diff --git a/src/DB/Interpreter.hs b/src/DB/Interpreter.hs new file mode 100644 index 0000000..61da6cf --- /dev/null +++ b/src/DB/Interpreter.hs @@ -0,0 +1,13 @@ +module DB.Interpreter where + +import Control.Exception (throwIO) +import Control.Monad.Free.Church (foldF) +import Database.PostgreSQL.Simple (Connection, Query) +import DB.Language + +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 diff --git a/src/DB/Language.hs b/src/DB/Language.hs new file mode 100644 index 0000000..378308f --- /dev/null +++ b/src/DB/Language.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE GADTs #-} + +module DB.Language where + +import Control.Exception (Exception) +import Control.Monad.Free.Church (F, liftF) +import Database.PostgreSQL.Simple (Connection, FromRow, Query) + +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 diff --git a/src/Lib.hs b/src/Lib.hs index 6dd6c31..0a69aff 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -1,55 +1,15 @@ {-# 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 +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 diff --git a/src/Logger/Interpreter.hs b/src/Logger/Interpreter.hs new file mode 100644 index 0000000..44fd5e6 --- /dev/null +++ b/src/Logger/Interpreter.hs @@ -0,0 +1,11 @@ +module Logger.Interpreter where + +import Control.Monad.Free.Church (foldF) +import Logger.Language + +interpretLoggerMethod :: LoggerMethodF a -> IO a +interpretLoggerMethod (LogMessage msg next) = next <$> print msg + +runLogger :: Logger () -> IO () +runLogger = foldF interpretLoggerMethod + diff --git a/src/Logger/Language.hs b/src/Logger/Language.hs new file mode 100644 index 0000000..9cff8b9 --- /dev/null +++ b/src/Logger/Language.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE GADTs #-} + +module Logger.Language where + +import Control.Monad.Free.Church (F, liftF) +import Data.Text (Text) + +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 +