Mtl example

MtlExample.hs

{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module MtlExample where

import Control.Monad.Reader
import Control.Monad.State
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Text (Text)
import Prelude

--

type ID = Int

-- A class of identifiable types, ie. types with an identity
class Entity a where
  identify :: a -> ID

-- A monad capable of getting entities given their identity
class (Monad m, Entity e) => GetEntity e m where
  getEntityById :: ID -> m (Maybe e)

--

-- Some user type
data User = MkUser
  { uid :: ID,
    name :: Text
  }
  deriving stock (Show)

-- User is identifiable ie. it is an entity
instance Entity User where
  identify = uid

-- This is function can get a User *but* cannot run arbitrary IO
-- GetEntity only has a generic Monad constraint which means it unifies
-- with *any* monad including Identity or State s, etc...
-- Try putting a putStrLn in there, it won't type check
getUserById :: (GetEntity User m) => ID -> m (Maybe User)
getUserById = getEntityById

--

-- Mock DB, ie. a map of ids and users
type MockDB = Map ID User

-- Production DB config
data ProdDB = MkProdDB
  { host :: Text,
    port :: Int,
    db :: Text
  }
  deriving stock (Show)

--

-- Mock context, pure, used eg. for testing
newtype Mock a = MkMock {unMock :: State MockDB a}
  deriving newtype (Functor, Applicative, Monad, MonadState MockDB)

runMock :: MockDB -> Mock a -> a
runMock mockDB = flip evalState mockDB . unMock

-- Knows how to get an entity purely
instance GetEntity User Mock where
  getEntityById :: ID -> Mock (Maybe User)
  getEntityById eid = gets (Map.lookup eid)

--

-- Production context, running in IO
newtype Prod a = MkProd {unProd :: ReaderT ProdDB IO a}
  deriving newtype (Functor, Applicative, Monad, MonadReader ProdDB, MonadIO)

runProd :: ProdDB -> Prod a -> IO a
runProd e = flip runReaderT e . unProd

-- Knows how to get an entity from a real DB
-- Note: undefined should be replaces with some DB library function
instance GetEntity User Prod where
  getEntityById :: ID -> Prod (Maybe User)
  getEntityById eid = do
    MkProdDB {..} <- ask
    liftIO $ undefined host port db eid

--

-- Sample mock DB
myMockDB :: MockDB
myMockDB =
  Map.fromList . zip [1 ..] $
    [ MkUser 1 "Aang",
      MkUser 2 "Katara",
      MkUser 3 "Sokka"
    ]

-- Sample prod DB config
myProdDB :: ProdDB
myProdDB = MkProdDB "localhost" 5432 "myDB"

-- Get a user using the mock context
mockUser :: ID -> Maybe User
mockUser = runMock myMockDB . getUserById

-- Get a user using the prod context
prodUser :: ID -> IO (Maybe User)
prodUser = runProd myProdDB . getUserById

{-
λ> mockUser 1
Just (MkUser {uid = 1, name = "Aang"})

λ> prodUser 1
*** Exception: Prelude.undefined -- well, needs a real DB function :)
-}