packages feed

relational-query-HDBC 0.1.0.1 → 0.2.0.0

raw patch · 9 files changed

+327/−190 lines, 9 filesdep +dlistdep +transformersdep ~relational-query

Dependencies added: dlist, transformers

Dependency ranges changed: relational-query

Files

relational-query-HDBC.cabal view
@@ -1,5 +1,5 @@ name:                relational-query-HDBC-version:             0.1.0.1+version:             0.2.0.0 synopsis:            HDBC instance of relational-query and typed query interface for HDBC description:         This package contains the HDBC instance of relational-query and                      the typed query interface for HDBC.@@ -43,12 +43,14 @@    build-depends:         base <5                        , containers+                       , transformers                        , convertible                        , template-haskell+                       , dlist                         , names-th                        , persistable-record-                       , relational-query+                       , relational-query >= 0.6.1                        , relational-schemas                        , HDBC >=2                        , HDBC-session
src/Database/HDBC/Query/TH.hs view
@@ -28,24 +28,26 @@  import Data.Maybe (listToMaybe, fromMaybe) import qualified Data.Map as Map+import Control.Applicative ((<$>), (<*>)) import Control.Monad (when)  import Database.HDBC (IConnection, SqlValue, prepare)  import Language.Haskell.TH (Q, runIO, Name, TypeQ, Dec) import Language.Haskell.TH.Name.CamelCase (ConName, varCamelcaseName)-import Language.Haskell.TH.Lib.Extra (reportWarning, reportMessage)+import Language.Haskell.TH.Lib.Extra (reportWarning, reportError, reportMessage)  import Database.Record.TH (makeRecordPersistableWithSqlTypeDefault) import qualified Database.Record.TH as Record-import Database.Relational.Query (Relation, Config, defaultConfig, relationalQuerySQL)+import Database.Relational.Query (Relation, Config, verboseAsCompilerWarning, defaultConfig, relationalQuerySQL) import Database.Relational.Query.SQL (QuerySuffix) import qualified Database.Relational.Query.TH as Relational  import Database.HDBC.Session (withConnectionIO) import Database.HDBC.Record.Persistable () -import Database.HDBC.Schema.Driver (Driver, getFields, getPrimaryKey)+import Database.HDBC.Schema.Driver+  (runLog, newLogChan, takeLogs, Driver, getFields, getPrimaryKey)   -- | Generate all persistable templates against defined record like type constructor.@@ -95,15 +97,17 @@                    -> [ConName]   -- ^ Derivings                    -> Q [Dec]     -- ^ Result declaration defineTableFromDB' connect config drv scm tbl derives = do-  let getDBinfo =-        withConnectionIO connect-        (\conn ->  do-            (cols, notNullIdxs) <- getFields drv conn scm tbl-            primCols            <- getPrimaryKey drv conn scm tbl--            return (cols, notNullIdxs, primCols) )+  let getDBinfo = do+        logChan  <-  newLogChan $ verboseAsCompilerWarning config+        infoP    <-  withConnectionIO connect+                     (\conn ->+                       (,)+                       <$> getFields drv conn logChan scm tbl+                       <*> getPrimaryKey drv conn logChan scm tbl)+        (,) infoP <$> takeLogs logChan -  (cols, notNullIdxs, primaryCols) <- runIO getDBinfo+  (((cols, notNullIdxs), primaryCols), logs) <- runIO getDBinfo+  mapM_ (runLog reportWarning reportError) logs   when (null primaryCols) . reportWarning     $ "getPrimaryKey: Primary key not found for table: " ++ scm ++ "." ++ tbl
src/Database/HDBC/Schema/Driver.hs view
@@ -11,12 +11,24 @@ -- to load database system catalog via HDBC. module Database.HDBC.Schema.Driver (   TypeMap,++  Log, runLog,+  LogChan, newLogChan, takeLogs, putWarning, putError, putVerbose,+  failWith, hoistMaybe, maybeIO,+   Driver(Driver, typeMap, getFieldsWithMap, getPrimaryKey),   emptyDriver,   getFields   ) where  import Database.HDBC (IConnection)+import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)+import Data.Monoid (mempty, (<>))+import Data.DList (DList, toList)+import Control.Applicative ((<$>), pure, (<*>))+import Control.Monad (MonadPlus, mzero)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Maybe (MaybeT (..)) import Language.Haskell.TH (TypeQ)  @@ -24,6 +36,73 @@ --   Type name string depends on specification of DBMS system catalogs. type TypeMap = [(String, TypeQ)] +-- | Log string type for compile time.+data Log+  = Warning String+  | Error String++-- | Folding operation of 'Log' type.+runLog :: (String -> t) -> (String -> t) -> Log -> t+runLog wf ef = d  where+  d (Warning m) = wf m+  d (Error m)   = ef m++-- | Channel to store compile-time warning messages.+data LogChan =+  LogChan+  { chan :: IORef (DList Log)+  , verboseAsWarning :: Bool+  }++-- | Build and return a new instance of 'LogChan'.+newLogChan :: Bool -> IO LogChan+newLogChan v =+  LogChan <$> newIORef mempty <*> pure v++-- | Take all logs list from channel.+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)++-- | Push a warning string into 'LogChan'.+putWarning :: LogChan -> String -> IO ()+putWarning lchan = putLog lchan . Warning++-- | Push an error string into 'LogChan'.+putError :: LogChan -> String -> IO ()+putError lchan = putLog lchan . Warning++-- | Push an error string into 'LogChan' and return failed context.+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++-- | Hoist from 'Maybe' context into 'MaybeT'.+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++-- | Run 'MaybeT' with default value.+maybeIO :: b -> (a -> b) -> MaybeT IO a -> IO b+maybeIO = maybeT++-- | Put verbose compile-time message as warning when 'verboseAsWarning'.+putVerbose :: LogChan -> String -> IO ()+putVerbose lchan+  | verboseAsWarning lchan  =  putWarning lchan . ("info: " ++)+  | otherwise               =  const $ pure ()+ -- | Interface type to load database system catalog via HDBC. data Driver conn =   Driver@@ -33,12 +112,15 @@     -- | Get column name and Haskell type pairs and not-null columns index.   , 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.+                     -> IO ([(String, TypeQ)], [Int]) {-  Action to get column name and Haskell type pairs+                                                           and not-null columns index. -}      -- | Get primary key column name.   , 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@@ -46,8 +128,8 @@  -- | Empty definition of 'Driver' emptyDriver :: IConnection conn => Driver conn-emptyDriver =  Driver [] (\_ _ _ _ -> return ([],[])) (\_ _ _ -> return [])+emptyDriver =  Driver [] (\_ _ _ _ _ -> return ([],[])) (\_ _ _ _ -> return [])  -- | Helper function to call 'getFieldsWithMap' using 'typeMap' of 'Driver'.-getFields :: IConnection conn => Driver conn -> conn -> String -> String -> IO ([(String, TypeQ)], [Int])+getFields :: IConnection conn => Driver conn -> conn -> LogChan -> String -> String -> IO ([(String, TypeQ)], [Int]) getFields drv = getFieldsWithMap drv (typeMap drv)
src/Database/HDBC/Schema/IBMDB2.hs view
@@ -24,12 +24,13 @@ import qualified Data.List as List import Data.Char (toUpper) import Data.Map (fromList)-import Control.Monad (when)+import Control.Applicative ((<$>), (<|>))+import Control.Monad (guard)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Maybe (MaybeT)  import Database.HDBC (IConnection, SqlValue) -import Language.Haskell.TH.Lib.Extra (reportMessage)- import Database.HDBC.Record.Query (runQuery') import Database.HDBC.Record.Persistable () @@ -41,7 +42,8 @@ import qualified Database.Relational.Schema.DB2Syscat.Columns as Columns  import Database.HDBC.Schema.Driver-  (TypeMap, Driver, getFieldsWithMap, getPrimaryKey, emptyDriver)+  (TypeMap, LogChan, putVerbose, failWith, maybeIO, hoistMaybe,+   Driver, getFieldsWithMap, getPrimaryKey, emptyDriver)   -- Specify type constructor and data constructor from same table name.@@ -51,48 +53,49 @@ logPrefix :: String -> String logPrefix =  ("IBMDB2: " ++) -putLog :: String -> IO ()-putLog =  reportMessage . logPrefix+putLog :: LogChan -> String -> IO ()+putLog lchan =  putVerbose lchan . logPrefix -compileErrorIO :: String -> IO a-compileErrorIO =  fail . logPrefix+compileError :: LogChan -> String -> MaybeT IO a+compileError lchan = failWith lchan . logPrefix  getPrimaryKey' :: IConnection conn-              => conn-              -> String-              -> String-              -> IO [String]-getPrimaryKey' conn scm' tbl' = do+               => conn+               -> LogChan+               -> String+               -> String+               -> IO [String]+getPrimaryKey' conn lchan scm' tbl' = do   let tbl = map toUpper tbl'       scm = map toUpper scm'   primCols <- runQuery' conn primaryKeyQuerySQL (scm, tbl)-  let primaryKeyCols = normalizeColumn `fmap` primCols-  putLog $ "getPrimaryKey: primary key = " ++ show primaryKeyCols+  let primaryKeyCols = normalizeColumn <$> primCols+  putLog lchan $ "getPrimaryKey: primary key = " ++ show primaryKeyCols    return primaryKeyCols  getColumns' :: IConnection conn-          => TypeMap-          -> conn-          -> String-          -> String-          -> IO ([(String, TypeQ)], [Int])-getColumns' tmap conn scm' tbl' = do+            => TypeMap+            -> conn+            -> LogChan+            -> String+            -> String+            -> IO ([(String, TypeQ)], [Int])+getColumns' tmap conn lchan scm' tbl' = maybeIO ([], []) id $ do   let tbl = map toUpper tbl'       scm = map toUpper scm' -  cols <- runQuery' conn columnsQuerySQL (scm, tbl)-  when (null cols) . compileErrorIO-    $ "getFields: No columns found: schema = " ++ scm ++ ", table = " ++ tbl+  cols <- lift $ runQuery' conn columnsQuerySQL (scm, tbl)+  guard (not $ null cols) <|>+    compileError lchan ("getFields: No columns found: schema = " ++ scm ++ ", table = " ++ tbl)    let notNullIdxs = map fst . filter (notNull . snd) . zip [0..] $ cols-  putLog+  lift . putLog lchan     $  "getFields: num of columns = " ++ show (List.length cols)     ++ ", not null columns = " ++ show notNullIdxs-  let getType' col = case getType (fromList tmap) col of-        Nothing -> compileErrorIO-                   $ "Type mapping is not defined against DB2 type: " ++ Columns.typename col-        Just p  -> return p+  let getType' col =+        hoistMaybe (getType (fromList tmap) col) <|>+        compileError lchan ("Type mapping is not defined against DB2 type: " ++ Columns.typename col)    types <- mapM getType' cols   return (types, notNullIdxs)
src/Database/HDBC/Schema/MySQL.hs view
@@ -1,6 +1,15 @@ {-# OPTIONS_GHC -fno-warn-orphans  #-} {-# LANGUAGE TemplateHaskell       #-} {-# LANGUAGE MultiParamTypeClasses #-}++-- |+-- Module      : Database.HDBC.Schema.MySQL+-- Copyright   : 2013 Sho KURODA+-- License     : BSD3+--+-- Maintainer  : krdlab@gmail.com+-- Stability   : experimental+-- Portability : unknown module Database.HDBC.Schema.MySQL     (       driverMySQL@@ -9,7 +18,10 @@  import           Prelude                            hiding (length) import           Language.Haskell.TH                (TypeQ)-import           Language.Haskell.TH.Lib.Extra      (reportMessage)+import           Control.Applicative                ((<$>), (<|>))+import           Control.Monad                      (guard)+import           Control.Monad.Trans.Class          (lift)+import           Control.Monad.Trans.Maybe          (MaybeT) import qualified Data.List                          as List import           Data.Map                           (fromList) @@ -17,6 +29,11 @@ import           Database.HDBC.Record.Query         (runQuery') import           Database.HDBC.Record.Persistable   () import           Database.HDBC.Schema.Driver        ( TypeMap+                                                    , LogChan+                                                    , putVerbose+                                                    , failWith+                                                    , maybeIO+                                                    , hoistMaybe                                                     , Driver                                                     , getFieldsWithMap                                                     , getPrimaryKey@@ -38,52 +55,52 @@ logPrefix :: String -> String logPrefix = ("MySQL: " ++) -putLog :: String -> IO ()-putLog = reportMessage . logPrefix+putLog :: LogChan -> String -> IO ()+putLog lchan = putVerbose lchan . logPrefix -compileErrorIO :: String -> IO a-compileErrorIO = fail . logPrefix+compileError :: LogChan -> String -> MaybeT IO a+compileError lchan = failWith lchan . logPrefix  getPrimaryKey' :: IConnection conn                => conn+               -> LogChan                -> String                -> String                -> IO [String]-getPrimaryKey' conn scm tbl = do+getPrimaryKey' conn lchan scm tbl = do     primCols <- runQuery' conn primaryKeyQuerySQL (scm, tbl)-    let primaryKeyCols = normalizeColumn `fmap` primCols-    putLog $ "getPrimaryKey: primary key = " ++ show primaryKeyCols+    let primaryKeyCols = normalizeColumn <$> primCols+    putLog lchan $ "getPrimaryKey: primary key = " ++ show primaryKeyCols     return primaryKeyCols -getFields' :: IConnection conn-           => TypeMap-           -> conn-           -> String-           -> String-           -> IO ([(String, TypeQ)], [Int])-getFields' tmap conn scm tbl = do-    cols <- runQuery' conn columnsQuerySQL (scm, tbl)-    case cols of-        [] -> compileErrorIO-                $ "getFields: No columns found: schema = " ++ scm-                ++ ", table = " ++ tbl-        _  -> return ()+getColumns' :: IConnection conn+            => TypeMap+            -> conn+            -> LogChan+            -> String+            -> String+            -> IO ([(String, TypeQ)], [Int])+getColumns' tmap conn lchan scm tbl = maybeIO ([], []) id $ do+    cols <- lift $ runQuery' conn columnsQuerySQL (scm, tbl)+    guard (not $ null cols) <|>+      compileError lchan+      ("getFields: No columns found: schema = " ++ scm+       ++ ", table = " ++ tbl)     let notNullIdxs = map fst . filter (notNull . snd) . zip [0..] $ cols-    putLog+    lift . putLog lchan       $  "getFields: num of columns = " ++ show (List.length cols)       ++ ", not null columns = " ++ show notNullIdxs     types <- mapM getType' cols     return (types, notNullIdxs)     where         getType' col =-            case getType (fromList tmap) col of-                Nothing -> compileErrorIO-                             $ "Type mapping is not defined against MySQL type: "-                             ++ Columns.dataType col-                Just p  -> return p+            hoistMaybe (getType (fromList tmap) col) <|>+            compileError lchan+            ("Type mapping is not defined against MySQL type: "+             ++ Columns.dataType col)  -- | Driver implementation driverMySQL :: IConnection conn => Driver conn driverMySQL =-    emptyDriver { getFieldsWithMap = getFields' }+    emptyDriver { getFieldsWithMap = getColumns' }                 { getPrimaryKey    = getPrimaryKey' }
src/Database/HDBC/Schema/Oracle.hs view
@@ -1,23 +1,34 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-} +-- |+-- Module      : Database.HDBC.Schema.MySQL+-- Copyright   : 2013 Shohei Yasutake+-- License     : BSD3+--+-- Maintainer  : amutake.s@gmail.com+-- Stability   : experimental+-- Portability : unknown module Database.HDBC.Schema.Oracle     ( driverOracle     ) where -import Control.Applicative ((<$>))+import Control.Applicative ((<$>), (<|>))+import Control.Monad (guard)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Maybe (MaybeT) import Data.Char (toUpper) import Data.Map (fromList) import Data.Maybe (catMaybes) import Language.Haskell.TH (TypeQ)-import Language.Haskell.TH.Lib.Extra (reportMessage)  import Database.HDBC (IConnection, SqlValue) import Database.HDBC.Record.Query (runQuery') import Database.HDBC.Record.Persistable () import Database.Record.TH (makeRecordPersistableWithSqlTypeDefaultFromDefined) import Database.HDBC.Schema.Driver-    ( TypeMap, Driver, getFieldsWithMap, getPrimaryKey, emptyDriver+    ( TypeMap, LogChan, putVerbose, failWith, maybeIO, hoistMaybe,+      Driver, getFieldsWithMap, getPrimaryKey, emptyDriver     )  import Database.Relational.Schema.Oracle@@ -34,53 +45,53 @@ logPrefix :: String -> String logPrefix = ("Oracle: " ++) -putLog :: String -> IO ()-putLog = reportMessage . logPrefix+putLog :: LogChan -> String -> IO ()+putLog lchan = putVerbose lchan . logPrefix -compileErrorIO :: String -> IO a-compileErrorIO = fail . logPrefix+compileError :: LogChan -> String -> MaybeT IO a+compileError lchan = failWith lchan . logPrefix  getPrimaryKey' :: IConnection conn                => conn+               -> LogChan                -> String -- ^ owner name                -> String -- ^ table name                -> IO [String] -- ^ primary key names-getPrimaryKey' conn owner' tbl' = do+getPrimaryKey' conn lchan owner' tbl' = do     let owner = map toUpper owner'         tbl = map toUpper tbl'     prims <- map normalizeColumn . catMaybes <$>         runQuery' conn primaryKeyQuerySQL (owner, tbl)-    putLog $ "getPrimaryKey: keys = " ++ show prims+    putLog lchan $ "getPrimaryKey: keys = " ++ show prims     return prims -getFields' :: IConnection conn-           => TypeMap-           -> conn-           -> String-           -> String-           -> IO ([(String, TypeQ)], [Int])-getFields' tmap conn owner' tbl' = do+getColumns' :: IConnection conn+            => TypeMap+            -> conn+            -> LogChan+            -> String+            -> String+            -> IO ([(String, TypeQ)], [Int])+getColumns' tmap conn lchan owner' tbl' = maybeIO ([], []) id $ do     let owner = map toUpper owner'         tbl = map toUpper tbl'-    cols <- runQuery' conn columnsQuerySQL (owner, tbl)-    case cols of-        [] -> compileErrorIO $-            "getFields: No columns found: owner = " ++ owner ++ ", table = " ++ tbl-        _ -> return ()+    cols <- lift $ runQuery' conn columnsQuerySQL (owner, tbl)+    guard (not $ null cols) <|>+        compileError lchan+        ("getFields: No columns found: owner = " ++ owner ++ ", table = " ++ tbl)     let notNullIdxs = map fst . filter (notNull . snd) . zip [0..] $ cols-    putLog $+    lift . putLog lchan $         "getFields: num of columns = " ++ show (length cols) ++         ", not null columns = " ++ show notNullIdxs-    let getType' col = case getType (fromList tmap) col of-            Nothing -> compileErrorIO $-                "Type mapping is not defined against Oracle DB type: " ++-                show (Cols.dataType col)-            Just p -> return p+    let getType' col =+          hoistMaybe (getType (fromList tmap) col) <|>+          compileError lchan+          ("Type mapping is not defined against Oracle DB type: " ++ show (Cols.dataType col))     types <- mapM getType' cols     return (types, notNullIdxs)  -- | Driver for Oracle DB driverOracle :: IConnection conn => Driver conn driverOracle =-    emptyDriver { getFieldsWithMap = getFields' }+    emptyDriver { getFieldsWithMap = getColumns' }                 { getPrimaryKey = getPrimaryKey' }
src/Database/HDBC/Schema/PostgreSQL.hs view
@@ -21,12 +21,13 @@  import Data.Char (toLower) import Data.Map (fromList)-import Control.Monad (when)+import Control.Applicative ((<$>), (<|>))+import Control.Monad (guard)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Maybe (MaybeT)  import Database.HDBC (IConnection, SqlValue) -import Language.Haskell.TH.Lib.Extra (reportMessage)- import Database.HDBC.Record.Query (runQuery') import Database.HDBC.Record.Persistable () @@ -40,7 +41,8 @@ import qualified Database.Relational.Schema.PgCatalog.PgType as Type  import Database.HDBC.Schema.Driver-  (TypeMap, Driver, getFieldsWithMap, getPrimaryKey, emptyDriver)+  (TypeMap, LogChan, putVerbose, failWith, maybeIO, hoistMaybe,+   Driver, getFieldsWithMap, getPrimaryKey, emptyDriver)   $(makeRecordPersistableWithSqlTypeDefaultFromDefined@@ -52,55 +54,56 @@ logPrefix :: String -> String logPrefix =  ("PostgreSQL: " ++) -putLog :: String -> IO ()-putLog =  reportMessage . logPrefix+putLog :: LogChan -> String -> IO ()+putLog lchan = putVerbose lchan . logPrefix -compileErrorIO :: String -> IO a-compileErrorIO =  fail . logPrefix+compileError :: LogChan -> String -> MaybeT IO a+compileError lchan = failWith lchan . logPrefix  getPrimaryKey' :: IConnection conn-              => conn-              -> String-              -> String-              -> IO [String]-getPrimaryKey' conn scm' tbl' = do+               => conn+               -> LogChan+               -> String+               -> String+               -> IO [String]+getPrimaryKey' conn lchan scm' tbl' = do   let scm = map toLower scm'       tbl = map toLower tbl'   mayKeyLen <- runQuery' conn primaryKeyLengthQuerySQL (scm, tbl)   case mayKeyLen of     []        -> do-      putLog   "getPrimaryKey: Primary key not found."+      putLog lchan   "getPrimaryKey: Primary key not found."       return []     [keyLen]  -> do       primCols <- runQuery' conn (primaryKeyQuerySQL keyLen) (scm, tbl)-      let primaryKeyCols = normalizeColumn `fmap` primCols-      putLog $ "getPrimaryKey: primary key = " ++ show primaryKeyCols+      let primaryKeyCols = normalizeColumn <$> primCols+      putLog lchan $ "getPrimaryKey: primary key = " ++ show primaryKeyCols       return primaryKeyCols     _:_:_     -> do-      putLog   "getPrimaryKey: Fail to detect primary key. Something wrong."+      putLog lchan   "getPrimaryKey: Fail to detect primary key. Something wrong."       return []  getColumns' :: IConnection conn-          => TypeMap-          -> conn-          -> String-          -> String-          -> IO ([(String, TypeQ)], [Int])-getColumns' tmap conn scm' tbl' = do+            => TypeMap+            -> conn+            -> LogChan+            -> String+            -> String+            -> IO ([(String, TypeQ)], [Int])+getColumns' tmap conn lchan scm' tbl' = maybeIO ([], []) id $ do   let scm = map toLower scm'       tbl = map toLower tbl'-  cols <- runQuery' conn columnQuerySQL (scm, tbl)-  when (null cols) . compileErrorIO-    $ "getFields: No columns found: schema = " ++ scm ++ ", table = " ++ tbl+  cols <- lift $ runQuery' conn columnQuerySQL (scm, tbl)+  guard (not $ null cols) <|>+    compileError lchan ("getFields: No columns found: schema = " ++ scm ++ ", table = " ++ tbl)    let notNullIdxs = map fst . filter (notNull . snd) . zip [0..] $ cols-  putLog+  lift . putLog lchan     $  "getFields: num of columns = " ++ show (length cols)     ++ ", not null columns = " ++ show notNullIdxs-  let getType' col = case getType (fromList tmap) col of-        Nothing -> compileErrorIO-                   $ "Type mapping is not defined against PostgreSQL type: " ++ Type.typname (snd col)-        Just p  -> return p+  let getType' col =+        hoistMaybe (getType (fromList tmap) col) <|>+        compileError lchan ("Type mapping is not defined against PostgreSQL type: " ++ Type.typname (snd col))    types <- mapM getType' cols   return (types, notNullIdxs)
src/Database/HDBC/Schema/SQLServer.hs view
@@ -17,20 +17,26 @@ import qualified Database.Relational.Schema.SQLServerSyscat.Columns as Columns import qualified Database.Relational.Schema.SQLServerSyscat.Types as Types +import Control.Applicative ((<$>), (<|>))+import Control.Monad (guard)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Maybe (MaybeT) import Data.Map (fromList) import Data.Maybe (catMaybes) import Database.HDBC (IConnection, SqlValue) import Database.HDBC.Record.Query (runQuery') import Database.HDBC.Record.Persistable ()-import Database.HDBC.Schema.Driver (TypeMap, Driver, getFieldsWithMap, getPrimaryKey, emptyDriver)+import Database.HDBC.Schema.Driver+  (TypeMap, LogChan, putVerbose, failWith, maybeIO,+   Driver, hoistMaybe, getFieldsWithMap, getPrimaryKey, emptyDriver) import Database.Record.TH (makeRecordPersistableWithSqlTypeDefaultFromDefined) import Database.Relational.Schema.SQLServer (columnTypeQuerySQL, getType, normalizeColumn,                                             notNull, primaryKeyQuerySQL) import Database.Relational.Schema.SQLServerSyscat.Columns (Columns) import Database.Relational.Schema.SQLServerSyscat.Types (Types) import Language.Haskell.TH (TypeQ)-import Language.Haskell.TH.Lib.Extra (reportMessage) + $(makeRecordPersistableWithSqlTypeDefaultFromDefined   [t| SqlValue |] ''Columns) @@ -40,49 +46,51 @@ logPrefix :: String -> String logPrefix = ("SQLServer: " ++) -putLog :: String -> IO ()-putLog = reportMessage . logPrefix+putLog :: LogChan -> String -> IO ()+putLog lchan = putVerbose lchan . logPrefix -compileErrorIO :: String -> IO a-compileErrorIO =  fail . logPrefix+compileError :: LogChan -> String -> MaybeT IO a+compileError lchan = failWith lchan . logPrefix  getPrimaryKey' :: IConnection conn                => conn+               -> LogChan                -> String                -> String                -> IO [String]-getPrimaryKey' conn scm tbl = do-    prims <- catMaybes `fmap` runQuery' conn primaryKeyQuerySQL (scm,tbl)+getPrimaryKey' conn lchan scm tbl = do+    prims <- catMaybes <$> runQuery' conn primaryKeyQuerySQL (scm,tbl)     let primColumns = map normalizeColumn prims-    putLog $ "getPrimaryKey: keys=" ++ show primColumns+    putLog lchan $ "getPrimaryKey: keys=" ++ show primColumns     return primColumns -getFields' :: IConnection conn-           => TypeMap-           -> conn-           -> String-           -> String-           -> IO ([(String, TypeQ)], [Int])-getFields' tmap conn scm tbl = do-    rows <- runQuery' conn columnTypeQuerySQL (scm, tbl)-    case rows of-      [] -> compileErrorIO-            $ "getFields: No columns found: schema = " ++ scm ++ ", table = " ++ tbl-      _  -> return ()+getColumns' :: IConnection conn+            => TypeMap+            -> conn+            -> LogChan+            -> String+            -> String+            -> IO ([(String, TypeQ)], [Int])+getColumns' tmap conn lchan scm tbl = maybeIO ([], []) id $ do+    rows <- lift $ runQuery' conn columnTypeQuerySQL (scm, tbl)+    guard (not $ null rows) <|>+      compileError lchan+      ("getFields: No columns found: schema = " ++ scm ++ ", table = " ++ tbl)     let columnId ((cols,_),_) = Columns.columnId cols - 1     let notNullIdxs = map (fromIntegral . columnId) . filter notNull $ rows-    putLog+    lift . putLog lchan         $ "getFields: num of columns = " ++ show (length rows)         ++ ", not null columns = " ++ show notNullIdxs-    let getType' rec@((_,typs),typScms) = case getType (fromList tmap) rec of-          Nothing -> compileErrorIO-                     $ "Type mapping is not defined against SQLServer type: "-                     ++ typScms ++ "." ++ Types.name typs-          Just p  -> return p+    let getType' rec'@((_,typs),typScms) =+          hoistMaybe (getType (fromList tmap) rec') <|>+          compileError lchan+          ("Type mapping is not defined against SQLServer type: "+           ++ typScms ++ "." ++ Types.name typs)     types <- mapM getType' rows     return (types, notNullIdxs) +-- | Driver implementation driverSQLServer :: IConnection conn => Driver conn driverSQLServer =-    emptyDriver { getFieldsWithMap = getFields' }+    emptyDriver { getFieldsWithMap = getColumns' }                 { getPrimaryKey    = getPrimaryKey' }
src/Database/HDBC/Schema/SQLite3.hs view
@@ -18,12 +18,18 @@ import qualified Database.Relational.Schema.SQLite3Syscat.IndexList as IndexList import qualified Database.Relational.Schema.SQLite3Syscat.TableInfo as TableInfo +import Control.Applicative ((<|>))+import Control.Monad (guard)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Maybe (MaybeT) import Data.List (isPrefixOf, sort, sortBy) import Data.Map (fromList) import Database.HDBC (IConnection, SqlValue) import Database.HDBC.Record.Query (runQuery') import Database.HDBC.Record.Persistable ()-import Database.HDBC.Schema.Driver (TypeMap, Driver, getFieldsWithMap, getPrimaryKey, emptyDriver)+import Database.HDBC.Schema.Driver+  (TypeMap, LogChan, putVerbose, failWith, maybeIO,+   Driver, hoistMaybe, getFieldsWithMap, getPrimaryKey, emptyDriver) import Database.Record.TH (makeRecordPersistableWithSqlTypeDefaultFromDefined) import Database.Relational.Schema.SQLite3 (getType, indexInfoQuerySQL, indexListQuerySQL, normalizeColumn,                                            normalizeType, notNull, tableInfoQuerySQL)@@ -31,7 +37,6 @@ import Database.Relational.Schema.SQLite3Syscat.IndexList (IndexList) import Database.Relational.Schema.SQLite3Syscat.TableInfo (TableInfo) import Language.Haskell.TH (TypeQ)-import Language.Haskell.TH.Lib.Extra (reportMessage)  $(makeRecordPersistableWithSqlTypeDefaultFromDefined   [t| SqlValue |] ''TableInfo)@@ -45,23 +50,24 @@ logPrefix :: String -> String logPrefix = ("SQLite3: " ++) -putLog :: String -> IO ()-putLog = reportMessage . logPrefix+putLog :: LogChan -> String -> IO ()+putLog lchan = putVerbose lchan . logPrefix -compileErrorIO :: String -> IO a-compileErrorIO =  fail . logPrefix+compileError :: LogChan -> String -> MaybeT IO a+compileError lchan = failWith lchan . logPrefix  getPrimaryKey' :: IConnection conn                => conn+               -> LogChan                -> String                -> String                -> IO [String]-getPrimaryKey' conn scm tbl = do+getPrimaryKey' conn lchan scm tbl = do     tblinfo <- runQuery' conn (tableInfoQuerySQL scm tbl) ()-    let primColumns = map (normalizeColumn . TableInfo.name)-                      . filter ((1 ==) . TableInfo.pk) $ tblinfo+    let primColumns = [ normalizeColumn $ TableInfo.name ti+                      | ti <- tblinfo, TableInfo.pk ti == 1 ]     if length primColumns <= 1 then do-        putLog $ "getPrimaryKey: key=" ++ show primColumns+        putLog lchan $ "getPrimaryKey: key=" ++ show primColumns         return primColumns      else do         idxlist <- runQuery' conn (indexListQuerySQL scm tbl) ()@@ -73,35 +79,36 @@         let idxInfo = concat . take 1 . filter isPrimaryKey $ idxInfos         let comp x y = compare (IndexInfo.seqno x) (IndexInfo.seqno y)         let primColumns' = map IndexInfo.name . sortBy comp $ idxInfo-        putLog $ "getPrimaryKey: keys=" ++ show primColumns'+        putLog lchan $ "getPrimaryKey: keys=" ++ show primColumns'         return primColumns' -getFields' :: IConnection conn-           => TypeMap-           -> conn-           -> String-           -> String-           -> IO ([(String, TypeQ)], [Int])-getFields' tmap conn scm tbl = do-    rows <- runQuery' conn (tableInfoQuerySQL scm tbl) ()-    case rows of-      [] -> compileErrorIO-            $ "getFields: No columns found: schema = " ++ scm ++ ", table = " ++ tbl-      _  -> return ()+getColumns' :: IConnection conn+            => TypeMap+            -> conn+            -> LogChan+            -> String+            -> String+            -> IO ([(String, TypeQ)], [Int])+getColumns' tmap conn lchan scm tbl = maybeIO ([], []) id $ do+    rows <- lift $ runQuery' conn (tableInfoQuerySQL scm tbl) ()+    guard (not $ null rows) <|>+      compileError lchan+      ("getFields: No columns found: schema = " ++ scm ++ ", table = " ++ tbl)     let columnId = TableInfo.cid     let notNullIdxs = map (fromIntegral . columnId) . filter notNull $ rows-    putLog+    lift . putLog lchan         $ "getFields: num of columns = " ++ show (length rows)         ++ ", not null columns = " ++ show notNullIdxs-    let getType' ti = case getType (fromList tmap) ti of-          Nothing -> compileErrorIO-                     $ "Type mapping is not defined against SQLite3 type: "-                     ++ normalizeType (TableInfo.ctype ti)-          Just p  -> return p+    let getType' ti =+          hoistMaybe (getType (fromList tmap) ti) <|>+          compileError lchan+          ("Type mapping is not defined against SQLite3 type: "+           ++ normalizeType (TableInfo.ctype ti))     types <- mapM getType' rows     return (types, notNullIdxs) +-- | Driver implementation driverSQLite3 :: IConnection conn => Driver conn driverSQLite3 =-    emptyDriver { getFieldsWithMap = getFields' }+    emptyDriver { getFieldsWithMap = getColumns' }                 { getPrimaryKey    = getPrimaryKey' }