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