39 lines
1.3 KiB
Haskell
39 lines
1.3 KiB
Haskell
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
|
|
module Lib where
|
|
|
|
import Control.Monad.Free.Church (F, foldF, liftF, MonadFree)
|
|
import Database.PostgreSQL.Simple (Connection, FromRow, Query, query_)
|
|
import Data.Text (Text)
|
|
import DB.Interpreter (runDB)
|
|
import DB.Language (SqlDb, sqlDbMethod)
|
|
import Logger.Interpreter (runLogger)
|
|
import Logger.Language (Logger, logMessage)
|
|
|
|
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) =
|
|
next <$> runLogger logger
|
|
interpretDSLMethod (RunQuery conn squery sql next) =
|
|
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
|