src: Refactor DB and Logger out of lib
Signed-off-by: Sanchayan Maity <maitysanchayan@gmail.com>
This commit is contained in:
parent
08d89b1663
commit
e4c13abefa
5 changed files with 72 additions and 47 deletions
13
src/DB/Interpreter.hs
Normal file
13
src/DB/Interpreter.hs
Normal file
|
@ -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
|
23
src/DB/Language.hs
Normal file
23
src/DB/Language.hs
Normal file
|
@ -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
|
54
src/Lib.hs
54
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
|
||||
|
|
11
src/Logger/Interpreter.hs
Normal file
11
src/Logger/Interpreter.hs
Normal file
|
@ -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
|
||||
|
18
src/Logger/Language.hs
Normal file
18
src/Logger/Language.hs
Normal file
|
@ -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
|
||||
|
Loading…
Reference in a new issue