module Database.HDBC.Schema.Driver (
TypeMap,
Log, runLog,
LogChan, newLogChan, 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
= Warning String
| Error String
runLog :: (String -> t) -> (String -> t) -> Log -> t
runLog wf ef = d where
d (Warning m) = wf m
d (Error m) = ef m
data LogChan =
LogChan
{ chan :: IORef (DList Log)
, verboseAsWarning :: Bool
}
newLogChan :: Bool -> IO LogChan
newLogChan v =
LogChan <$> newIORef mempty <*> pure v
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 . Warning
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
putVerbose :: LogChan -> String -> IO ()
putVerbose lchan
| verboseAsWarning lchan = putWarning lchan . ("info: " ++)
| otherwise = const $ pure ()
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)