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 :: forall t.
(String -> t) -> (String -> t) -> (String -> t) -> Log -> t
foldLog String -> t
vf String -> t
wf String -> t
ef = Log -> t
d where
d :: Log -> t
d (Verbose String
m) = String -> t
vf String
m
d (Warning String
m) = String -> t
wf String
m
d (Error String
m) = String -> t
ef String
m
newtype LogChan = LogChan { LogChan -> IORef (DList Log)
chan :: IORef (DList Log) }
emptyLogChan :: IO LogChan
emptyLogChan :: IO LogChan
emptyLogChan = IORef (DList Log) -> LogChan
LogChan forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (IORef a)
newIORef forall a. Monoid a => a
mempty
takeLogs :: LogChan -> IO [Log]
takeLogs :: LogChan -> IO [Log]
takeLogs LogChan
lchan = do
DList Log
xs <- forall a. IORef a -> IO a
readIORef forall a b. (a -> b) -> a -> b
$ LogChan -> IORef (DList Log)
chan LogChan
lchan
forall a. IORef a -> a -> IO ()
writeIORef (LogChan -> IORef (DList Log)
chan LogChan
lchan) forall a. Monoid a => a
mempty
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. DList a -> [a]
toList DList Log
xs
putLog :: LogChan -> Log -> IO ()
putLog :: LogChan -> Log -> IO ()
putLog LogChan
lchan Log
m = LogChan -> IORef (DList Log)
chan LogChan
lchan forall a. IORef a -> (a -> a) -> IO ()
`modifyIORef` (forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. Applicative f => a -> f a
pure Log
m)
putWarning :: LogChan -> String -> IO ()
putWarning :: LogChan -> String -> IO ()
putWarning LogChan
lchan = LogChan -> Log -> IO ()
putLog LogChan
lchan forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Log
Warning
putError :: LogChan -> String -> IO ()
putError :: LogChan -> String -> IO ()
putError LogChan
lchan = LogChan -> Log -> IO ()
putLog LogChan
lchan forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Log
Error
putVerbose :: LogChan -> String -> IO ()
putVerbose :: LogChan -> String -> IO ()
putVerbose LogChan
lchan = LogChan -> Log -> IO ()
putLog LogChan
lchan forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Log
Verbose
failWith :: LogChan -> String -> MaybeT IO a
failWith :: forall a. LogChan -> String -> MaybeT IO a
failWith LogChan
lchan String
m = do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ LogChan -> String -> IO ()
putError LogChan
lchan String
m
forall (m :: * -> *) a. MonadPlus m => m a
mzero
hoistM :: MonadPlus m => Maybe a -> m a
hoistM :: forall (m :: * -> *) a. MonadPlus m => Maybe a -> m a
hoistM = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *) a. MonadPlus m => m a
mzero forall (m :: * -> *) a. Monad m => a -> m a
return
hoistMaybe :: Monad m => Maybe a -> MaybeT m a
hoistMaybe :: forall (m :: * -> *) a. Monad m => Maybe a -> MaybeT m a
hoistMaybe = forall (m :: * -> *) a. MonadPlus m => Maybe a -> m a
hoistM
maybeT :: Functor f => b -> (a -> b) -> MaybeT f a -> f b
maybeT :: forall (f :: * -> *) b a.
Functor f =>
b -> (a -> b) -> MaybeT f a -> f b
maybeT b
zero a -> b
f = (forall b a. b -> (a -> b) -> Maybe a -> b
maybe b
zero a -> b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT
maybeIO :: b -> (a -> b) -> MaybeT IO a -> IO b
maybeIO :: forall b a. b -> (a -> b) -> MaybeT IO a -> IO b
maybeIO = forall (f :: * -> *) b a.
Functor f =>
b -> (a -> b) -> MaybeT f a -> f b
maybeT
data Driver conn =
Driver
{
forall conn. Driver conn -> TypeMap
typeMap :: TypeMap
, forall conn. Driver conn -> Config
driverConfig :: Config
, forall conn.
Driver conn
-> TypeMap
-> conn
-> LogChan
-> String
-> String
-> IO (TypeMap, [Int])
getFieldsWithMap :: TypeMap
-> conn
-> LogChan
-> String
-> String
-> IO ([(String, TypeQ)], [Int])
, forall conn.
Driver conn -> conn -> LogChan -> String -> String -> IO [String]
getPrimaryKey :: conn
-> LogChan
-> String
-> String
-> IO [String]
}
emptyDriver :: IConnection conn
=> Driver conn
emptyDriver :: forall conn. IConnection conn => Driver conn
emptyDriver = forall conn.
TypeMap
-> Config
-> (TypeMap
-> conn -> LogChan -> String -> String -> IO (TypeMap, [Int]))
-> (conn -> LogChan -> String -> String -> IO [String])
-> Driver conn
Driver [] Config
defaultConfig (\TypeMap
_ conn
_ LogChan
_ String
_ String
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ([],[])) (\conn
_ LogChan
_ String
_ String
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return [])
getFields :: IConnection conn
=> Driver conn
-> conn
-> LogChan
-> String
-> String
-> IO ([(String, TypeQ)], [Int])
getFields :: forall conn.
IConnection conn =>
Driver conn
-> conn -> LogChan -> String -> String -> IO (TypeMap, [Int])
getFields Driver conn
drv = forall conn.
Driver conn
-> TypeMap
-> conn
-> LogChan
-> String
-> String
-> IO (TypeMap, [Int])
getFieldsWithMap Driver conn
drv (forall conn. Driver conn -> TypeMap
typeMap Driver conn
drv)