free-monad-example/src/Lib.hs

79 lines
2.6 KiB
Haskell

{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Lib where
import Control.Exception
import Control.Monad.Free.Church
import Database.PostgreSQL.Simple
import Data.Text
data SqlDBMethodF next where
SqlDBMethod :: FromRow r => (Connection -> Query -> IO [r]) -> ([r] -> next) -> SqlDBMethodF next
SqlThrowException :: Exception e => e -> (a -> next) -> SqlDBMethodF next
instance Functor SqlDBMethodF where
fmap f (SqlDBMethod runner next) = SqlDBMethod runner (f . next)
fmap f (SqlThrowException exceptionMsg next) = SqlThrowException exceptionMsg (f . next)
type SqlDb = F SqlDBMethodF
sqlDbMethod :: FromRow r => (Connection -> Query -> IO [r]) -> SqlDb [r]
sqlDbMethod action = liftF $ SqlDBMethod action id
sqlThrowException :: Exception e => e -> SqlDb a
sqlThrowException exception = liftF $ SqlThrowException exception id
interpretSqlDBMethod :: Connection -> Query -> SqlDBMethodF a -> IO a
interpretSqlDBMethod conn squery (SqlDBMethod runner next) = next <$> runner conn squery
interpretSqlDBMethod _ _ (SqlThrowException exception _) = throwIO exception
runDB :: Connection -> Query -> SqlDb a -> IO a
runDB conn squery = foldF $ interpretSqlDBMethod conn squery
data LoggerMethodF next where
LogMessage :: Text -> (() -> next) -> LoggerMethodF next
instance Functor LoggerMethodF where
fmap f (LogMessage msg next) = LogMessage msg (f . next)
type Logger = F LoggerMethodF
logMessage :: Text -> Logger ()
logMessage msg = liftF $ LogMessage msg id
interpretLoggerMethod :: LoggerMethodF a -> IO a
interpretLoggerMethod (LogMessage msg next) = next <$> print msg
runLogger :: Logger () -> IO ()
runLogger = foldF interpretLoggerMethod
data DSLMethod next where
LogMsg :: Logger () -> (() -> next) -> DSLMethod next
RunQuery :: FromRow r => Connection -> Query -> SqlDb [r] -> ([r] -> next) -> DSLMethod next
instance Functor DSLMethod where
fmap f (LogMsg msg next) = LogMsg msg (f . next)
fmap f (RunQuery conn squery act next) = RunQuery conn squery act (f . next)
type DSL = F DSLMethod
interpretDSLMethod :: DSLMethod a -> IO a
interpretDSLMethod (LogMsg logger next) =
fmap next $ runLogger logger
interpretDSLMethod (RunQuery conn squery sql next) =
fmap next $ runDB conn squery sql
runDSL :: DSL () -> IO ()
runDSL = foldF interpretDSLMethod
-- Smart constructors providing a convenient interface.
logMsg :: Text -> DSL ()
logMsg msg = liftF $ LogMsg (logMessage msg) id
runQuery :: (MonadFree DSLMethod m, FromRow r) => Connection -> Query -> m [r]
runQuery conn squery = liftF $ RunQuery conn squery (sqlDbMethod query_) id