-- |
-- Module      : Database.HDBC.Schema.Driver
-- Copyright   : 2013-2017 Kei Hibino
-- License     : BSD3
--
-- Maintainer  : ex8k.hibino@gmail.com
-- Stability   : experimental
-- Portability : unknown
--
-- This module provides driver interface
-- to load database system catalog via HDBC.
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)


-- | Mapping between type name string of DBMS and type in Haskell.
--   Type name string depends on specification of DBMS system catalogs.
type TypeMap = [(String, TypeQ)]

-- | Log string type for compile time.
data Log
  = Verbose String
  | Warning String
  | Error String

-- | Folding operation of 'Log' type.
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

-- | Channel to store compile-time warning messages.
newtype LogChan = LogChan { LogChan -> IORef (DList Log)
chan :: IORef (DList Log) }

-- | Build and return a new instance of 'LogChan'.
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

-- | Take all logs list from channel.
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)

-- | Push a warning string into 'LogChan'.
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

-- | Push an error string into 'LogChan'.
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

-- | Put verbose compile-time message as warning when 'verboseAsWarning'.
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

-- | Push an error string into 'LogChan' and return failed context.
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

-- | Hoist from 'Maybe' context into 'MaybeT'.
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

-- | Run 'MaybeT' with default value.
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

-- | Interface type to load database system catalog via HDBC.
data Driver conn =
  Driver
  { -- | Custom type mapping of this driver
    forall conn. Driver conn -> TypeMap
typeMap   :: TypeMap

    -- | Custom configuration for this driver
  , forall conn. Driver conn -> Config
driverConfig :: Config

    -- | Get column name and Haskell type pairs and not-null columns index.
  , forall conn.
Driver conn
-> TypeMap
-> conn
-> LogChan
-> String
-> String
-> IO (TypeMap, [Int])
getFieldsWithMap :: TypeMap                       --  Custom type mapping
                     -> conn                          --  Connection to query system catalog
                     -> LogChan
                     -> String                        --  Schema name string
                     -> String                        --  Table name string
                     -> IO ([(String, TypeQ)], [Int]) {-  Action to get column name and Haskell type pairs
                                                           and not-null columns index. -}

    -- | Get primary key column name.
  , forall conn.
Driver conn -> conn -> LogChan -> String -> String -> IO [String]
getPrimaryKey :: conn          --  Connection to query system catalog
                  -> LogChan
                  -> String        --  Schema name string
                  -> String        --  Table name string
                  -> IO [String]   --  Action to get column names of primary key
  }

-- | Empty definition of 'Driver'
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 [])

-- | Helper function to call 'getFieldsWithMap' using 'typeMap' of 'Driver'.
getFields :: IConnection conn
          => Driver conn   -- ^ driver record
          -> conn          -- ^ connection
          -> LogChan       -- ^ log channel
          -> String        -- ^ schema name string
          -> String        -- ^ table name 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)