diff options
author | KeiHibino <> | 2018-03-01 00:41:00 (GMT) |
---|---|---|
committer | hdiff <hdiff@hdiff.luite.com> | 2018-03-01 00:41:00 (GMT) |
commit | cc7770524d4a71ff5c84f8b00947278b49376e6c (patch) | |
tree | c71ebb467ed6c04a71cf4a4c7535c2d0c729548d | |
parent | 9e5f865a2c3e04eeef93f44085132b36223e0928 (diff) |
version 0.5.2.00.5.2.0
-rw-r--r-- | ChangeLog.md | 11 | ||||
-rw-r--r-- | persistable-record.cabal | 3 | ||||
-rw-r--r-- | src/Database/Record.hs | 6 | ||||
-rw-r--r-- | src/Database/Record/FromSql.hs | 2 | ||||
-rw-r--r-- | src/Database/Record/InternalTH.hs | 67 | ||||
-rw-r--r-- | src/Database/Record/Persistable.hs | 28 | ||||
-rw-r--r-- | src/Database/Record/TH.hs | 129 | ||||
-rw-r--r-- | src/Database/Record/ToSql.hs | 35 |
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) |