summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorKeiHibino <>2018-03-01 00:46:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-03-01 00:46:00 (GMT)
commit8ed9366234893353e7cac2f51fd7847f23e5fcb9 (patch)
tree3a4f5d6291cc2416fda41ccf8b6bb7d88865a9d4
parentcc7770524d4a71ff5c84f8b00947278b49376e6c (diff)
version 0.6.0.10.6.0.1
-rw-r--r--ChangeLog.md15
-rw-r--r--persistable-record.cabal3
-rw-r--r--src/Database/Record.hs6
-rw-r--r--src/Database/Record/InternalTH.hs67
-rw-r--r--src/Database/Record/Persistable.hs28
-rw-r--r--src/Database/Record/TH.hs129
-rw-r--r--src/Database/Record/ToSql.hs35
7 files changed, 111 insertions, 172 deletions
diff --git a/ChangeLog.md b/ChangeLog.md
index 3f07a62..cc6a676 100644
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -1,13 +1,18 @@
<!-- -*- Markdown -*- -->
-## 0.5.2.0
+## 0.6.0.1
-- check width of Int type and add instances. (backport)
+- fix changelog.
- fix typo.
+## 0.6.0.0
+
+- divide and apply product-isomorphic interfaces.
+- check width of Int type and add instances.
+
## 0.5.1.1
-- Update this changelog.
+- update this changelog.
## 0.5.1.0
@@ -19,11 +24,11 @@
## 0.5.0.1
-- Use Haskell implementation test instead of flag test in .cabal
+- use Haskell implementation test instead of flag test in .cabal
## 0.5.0.0
-- Add generic instances of FromSql, ToSql and PersistableWidth.
+- add generic instances of FromSql, ToSql and PersistableWidth.
## 0.4.1.1
diff --git a/persistable-record.cabal b/persistable-record.cabal
index dbbfd0d..9120aac 100644
--- a/persistable-record.cabal
+++ b/persistable-record.cabal
@@ -1,5 +1,5 @@
name: persistable-record
-version: 0.5.2.0
+version: 0.6.0.1
synopsis: Binding between SQL database values and haskell records.
description: This package contiains types to represent table constraints and
interfaces to bind between SQL database values and Haskell records.
@@ -37,6 +37,7 @@ library
build-depends: base <5
, template-haskell
, th-data-compat
+ , product-isomorphic >= 0.0.3
, array
, containers
, transformers
diff --git a/src/Database/Record.hs b/src/Database/Record.hs
index 62f8889..af060a7 100644
--- a/src/Database/Record.hs
+++ b/src/Database/Record.hs
@@ -28,7 +28,7 @@ module Database.Record (
-- ** Convert from list of SQL type
module Database.Record.FromSql,
-- ** Convert into list of SQL type
- module Database.Record.ToSql
+ module Database.Record.ToSql,
) where
import Database.Record.KeyConstraint
@@ -43,10 +43,10 @@ import Database.Record.Persistable
PersistableRecordWidth, PersistableWidth(..), derivedWidth)
import Database.Record.FromSql
(RecordFromSql, FromSql(..), valueRecordFromSql,
- runTakeRecord, takeRecord, runToRecord, toRecord)
+ takeRecord, toRecord)
import Database.Record.ToSql
(ToSqlM, RecordToSql, ToSql(..), valueRecordToSql,
- runFromRecord, wrapToSql, putRecord, putEmpty, fromRecord,
+ putRecord, putEmpty, fromRecord,
updateValuesByUnique, updateValuesByPrimary)
import Database.Record.TupleInstances ()
diff --git a/src/Database/Record/InternalTH.hs b/src/Database/Record/InternalTH.hs
index 334f066..f38de30 100644
--- a/src/Database/Record/InternalTH.hs
+++ b/src/Database/Record/InternalTH.hs
@@ -2,49 +2,70 @@
{-# LANGUAGE ConstraintKinds #-}
module Database.Record.InternalTH (
+ definePersistableWidthInstance,
+ defineSqlPersistableInstances,
defineTupleInstances,
knownWidthIntType,
) where
import Control.Applicative ((<$>))
import Data.Int (Int32, Int64)
-import Data.List (foldl')
import Language.Haskell.TH
- (Q, mkName, Name,
- conT, varT, tupleT, appT, classP,
- TypeQ, Dec, instanceD, )
+ (Q, mkName, Name, tupleTypeName,
+ TypeQ, varT, classP, Dec, instanceD, )
+import Data.Functor.ProductIsomorphic.TH (reifyRecordType)
import Database.Record.Persistable (PersistableWidth)
import Database.Record.FromSql (FromSql)
import Database.Record.ToSql (ToSql)
+-- | Polymorphic 'PersistableWidth' instance template.
+definePersistableWidthInstance :: TypeQ -- ^ Record type construct expression.
+ -> [Name] -- ^ Record type construct argument variables.
+ -> Q [Dec] -- ^ Definition of 'PersistableWidth' instance.
+definePersistableWidthInstance tyCon avs = do
+ -- in template-haskell 2.8 or older, Pred is not Type
+ let classP' n v = classP n [varT v]
+ (:[]) <$>
+ instanceD
+ (mapM (classP' ''PersistableWidth) avs)
+ [t| PersistableWidth $tyCon |] []
+
+-- | Polymorphic record parser and printer instance templates
+-- for converting between list of SQL type and Haskell record type.
+defineSqlPersistableInstances :: TypeQ
+ -> TypeQ
+ -> [Name]
+ -> Q [Dec]
+defineSqlPersistableInstances tySql tyRec avs = do
+ -- in template-haskell 2.8 or older, Pred is not Type
+ let classP' n v = classP n [tySql, varT v]
+ fromI <-
+ instanceD
+ (mapM (classP' ''FromSql) avs)
+ [t| FromSql $tySql $tyRec |] []
+ toI <-
+ instanceD
+ (mapM (classP' ''ToSql) avs)
+ [t| ToSql $tySql $tyRec |] []
+ return [fromI, toI]
+
persistableWidth :: Int -> Q [Dec]
persistableWidth n = do
- let vs = [ varT . mkName $ "a" ++ show i | i <- [1 .. n] ]
- (:[]) <$> instanceD
- -- in template-haskell 2.8 or older, Pred is not Type
- (mapM (classP ''PersistableWidth . (:[])) vs)
- [t| PersistableWidth $(foldl' appT (tupleT n) vs) |]
- []
-
-tupleInstance2 :: Int -> Name -> Q [Dec]
-tupleInstance2 n clazz = do
- let vs = [ varT . mkName $ "a" ++ show i | i <- [1 .. n] ]
- q = varT $ mkName "q"
- (:[]) <$> instanceD
- -- in template-haskell 2.8 or older, Pred is not Type
- (mapM (\v -> classP clazz [q, v]) vs)
- [t| $(conT clazz) $q $(foldl' appT (tupleT n) vs) |]
- []
+ (((tyCon, avs), _), _) <- reifyRecordType $ tupleTypeName n
+ definePersistableWidthInstance tyCon avs
+
+sqlInstances :: Int -> Q [Dec]
+sqlInstances n = do
+ (((tyCon, avs), _), _) <- reifyRecordType $ tupleTypeName n
+ defineSqlPersistableInstances (varT $ mkName "q") tyCon avs
-- | Template to define tuple instances of persistable-record classes.
defineTupleInstances :: Int -> Q [Dec]
defineTupleInstances n =
concat <$> sequence
- [ persistableWidth n
- , tupleInstance2 n ''FromSql
- , tupleInstance2 n ''ToSql ]
+ [ persistableWidth n, sqlInstances n ]
knownWidthIntType :: Maybe TypeQ
knownWidthIntType
diff --git a/src/Database/Record/Persistable.hs b/src/Database/Record/Persistable.hs
index dce83c2..aa0a328 100644
--- a/src/Database/Record/Persistable.hs
+++ b/src/Database/Record/Persistable.hs
@@ -3,6 +3,7 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- |
-- Module : Database.Record.Persistable
@@ -34,11 +35,13 @@ module Database.Record.Persistable (
) where
import GHC.Generics (Generic, Rep, U1 (..), K1 (..), M1 (..), (:*:)(..), to)
-import Control.Applicative ((<$>), pure, (<*>), Const (..))
+import Control.Applicative ((<$>), pure, Const (..))
import Data.Monoid (Monoid, Sum (..))
import Data.Array (Array, listArray, bounds, (!))
import Data.DList (DList)
import qualified Data.DList as DList
+import Data.Functor.ProductIsomorphic
+ (ProductIsoFunctor, (|$|), ProductIsoApplicative, pureP, (|*|), )
-- | Proposition to specify type 'q' is database value type, contains null value
@@ -57,6 +60,7 @@ unsafePersistableSqlTypeFromNull = PersistableSqlType
-- | Restricted in product isomorphism record type b
newtype ProductConst a b =
ProductConst { unPC :: Const a b }
+ deriving (ProductIsoFunctor, ProductIsoApplicative)
-- | extract constant value of 'ProductConst'.
getProductConst :: ProductConst a b -> a
@@ -68,12 +72,8 @@ getProductConst = getConst . unPC
type PersistableRecordWidth a = ProductConst (Sum Int) a
-- unsafely map PersistableRecordWidth
-pmap :: Monoid e => (a -> b) -> ProductConst e a -> ProductConst e b
-f `pmap` prw = ProductConst $ f <$> unPC prw
-
--- unsafely ap PersistableRecordWidth
-pap :: Monoid e => ProductConst e (a -> b) -> ProductConst e a -> ProductConst e b
-wf `pap` prw = ProductConst $ unPC wf <*> unPC prw
+pmap' :: Monoid e => (a -> b) -> ProductConst e a -> ProductConst e b
+f `pmap'` prw = ProductConst $ f <$> unPC prw
-- | Get width 'Int' value of record type 'a'.
@@ -97,11 +97,11 @@ unsafeValueWidth = unsafePersistableRecordWidth 1
-- | Derivation rule of 'PersistableRecordWidth' for tuple (,) type.
(<&>) :: PersistableRecordWidth a -> PersistableRecordWidth b -> PersistableRecordWidth (a, b)
-a <&> b = (,) `pmap` a `pap` b
+a <&> b = (,) |$| a |*| b
-- | Derivation rule of 'PersistableRecordWidth' from from Haskell type 'a' into for Haskell type 'Maybe' 'a'.
maybeWidth :: PersistableRecordWidth a -> PersistableRecordWidth (Maybe a)
-maybeWidth = pmap Just
+maybeWidth = pmap' Just
-- | Interface of derivation rule for 'PersistableSqlType'.
@@ -146,23 +146,23 @@ class GFieldWidthList f where
gFieldWidthList :: ProductConst (DList Int) (f a)
instance GFieldWidthList U1 where
- gFieldWidthList = ProductConst $ pure U1
+ gFieldWidthList = pureP U1
instance (GFieldWidthList a, GFieldWidthList b) => GFieldWidthList (a :*: b) where
- gFieldWidthList = (:*:) `pmap` gFieldWidthList `pap` gFieldWidthList
+ gFieldWidthList = (:*:) |$| gFieldWidthList |*| gFieldWidthList
instance GFieldWidthList a => GFieldWidthList (M1 i c a) where
- gFieldWidthList = M1 `pmap` gFieldWidthList
+ gFieldWidthList = M1 |$| gFieldWidthList
instance PersistableWidth a => GFieldWidthList (K1 i a) where
- gFieldWidthList = K1 `pmap` pmapConst (pure . getSum) persistableWidth
+ gFieldWidthList = K1 |$| pmapConst (pure . getSum) persistableWidth
offsets :: [Int] -> Array Int Int
offsets ws = listArray (0, length ws) $ scanl (+) 0 ws
-- | Generic offset array of record fields.
genericFieldOffsets :: (Generic a, GFieldWidthList (Rep a)) => ProductConst (Array Int Int) a
-genericFieldOffsets = pmapConst (offsets . DList.toList) $ to `pmap` gFieldWidthList
+genericFieldOffsets = pmapConst (offsets . DList.toList) $ to `pmap'` gFieldWidthList
-- | Inference rule of 'PersistableRecordWidth' proof object for 'Maybe' type.
diff --git a/src/Database/Record/TH.hs b/src/Database/Record/TH.hs
index b8865a3..0c63d19 100644
--- a/src/Database/Record/TH.hs
+++ b/src/Database/Record/TH.hs
@@ -14,10 +14,6 @@
-- This module defines templates for Haskell record type and
-- type class instances to map between list of untyped SQL type and Haskell record type.
module Database.Record.TH (
- -- * Generate all templates about record
- defineRecord,
- defineRecordWithConfig,
-
-- * Table constraint specified by key
defineHasColumnConstraintInstance,
defineHasPrimaryConstraintInstanceDerived,
@@ -30,11 +26,11 @@ module Database.Record.TH (
-- * Function declarations against defined record types
defineColumnOffsets,
-
recordWidthTemplate,
- -- * Reify
- reifyRecordType,
+ -- * Instance definitions against defined record types
+ definePersistableWidthInstance,
+ defineSqlPersistableInstances,
-- * Templates about record name
NameConfig, defaultNameConfig,
@@ -58,22 +54,17 @@ import Language.Haskell.TH.Name.CamelCase
conCamelcaseName, varCamelcaseName, varNameWithPrefix,
toTypeCon, toDataCon, )
import Language.Haskell.TH.Lib.Extra (integralE, simpleValD, reportWarning)
-import Language.Haskell.TH.Compat.Data (dataD', unDataD)
+import Language.Haskell.TH.Compat.Data (dataD')
import Language.Haskell.TH
- (Q, nameBase, reify, Info(TyConI), Name,
- TypeQ, conT, Con (NormalC, RecC),
- Dec,
- ExpQ, conE, listE, sigE,
- recC,
- cxt, varStrictType, strictType, isStrict)
+ (Q, nameBase, Name, Dec, TypeQ, conT, ExpQ, listE, sigE,
+ recC, cxt, varStrictType, strictType, isStrict)
import Control.Arrow ((&&&))
import Database.Record
(HasColumnConstraint(columnConstraint), Primary, NotNull,
HasKeyConstraint(keyConstraint), derivedCompositePrimary,
- PersistableRecordWidth, PersistableWidth(persistableWidth),
- FromSql, ToSql, )
+ PersistableRecordWidth, PersistableWidth(persistableWidth), )
import Database.Record.KeyConstraint
(unsafeSpecifyColumnConstraint, unsafeSpecifyNotNullValue, unsafeSpecifyKeyConstraint)
@@ -81,7 +72,8 @@ import Database.Record.Persistable
(runPersistableRecordWidth,
ProductConst, getProductConst, genericFieldOffsets)
import qualified Database.Record.Persistable as Persistable
-import Database.Record.InternalTH (defineTupleInstances)
+import Database.Record.InternalTH
+ (definePersistableWidthInstance, defineSqlPersistableInstances, defineTupleInstances)
-- | 'NameConfig' type to customize names of expanded record templates.
@@ -122,14 +114,14 @@ columnOffsetsVarNameDefault = (`varNameWithPrefix` "columnOffsets") . nameBase
defineHasColumnConstraintInstance :: TypeQ -- ^ Type which represent constraint type
-> TypeQ -- ^ Type constructor of record
-> Int -- ^ Key index which specifies this constraint
- -> Q [Dec] -- ^ Result declaration template
+ -> Q [Dec] -- ^ Result definition template
defineHasColumnConstraintInstance constraint typeCon index =
[d| instance HasColumnConstraint $constraint $typeCon where
columnConstraint = unsafeSpecifyColumnConstraint $(integralE index) |]
-- | Template of 'HasKeyConstraint' instance.
defineHasPrimaryConstraintInstanceDerived ::TypeQ -- ^ Type constructor of record
- -> Q [Dec] -- ^ Result declaration template
+ -> Q [Dec] -- ^ Result definition template
defineHasPrimaryConstraintInstanceDerived typeCon =
[d| instance HasKeyConstraint Primary $typeCon where
keyConstraint = derivedCompositePrimary |]
@@ -137,7 +129,7 @@ defineHasPrimaryConstraintInstanceDerived typeCon =
-- | Template of 'HasColumnConstraint' 'Primary' instance.
defineHasPrimaryKeyInstance :: TypeQ -- ^ Type constructor of record
-> [Int] -- ^ Key index which specifies this constraint
- -> Q [Dec] -- ^ Declaration of primary key constraint instance
+ -> Q [Dec] -- ^ Definition of primary key constraint instance
defineHasPrimaryKeyInstance typeCon = d where
d [] = return []
d [ix] = do
@@ -153,7 +145,7 @@ defineHasPrimaryKeyInstance typeCon = d where
-- | Template of 'HasColumnConstraint' 'NotNull' instance.
defineHasNotNullKeyInstance :: TypeQ -- ^ Type constructor of record
-> Int -- ^ Key index which specifies this constraint
- -> Q [Dec] -- ^ Declaration of not null key constraint instance
+ -> Q [Dec] -- ^ Definition of not null key constraint instance
defineHasNotNullKeyInstance =
defineHasColumnConstraintInstance [t| NotNull |]
@@ -165,24 +157,19 @@ recordWidthTemplate ty =
$(sigE [| persistableWidth |] [t| PersistableRecordWidth $(ty) |])
|]
--- | Column offset array and 'PersistableWidth' instance declaration.
+-- | Column offset array definition.
defineColumnOffsets :: ConName -- ^ Record type constructor.
- -> [TypeQ] -- ^ Types of record columns.
- -> Q [Dec] -- ^ Declaration of 'PersistableWidth' instance.
-defineColumnOffsets typeName' tys = do
+ -> Q [Dec] -- ^ Result column offset array declaration.
+defineColumnOffsets typeName' = do
let ofsVar = columnOffsetsVarNameDefault $ conName typeName'
- widthIxE = integralE $ length tys
- ar <- simpleValD (varName ofsVar) [t| Array Int Int |]
- [| getProductConst (genericFieldOffsets :: ProductConst (Array Int Int) $(toTypeCon typeName')) |]
- pw <- [d| instance PersistableWidth $(toTypeCon typeName')
- |]
- return $ ar ++ pw
+ simpleValD (varName ofsVar) [t| Array Int Int |]
+ [| getProductConst (genericFieldOffsets :: ProductConst (Array Int Int) $(toTypeCon typeName')) |]
--- | Record type declaration template.
+-- | Record type definition template.
defineRecordType :: ConName -- ^ Name of the data type of table record type.
-> [(VarName, TypeQ)] -- ^ List of columns in the table. Must be legal, properly cased record columns.
-> [Name] -- ^ Deriving type class names.
- -> Q [Dec] -- ^ The data type record declaration.
+ -> Q [Dec] -- ^ The data type record definition
defineRecordType typeName' columns derives = do
let typeName = conName typeName'
fld (n, tq) = varStrictType (varName n) (strictType isStrict tq)
@@ -192,85 +179,17 @@ defineRecordType typeName' columns derives = do
{- DROP this hack in future version ups. -}
else return derives
rec' <- dataD' (cxt []) typeName [] [recC typeName (map fld columns)] derives1
- offs <- defineColumnOffsets typeName' [ty | (_, ty) <- columns]
- return $ rec' : offs
+ offs <- defineColumnOffsets typeName'
+ pw <- definePersistableWidthInstance (conT typeName) []
+ return $ rec' : offs ++ pw
--- | Record type declaration template with configured names.
+-- | Record type definition template with configured names.
defineRecordTypeWithConfig :: NameConfig -> String -> String -> [(String, TypeQ)] -> [Name] -> Q [Dec]
defineRecordTypeWithConfig config schema table columns =
defineRecordType
(recordTypeName config schema table)
[ (columnName config schema n, t) | (n, t) <- columns ]
-
--- | Default name of record construction function from SQL table name.
-fromSqlNameDefault :: String -> VarName
-fromSqlNameDefault = (`varNameWithPrefix` "fromSqlOf")
-
--- | Default name of record decomposition function from SQL table name.
-toSqlNameDefault :: String -> VarName
-toSqlNameDefault = (`varNameWithPrefix` "toSqlOf")
-
-recordInfo' :: Info -> Maybe ((TypeQ, ExpQ), (Maybe [Name], [TypeQ]))
-recordInfo' = d where
- d (TyConI tcon) = do
- (_cxt, tcn, _bs, _mk, [r], _ds) <- unDataD tcon
- case r of
- NormalC dcn ts -> Just ((conT tcn, conE dcn), (Nothing, [return t | (_, t) <- ts]))
- RecC dcn vts -> Just ((conT tcn, conE dcn), (Just ns, ts))
- where (ns, ts) = unzip [(n, return t) | (n, _, t) <- vts]
- _ -> Nothing
- d _ = Nothing
-
--- | Low-level reify interface for record type name.
-reifyRecordType :: Name -> Q ((TypeQ, ExpQ), (Maybe [Name], [TypeQ]))
-reifyRecordType recTypeName = do
- tyConInfo <- reify recTypeName
- maybe
- (fail $ "Defined record type constructor not found: " ++ show recTypeName)
- return
- (recordInfo' tyConInfo)
-
--- | Record parser and printer instance templates for converting
--- between list of SQL type and Haskell record type.
-definePersistableInstance :: TypeQ -- ^ SQL value type.
- -> TypeQ -- ^ Record type constructor.
- -> Q [Dec] -- ^ Instance declarations.
-definePersistableInstance sqlType typeCon = do
- [d| instance FromSql $sqlType $typeCon
- instance ToSql $sqlType $typeCon
- |]
-
--- | All templates for record type.
-defineRecord :: TypeQ -- ^ SQL value type
- -> ConName -- ^ Record type name
- -> [(VarName, TypeQ)] -- ^ Column schema
- -> [Name] -- ^ Record derivings
- -> Q [Dec] -- ^ Result declarations
-defineRecord
- sqlValueType
- tyC
- columns drvs = do
-
- typ <- defineRecordType tyC columns drvs
- withSql <- definePersistableInstance sqlValueType $ toTypeCon tyC
- return $ typ ++ withSql
-
--- | All templates for record type with configured names.
-defineRecordWithConfig :: TypeQ -- ^ SQL value type
- -> NameConfig -- ^ name rule config
- -> String -- ^ Schema name
- -> String -- ^ Table name
- -> [(String, TypeQ)] -- ^ Column names and types
- -> [Name] -- ^ Record derivings
- -> Q [Dec] -- ^ Result declarations
-defineRecordWithConfig sqlValueType config schema table columns derives = do
- typ <- defineRecordTypeWithConfig config schema table columns derives
- withSql <- definePersistableInstance sqlValueType . fst $ recordTemplate config schema table
-
- return $ typ ++ withSql
-
-
-- | Templates for single column value type.
deriveNotNullType :: TypeQ -> Q [Dec]
deriveNotNullType typeCon =
diff --git a/src/Database/Record/ToSql.hs b/src/Database/Record/ToSql.hs
index 4de7e31..ebfdb1f 100644
--- a/src/Database/Record/ToSql.hs
+++ b/src/Database/Record/ToSql.hs
@@ -17,24 +17,23 @@
-- from Haskell type into list of database value type.
module Database.Record.ToSql (
-- * Conversion from record type into list of database value type
- ToSqlM, RecordToSql, runFromRecord,
+ ToSqlM, execToSqlM, RecordToSql, runFromRecord, wrapToSql,
createRecordToSql,
(<&>),
-- * Derivation rules of 'RecordToSql' conversion
ToSql (recordToSql),
- putRecord, putEmpty, fromRecord, wrapToSql,
+ putRecord, putEmpty, fromRecord,
valueRecordToSql,
-- * Make parameter list for updating with key
updateValuesByUnique,
updateValuesByPrimary,
- updateValuesByUnique',
untypedUpdateValuesIndex,
- unsafeUpdateValuesWithIndexes
+ unsafeUpdateValuesWithIndexes,
) where
import GHC.Generics (Generic, Rep, U1 (..), K1 (..), M1 (..), (:*:)(..), from)
@@ -54,8 +53,9 @@ import Database.Record.KeyConstraint
-- | Context type to convert into database value list.
type ToSqlM q a = Writer (DList q) a
-runToSqlM :: ToSqlM q a -> [q]
-runToSqlM = DList.toList . execWriter
+-- | extract appended print result of record.
+execToSqlM :: ToSqlM q a -> [q]
+execToSqlM = DList.toList . execWriter
{- |
'RecordToSql' 'q' 'a' is data-type wrapping function
@@ -78,7 +78,7 @@ wrapToSql = RecordToSql
runFromRecord :: RecordToSql q a -- ^ printer function object which has capability to convert
-> a -- ^ Haskell type
-> [q] -- ^ list of database value
-runFromRecord r = runToSqlM . runRecordToSql r
+runFromRecord r = execToSqlM . runRecordToSql r
-- | Axiom of 'RecordToSql' for database value type 'q' and Haksell type 'a'.
createRecordToSql :: (a -> [q]) -- ^ Convert function body
@@ -197,7 +197,7 @@ putEmpty = putRecord
-- | Run implicit 'RecordToSql' printer function object.
-- Convert from haskell type 'a' into list of database value type ['q'].
fromRecord :: ToSql q a => a -> [q]
-fromRecord = runToSqlM . putRecord
+fromRecord = execToSqlM . putRecord
-- | Derivation rule of 'RecordToSql' printer function object for value convert function.
valueRecordToSql :: (a -> q) -> RecordToSql q a
@@ -224,13 +224,13 @@ untypedUpdateValuesIndex key width = otherThanKey where
-- @
--
-- using 'RecordToSql' printer function object.
-unsafeUpdateValuesWithIndexes :: RecordToSql q ra
- -> [Int]
+unsafeUpdateValuesWithIndexes :: ToSql q ra
+ => [Int]
-> ra
-> [q]
-unsafeUpdateValuesWithIndexes pr key a =
+unsafeUpdateValuesWithIndexes key a =
[ valsA ! i | i <- otherThanKey ++ key ] where
- vals = runFromRecord pr a
+ vals = execToSqlM $ putRecord a
width = length vals
valsA = listArray (0, width - 1) vals
otherThanKey = untypedUpdateValuesIndex key width
@@ -241,19 +241,12 @@ unsafeUpdateValuesWithIndexes pr key a =
-- UPDATE /table/ SET /c0/ = ?, /c1/ = ?, /c2/ = ? ... WHERE /key0/ = ? AND /key1/ = ? AND /key2/ = ? ...
-- @
--
--- using 'RecordToSql' printer function object.
-updateValuesByUnique' :: RecordToSql q ra
- -> KeyConstraint Unique ra -- ^ Unique key table constraint printer function object.
- -> ra
- -> [q]
-updateValuesByUnique' pr uk = unsafeUpdateValuesWithIndexes pr (indexes uk)
-
--- | Convert like 'updateValuesByUnique'' using implicit 'RecordToSql' printer function object.
+-- using printer function object infered by ToSql ra q.
updateValuesByUnique :: ToSql q ra
=> KeyConstraint Unique ra -- ^ Unique key table constraint printer function object.
-> ra
-> [q]
-updateValuesByUnique = updateValuesByUnique' recordToSql
+updateValuesByUnique uk = unsafeUpdateValuesWithIndexes (indexes uk)
-- | Convert like 'updateValuesByUnique'' using implicit 'RecordToSql' and 'ColumnConstraint'.
updateValuesByPrimary :: (HasKeyConstraint Primary ra, ToSql q ra)