module Database.HDBC.Schema.Driver (
TypeMap,
Log, foldLog,
LogChan, emptyLogChan, takeLogs, putWarning, putError, putVerbose,
failWith, hoistMaybe, maybeIO,
Driver(Driver, typeMap, driverConfig, getFieldsWithMap, getPrimaryKey),
emptyDriver,
getFields,
) where
import Language.Haskell.TH (TypeQ)
import Control.Applicative ((<$>), pure)
import Control.Monad (MonadPlus, mzero)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT (..))
import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
import Data.Monoid (mempty, (<>))
import Data.DList (DList, toList)
import Database.HDBC (IConnection)
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 conn =
Driver
{
typeMap :: TypeMap
, driverConfig :: Config
, getFieldsWithMap :: TypeMap
-> conn
-> LogChan
-> String
-> String
-> IO ([(String, TypeQ)], [Int])
, getPrimaryKey :: conn
-> LogChan
-> String
-> String
-> IO [String]
}
emptyDriver :: IConnection conn
=> Driver conn
emptyDriver = Driver [] defaultConfig (\_ _ _ _ _ -> return ([],[])) (\_ _ _ _ -> return [])
getFields :: IConnection conn
=> Driver conn
-> conn
-> LogChan
-> String
-> String
-> IO ([(String, TypeQ)], [Int])
getFields drv = getFieldsWithMap drv (typeMap drv)