src: Refactor DB and Logger out of lib

Signed-off-by: Sanchayan Maity <maitysanchayan@gmail.com>
This commit is contained in:
Sanchayan Maity 2020-07-28 18:27:33 +05:30
parent 08d89b1663
commit e4c13abefa
5 changed files with 72 additions and 47 deletions

13
src/DB/Interpreter.hs Normal file
View 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
View 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

View file

@ -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
View 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
View 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