summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorKeiHibino <>2018-03-01 00:41:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-03-01 00:41:00 (GMT)
commitcc7770524d4a71ff5c84f8b00947278b49376e6c (patch)
treec71ebb467ed6c04a71cf4a4c7535c2d0c729548d
parent9e5f865a2c3e04eeef93f44085132b36223e0928 (diff)
version 0.5.2.00.5.2.0
-rw-r--r--ChangeLog.md11
-rw-r--r--persistable-record.cabal3
-rw-r--r--src/Database/Record.hs6
-rw-r--r--src/Database/Record/FromSql.hs2
-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
8 files changed, 174 insertions, 107 deletions
diff --git a/ChangeLog.md b/ChangeLog.md
index c7c8c05..3f07a62 100644
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -1,12 +1,13 @@
<!-- -*- Markdown -*- -->
-## 0.6.0.0
+## 0.5.2.0
-- divide and apply product-isomorphic interfaces.
+- check width of Int type and add instances. (backport)
+- fix typo.
## 0.5.1.1
-- update this changelog.
+- Update this changelog.
## 0.5.1.0
@@ -18,11 +19,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 7cbb3f7..dbbfd0d 100644
--- a/persistable-record.cabal
+++ b/persistable-record.cabal
@@ -1,5 +1,5 @@
name: persistable-record
-version: 0.6.0.0
+version: 0.5.2.0
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,7 +37,6 @@ 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 af060a7..62f8889 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,
- takeRecord, toRecord)
+ runTakeRecord, takeRecord, runToRecord, toRecord)
import Database.Record.ToSql
(ToSqlM, RecordToSql, ToSql(..), valueRecordToSql,
- putRecord, putEmpty, fromRecord,
+ runFromRecord, wrapToSql, putRecord, putEmpty, fromRecord,
updateValuesByUnique, updateValuesByPrimary)
import Database.Record.TupleInstances ()
diff --git a/src/Database/Record/FromSql.hs b/src/Database/Record/FromSql.hs
index 65aaddc..34dbf10 100644
--- a/src/Database/Record/FromSql.hs
+++ b/src/Database/Record/FromSql.hs
@@ -60,7 +60,7 @@ When, you have data constructor and objects like below.
foo = ...
bar :: 'RecordFromSql' SqlValue Bar
bar = ...
- baz :: 'RecordFromSql' SqlValue Bar
+ baz :: 'RecordFromSql' SqlValue Baz
baz = ...
@
diff --git a/src/Database/Record/InternalTH.hs b/src/Database/Record/InternalTH.hs
index f38de30..334f066 100644
--- a/src/Database/Record/InternalTH.hs
+++ b/src/Database/Record/InternalTH.hs
@@ -2,70 +2,49 @@
{-# 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, tupleTypeName,
- TypeQ, varT, classP, Dec, instanceD, )
-import Data.Functor.ProductIsomorphic.TH (reifyRecordType)
+ (Q, mkName, Name,
+ conT, varT, tupleT, appT, classP,
+ TypeQ, Dec, instanceD, )
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
- (((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
+ 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) |]
+ []
-- | Template to define tuple instances of persistable-record classes.
defineTupleInstances :: Int -> Q [Dec]
defineTupleInstances n =
concat <$> sequence
- [ persistableWidth n, sqlInstances n ]
+ [ persistableWidth n
+ , tupleInstance2 n ''FromSql
+ , tupleInstance2 n ''ToSql ]
knownWidthIntType :: Maybe TypeQ
knownWidthIntType
diff --git a/src/Database/Record/Persistable.hs b/src/Database/Record/Persistable.hs
index aa0a328..dce83c2 100644
--- a/src/Database/Record/Persistable.hs
+++ b/src/Database/Record/Persistable.hs
@@ -3,7 +3,6 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- |
-- Module : Database.Record.Persistable
@@ -35,13 +34,11 @@ 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
@@ -60,7 +57,6 @@ 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
@@ -72,8 +68,12 @@ 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
+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
-- | 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 = (,) |$| a |*| b
+a <&> b = (,) `pmap` a `pap` 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 = pureP U1
+ gFieldWidthList = ProductConst $ pure U1
instance (GFieldWidthList a, GFieldWidthList b) => GFieldWidthList (a :*: b) where
- gFieldWidthList = (:*:) |$| gFieldWidthList |*| gFieldWidthList
+ gFieldWidthList = (:*:) `pmap` gFieldWidthList `pap` gFieldWidthList
instance GFieldWidthList a => GFieldWidthList (M1 i c a) where
- gFieldWidthList = M1 |$| gFieldWidthList
+ gFieldWidthList = M1 `pmap` gFieldWidthList
instance PersistableWidth a => GFieldWidthList (K1 i a) where
- gFieldWidthList = K1 |$| pmapConst (pure . getSum) persistableWidth
+ gFieldWidthList = K1 `pmap` 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 0c63d19..b8865a3 100644
--- a/src/Database/Record/TH.hs
+++ b/src/Database/Record/TH.hs
@@ -14,6 +14,10 @@
-- 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,
@@ -26,11 +30,11 @@ module Database.Record.TH (
-- * Function declarations against defined record types
defineColumnOffsets,
+
recordWidthTemplate,
- -- * Instance definitions against defined record types
- definePersistableWidthInstance,
- defineSqlPersistableInstances,
+ -- * Reify
+ reifyRecordType,
-- * Templates about record name
NameConfig, defaultNameConfig,
@@ -54,17 +58,22 @@ 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')
+import Language.Haskell.TH.Compat.Data (dataD', unDataD)
import Language.Haskell.TH
- (Q, nameBase, Name, Dec, TypeQ, conT, ExpQ, listE, sigE,
- recC, cxt, varStrictType, strictType, isStrict)
+ (Q, nameBase, reify, Info(TyConI), Name,
+ TypeQ, conT, Con (NormalC, RecC),
+ Dec,
+ ExpQ, conE, listE, sigE,
+ recC,
+ cxt, varStrictType, strictType, isStrict)
import Control.Arrow ((&&&))
import Database.Record
(HasColumnConstraint(columnConstraint), Primary, NotNull,
HasKeyConstraint(keyConstraint), derivedCompositePrimary,
- PersistableRecordWidth, PersistableWidth(persistableWidth), )
+ PersistableRecordWidth, PersistableWidth(persistableWidth),
+ FromSql, ToSql, )
import Database.Record.KeyConstraint
(unsafeSpecifyColumnConstraint, unsafeSpecifyNotNullValue, unsafeSpecifyKeyConstraint)
@@ -72,8 +81,7 @@ import Database.Record.Persistable
(runPersistableRecordWidth,
ProductConst, getProductConst, genericFieldOffsets)
import qualified Database.Record.Persistable as Persistable
-import Database.Record.InternalTH
- (definePersistableWidthInstance, defineSqlPersistableInstances, defineTupleInstances)
+import Database.Record.InternalTH (defineTupleInstances)
-- | 'NameConfig' type to customize names of expanded record templates.
@@ -114,14 +122,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 definition template
+ -> Q [Dec] -- ^ Result declaration 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 definition template
+ -> Q [Dec] -- ^ Result declaration template
defineHasPrimaryConstraintInstanceDerived typeCon =
[d| instance HasKeyConstraint Primary $typeCon where
keyConstraint = derivedCompositePrimary |]
@@ -129,7 +137,7 @@ defineHasPrimaryConstraintInstanceDerived typeCon =
-- | Template of 'HasColumnConstraint' 'Primary' instance.
defineHasPrimaryKeyInstance :: TypeQ -- ^ Type constructor of record
-> [Int] -- ^ Key index which specifies this constraint
- -> Q [Dec] -- ^ Definition of primary key constraint instance
+ -> Q [Dec] -- ^ Declaration of primary key constraint instance
defineHasPrimaryKeyInstance typeCon = d where
d [] = return []
d [ix] = do
@@ -145,7 +153,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] -- ^ Definition of not null key constraint instance
+ -> Q [Dec] -- ^ Declaration of not null key constraint instance
defineHasNotNullKeyInstance =
defineHasColumnConstraintInstance [t| NotNull |]
@@ -157,19 +165,24 @@ recordWidthTemplate ty =
$(sigE [| persistableWidth |] [t| PersistableRecordWidth $(ty) |])
|]
--- | Column offset array definition.
+-- | Column offset array and 'PersistableWidth' instance declaration.
defineColumnOffsets :: ConName -- ^ Record type constructor.
- -> Q [Dec] -- ^ Result column offset array declaration.
-defineColumnOffsets typeName' = do
+ -> [TypeQ] -- ^ Types of record columns.
+ -> Q [Dec] -- ^ Declaration of 'PersistableWidth' instance.
+defineColumnOffsets typeName' tys = do
let ofsVar = columnOffsetsVarNameDefault $ conName typeName'
- simpleValD (varName ofsVar) [t| Array Int Int |]
- [| getProductConst (genericFieldOffsets :: ProductConst (Array Int Int) $(toTypeCon 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
--- | Record type definition template.
+-- | Record type declaration 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 definition
+ -> Q [Dec] -- ^ The data type record declaration.
defineRecordType typeName' columns derives = do
let typeName = conName typeName'
fld (n, tq) = varStrictType (varName n) (strictType isStrict tq)
@@ -179,17 +192,85 @@ 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'
- pw <- definePersistableWidthInstance (conT typeName) []
- return $ rec' : offs ++ pw
+ offs <- defineColumnOffsets typeName' [ty | (_, ty) <- columns]
+ return $ rec' : offs
--- | Record type definition template with configured names.
+-- | Record type declaration 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 ebfdb1f..4de7e31 100644
--- a/src/Database/Record/ToSql.hs
+++ b/src/Database/Record/ToSql.hs
@@ -17,23 +17,24 @@
-- from Haskell type into list of database value type.
module Database.Record.ToSql (
-- * Conversion from record type into list of database value type
- ToSqlM, execToSqlM, RecordToSql, runFromRecord, wrapToSql,
+ ToSqlM, RecordToSql, runFromRecord,
createRecordToSql,
(<&>),
-- * Derivation rules of 'RecordToSql' conversion
ToSql (recordToSql),
- putRecord, putEmpty, fromRecord,
+ putRecord, putEmpty, fromRecord, wrapToSql,
valueRecordToSql,
-- * Make parameter list for updating with key
updateValuesByUnique,
updateValuesByPrimary,
+ updateValuesByUnique',
untypedUpdateValuesIndex,
- unsafeUpdateValuesWithIndexes,
+ unsafeUpdateValuesWithIndexes
) where
import GHC.Generics (Generic, Rep, U1 (..), K1 (..), M1 (..), (:*:)(..), from)
@@ -53,9 +54,8 @@ import Database.Record.KeyConstraint
-- | Context type to convert into database value list.
type ToSqlM q a = Writer (DList q) a
--- | extract appended print result of record.
-execToSqlM :: ToSqlM q a -> [q]
-execToSqlM = DList.toList . execWriter
+runToSqlM :: ToSqlM q a -> [q]
+runToSqlM = 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 = execToSqlM . runRecordToSql r
+runFromRecord r = runToSqlM . 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 = execToSqlM . putRecord
+fromRecord = runToSqlM . 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 :: ToSql q ra
- => [Int]
+unsafeUpdateValuesWithIndexes :: RecordToSql q ra
+ -> [Int]
-> ra
-> [q]
-unsafeUpdateValuesWithIndexes key a =
+unsafeUpdateValuesWithIndexes pr key a =
[ valsA ! i | i <- otherThanKey ++ key ] where
- vals = execToSqlM $ putRecord a
+ vals = runFromRecord pr a
width = length vals
valsA = listArray (0, width - 1) vals
otherThanKey = untypedUpdateValuesIndex key width
@@ -241,12 +241,19 @@ unsafeUpdateValuesWithIndexes key a =
-- UPDATE /table/ SET /c0/ = ?, /c1/ = ?, /c2/ = ? ... WHERE /key0/ = ? AND /key1/ = ? AND /key2/ = ? ...
-- @
--
--- using printer function object infered by ToSql ra q.
+-- 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.
updateValuesByUnique :: ToSql q ra
=> KeyConstraint Unique ra -- ^ Unique key table constraint printer function object.
-> ra
-> [q]
-updateValuesByUnique uk = unsafeUpdateValuesWithIndexes (indexes uk)
+updateValuesByUnique = updateValuesByUnique' recordToSql
-- | Convert like 'updateValuesByUnique'' using implicit 'RecordToSql' and 'ColumnConstraint'.
updateValuesByPrimary :: (HasKeyConstraint Primary ra, ToSql q ra)