module Database.Schema.PostgreSQL.Pure.Driver (
TypeMap,
Log, foldLog,
LogChan, emptyLogChan, takeLogs, putWarning, putError, putVerbose,
failWith, hoistMaybe, maybeIO,
Driver(Driver, typeMap, driverConfig, getFieldsWithMap, getPrimaryKey),
emptyDriver,
getFields,
) where
import Control.Monad (MonadPlus, mzero)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT (runMaybeT))
import Data.DList (DList, toList)
import Data.IORef (IORef, modifyIORef, newIORef, readIORef, writeIORef)
import Language.Haskell.TH (TypeQ)
import Database.PostgreSQL.Pure (Connection)
import Database.Relational (Config, defaultConfig)
type TypeMap = [(String, TypeQ)]
data Log
= Verbose String
| Warning String
| Error String
foldLog :: (String -> t) -> (String -> t) -> (String -> t) -> Log -> t
foldLog vf wf ef = d where
d (Verbose m) = vf m
d (Warning m) = wf m
d (Error m) = ef m
newtype LogChan = LogChan { chan :: IORef (DList Log) }
emptyLogChan :: IO LogChan
emptyLogChan = LogChan <$> newIORef mempty
takeLogs :: LogChan -> IO [Log]
takeLogs lchan = do
xs <- readIORef $ chan lchan
writeIORef (chan lchan) mempty
return $ toList xs
putLog :: LogChan -> Log -> IO ()
putLog lchan m = chan lchan `modifyIORef` (<> pure m)
putWarning :: LogChan -> String -> IO ()
putWarning lchan = putLog lchan . Warning
putError :: LogChan -> String -> IO ()
putError lchan = putLog lchan . Error
putVerbose :: LogChan -> String -> IO ()
putVerbose lchan = putLog lchan . Verbose
failWith :: LogChan -> String -> MaybeT IO a
failWith lchan m = do
lift $ putError lchan m
mzero
hoistM :: MonadPlus m => Maybe a -> m a
hoistM = maybe mzero return
hoistMaybe :: Monad m => Maybe a -> MaybeT m a
hoistMaybe = hoistM
maybeT :: Functor f => b -> (a -> b) -> MaybeT f a -> f b
maybeT zero f = (maybe zero f <$>) . runMaybeT
maybeIO :: b -> (a -> b) -> MaybeT IO a -> IO b
maybeIO = maybeT
data Driver =
Driver
{
typeMap :: TypeMap
, driverConfig :: Config
, getFieldsWithMap :: TypeMap
-> Connection
-> LogChan
-> String
-> String
-> IO ([(String, TypeQ)], [Int])
, getPrimaryKey :: Connection
-> LogChan
-> String
-> String
-> IO [String]
}
emptyDriver :: Driver
emptyDriver = Driver [] defaultConfig (\_ _ _ _ _ -> return ([],[])) (\_ _ _ _ -> return [])
getFields :: Driver
-> Connection
-> LogChan
-> String
-> String
-> IO ([(String, TypeQ)], [Int])
getFields drv conn log scm tbl =
getFieldsWithMap drv (typeMap drv) conn log scm tbl