khibino/haskell-relational-record
1
1
Fork 0
mirror of https://github.com/khibino/haskell-relational-record.git synced 2025-01-05 20:04:49 +03:00
Code Issues Projects Releases Wiki Activity

Update to use not wrapped (Singleton) types.

Browse Source
This commit is contained in:
Kei Hibino 2013-05-07 12:20:31 +09:00
parent ec1741d0ab
commit c5887b4c81
3 changed files with 14 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
schema-th/src/Database/HDBC/Schema/IBMDB2.hs
View File

@ -29,7 +29,6 @@ import Database.HDBC (IConnection)
import Database.HDBC.SqlValueExtra ()
import Database.HDBC.TH (derivingShow)
import qualified Database.HDBC.TH as Base
import Database.Record.Persistable (Singleton, singleton, runSingleton)
import Database.Relational.Query.Type (unsafeTypedQuery)
import Database.Relational.Query (Query)
import Database.HDBC.Record.Query (runQuery', listToUnique)
@ -149,7 +148,7 @@ getType mapFromSql rec =
then typ
else [t| Maybe $(typ) |]
columnsQuerySQL :: Query (Singleton String, Singleton String) Columns
columnsQuerySQL :: Query (String, String) Columns
columnsQuerySQL =
unsafeTypedQuery .
SQL.unwordsSQL
@ -159,7 +158,7 @@ columnsQuerySQL =
ORDER, BY, "colno"]
where fields = map SQL.word fieldsOfColumns
primaryKeyQuerySQL :: Query (Singleton String, Singleton String) (Singleton String)
primaryKeyQuerySQL :: Query (String, String) String
primaryKeyQuerySQL =
unsafeTypedQuery .
SQL.unwordsSQL
@ -199,9 +198,9 @@ getPrimaryKey' :: IConnection conn
getPrimaryKey' conn scm' tbl' = do
let tbl = map toUpper tbl'
scm = map toUpper scm'
mayPrim <- runQuery' conn (singleton scm, singleton tbl) primaryKeyQuerySQL
mayPrim <- runQuery' conn (scm, tbl) primaryKeyQuerySQL
>>= listToUnique
let mayPrimaryKey = (normalizeField . runSingleton) `fmap` mayPrim
let mayPrimaryKey = normalizeField `fmap` mayPrim
putLog $ "getPrimaryKey: primary key = " ++ show mayPrimaryKey
return mayPrimaryKey
@ -216,7 +215,7 @@ getFields' tmap conn scm' tbl' = do
let tbl = map toUpper tbl'
scm = map toUpper scm'
cols <- runQuery' conn (singleton scm, singleton tbl) columnsQuerySQL
cols <- runQuery' conn (scm, tbl) columnsQuerySQL
case cols of
[] -> compileErrorIO
$ "getFields: No columns found: schema = " ++ scm ++ ", table = " ++ tbl

15
schema-th/src/Database/HDBC/Schema/PostgreSQL.hs
View File

@ -27,7 +27,6 @@ import Database.HDBC (IConnection)
import Database.HDBC.SqlValueExtra ()
import qualified Database.HDBC.TH as Base
import Database.Record.Persistable (Singleton, singleton, runSingleton)
import Database.Relational.Query.Type (unsafeTypedQuery)
import Database.Relational.Query (Query(untypeQuery))
import Database.HDBC.Record.Query (runQuery', listToUnique)
@ -95,7 +94,7 @@ getType mapFromSql column@(pgAttr, pgType) =
pgCatalog :: SQL.Keyword
pgCatalog = "PG_CATALOG"
relOidQuerySQL :: Query (Singleton String, Singleton String) (Singleton Int32)
relOidQuerySQL :: Query (String, String) (Int32)
relOidQuerySQL =
unsafeTypedQuery .
SQL.unwordsSQL
@ -110,7 +109,7 @@ relOidQuerySQL =
"nspname" .=. "?", AND, "relname" .=. "?"
]
attributeQuerySQL :: Query (Singleton String, Singleton String) PgAttribute
attributeQuerySQL :: Query (String, String) PgAttribute
attributeQuerySQL =
unsafeTypedQuery .
SQL.unwordsSQL
@ -124,7 +123,7 @@ attributeQuerySQL =
"attnum", ">", "0" -- attnum of normal attributes begins from 1
]
columnQuerySQL :: Query (Singleton String, Singleton String) Column
columnQuerySQL :: Query (String, String) Column
columnQuerySQL =
unsafeTypedQuery .
SQL.unwordsSQL
@ -146,7 +145,7 @@ columnQuerySQL =
"typcategory = 'T'",
")" ]
primaryKeyQuerySQL :: Query (Singleton String, Singleton String) (Singleton String)
primaryKeyQuerySQL :: Query (String, String) String
primaryKeyQuerySQL =
unsafeTypedQuery .
SQL.unwordsSQL
@ -178,9 +177,9 @@ getPrimaryKey' :: IConnection conn
getPrimaryKey' conn scm' tbl' = do
let scm = map toLower scm'
tbl = map toLower tbl'
mayPrim <- runQuery' conn (singleton scm, singleton tbl) primaryKeyQuerySQL
mayPrim <- runQuery' conn (scm, tbl) primaryKeyQuerySQL
>>= listToUnique
return $ (normalizeField . runSingleton) `fmap` mayPrim
return $ normalizeField `fmap` mayPrim
getFields' :: IConnection conn
=> TypeMap
@ -191,7 +190,7 @@ getFields' :: IConnection conn
getFields' tmap conn scm' tbl' = do
let scm = map toLower scm'
tbl = map toLower tbl'
cols <- runQuery' conn (singleton scm, singleton tbl) columnQuerySQL
cols <- runQuery' conn (scm, tbl) columnQuerySQL
case cols of
[] -> compileErrorIO
$ "getFields: No columns found: schema = " ++ scm ++ ", table = " ++ tbl

5
schema-th/src/Database/HDBC/TH.hs
View File

@ -67,8 +67,7 @@ import Language.Haskell.TH
import Database.HDBC.Session (withConnectionIO)
import Database.Record.Persistable
(persistableRecord, Persistable, persistable,
persistableRecordWidth, PersistableWidth, persistableWidth,
Singleton)
persistableRecordWidth, PersistableWidth, persistableWidth)
import Database.Record.KeyConstraint
(HasKeyConstraint(constraintKey), specifyKeyConstraint, Primary, NotNull)
import Database.Record.FromSql (FromSql(recordFromSql), recordFromSql')
@ -278,7 +277,7 @@ defineConstantSql name' sqlStr = do
defineConstantSqlQuery :: TypeQ -> TypeQ -> VarName -> String -> Q [Dec]
defineConstantSqlQuery pkeyType recordType name' sqlStr = do
let name = varName name'
sig <- sigD name [t| Query (Singleton $pkeyType) $recordType |]
sig <- sigD name [t| Query $pkeyType $recordType |]
var <- valD (varP name)
(normalB [| unsafeTypedQuery $(stringE $ sqlStr) |])
[]