MtlStyle.hs

{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE EmptyDataDeriving #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module MtlStyle where

import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Identity
import Data.Map.Strict qualified as Map
import Data.Map.Strict (Map)
import Data.Text
import GHC.Generics
import Control.Lens (view, over)
import Data.Generics.Product (HasType (..))


-------- Business data types --------

data Document = Document
  { contents :: Text
  }
  deriving (Show, Eq, Generic)

newtype DocumentId = DocumentId Text
  deriving (Show, Eq, Ord, Generic)

------------------------------------------------------
---------------- SERVICE LIBRARY CODE ----------------
------------------------------------------------------

class Monad m => MonadPersistDocument m where
  persistDocument :: DocumentId -> Document -> m ()
  getDocument :: DocumentId -> m (Maybe Document)


---------------- Real Implementation Transformer  ----------------
newtype RealPersistDocumentT m a = RealPersistDocumentT { runRealPersistDocument :: m a }
  deriving (Functor, Applicative, Monad) via m
  deriving (MonadTrans) via IdentityT

data ConnPool = ConnPool
  deriving (Show, Eq, Generic)

instance (MonadIO m, MonadReader env m, HasType ConnPool env) => MonadPersistDocument (RealPersistDocumentT m) where
  persistDocument docId doc = lift $ asks (view typed) >>= \ConnPool -> pure ()
  getDocument docId = lift $ asks (view typed) >>= \ConnPool -> pure Nothing
  -- predent we really did all this

---------------- Mock Implementation Transformer  ----------------
newtype MockPersistDocumentT m a = MockPersistDocumentT { runMockPersistDocumentT :: m a }
  deriving (Functor, Applicative, Monad) via m
  deriving (MonadTrans) via IdentityT

instance (Monad m, HasType (Map DocumentId Document) env, MonadState env m) => MonadPersistDocument (MockPersistDocumentT m) where
  persistDocument docId doc = lift $ modify $ over typed $ Map.insert docId doc
  getDocument     docId     = lift $ gets $ Map.lookup docId . view typed


-------------------------------------------
------------ APPLICATION CODE -------------
-------------------------------------------


---------------- Production Implementation  ----------------
data AppContext = AppContext
  { connection :: ConnPool
  }
  deriving (Show, Eq, Generic)

newtype MyApp a = MyApp (AppContext -> IO a)
  deriving (Functor, Applicative, Monad, MonadIO, MonadReader AppContext) via ReaderT AppContext IO
  deriving MonadPersistDocument via RealPersistDocumentT MyApp

---------------- Test Implementation  ----------------

data MyMockDatabase = MyMockDatabase { documents :: Map DocumentId Document }
  deriving (Show, Eq, Generic)


newtype TestMonad a = TestMonad (State MyMockDatabase a)
  deriving (Functor, Applicative, Monad, MonadState MyMockDatabase) via State MyMockDatabase
  deriving (MonadPersistDocument) via MockPersistDocumentT TestMonad

initialState :: MyMockDatabase
initialState = undefined

runTestMonad :: TestMonad a -> a
runTestMonad (TestMonad sma) = evalState sma initialState