khibino/haskell-relational-record
1
1
Fork 0
mirror of https://github.com/khibino/haskell-relational-record.git synced 2024-11-29 14:45:51 +03:00
Code Issues Projects Releases Wiki Activity

Prepare to write the lifted transaction of MySQL driver.

Browse Source
This commit is contained in:
Kei Hibino 2015-11-06 17:27:36 +09:00
parent 3d052a6bd7
commit 0d139bdde9
1 changed files with 8 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
relational-query-HDBC/src/Database/HDBC/Schema/MySQL.hs
View File

@ -9,6 +9,7 @@ module Database.HDBC.Schema.MySQL
import Prelude hiding (length)
import Language.Haskell.TH (TypeQ)
import Control.Monad.Trans.Class (lift)
import qualified Data.List as List
import Data.Map (fromList)
@ -17,8 +18,9 @@ import Database.HDBC.Record.Query (runQuery')
import Database.HDBC.Record.Persistable ()
import Database.HDBC.Schema.Driver ( TypeMap
, LogChan
, Driver
, putVerbose
, maybeIO
, Driver
, getFieldsWithMap
, getPrimaryKey
, emptyDriver
@ -64,18 +66,18 @@ getFields' :: IConnection conn
-> String
-> String
-> IO ([(String, TypeQ)], [Int])
getFields' tmap conn lchan scm tbl = do
cols <- runQuery' conn columnsQuerySQL (scm, tbl)
getFields' tmap conn lchan scm tbl = maybeIO ([], []) id $ do
cols <- lift $ runQuery' conn columnsQuerySQL (scm, tbl)
case cols of
[] -> compileErrorIO
[] -> lift . compileErrorIO
$ "getFields: No columns found: schema = " ++ scm
++ ", table = " ++ tbl
_ -> return ()
let notNullIdxs = map fst . filter (notNull . snd) . zip [0..] $ cols
putLog lchan
lift . putLog lchan
$ "getFields: num of columns = " ++ show (List.length cols)
++ ", not null columns = " ++ show notNullIdxs
types <- mapM getType' cols
types <- lift $ mapM getType' cols
return (types, notNullIdxs)
where
getType' col =