persistable-record 0.5.2.2 → 0.6.0.0
raw patch · 8 files changed
+110/−195 lines, 8 filesdep +product-isomorphicPVP ok
version bump matches the API change (PVP)
Dependencies added: product-isomorphic
API changes (from Hackage documentation)
- Database.Record.TH: defineRecord :: TypeQ -> ConName -> [(VarName, TypeQ)] -> [Name] -> Q [Dec]
- Database.Record.TH: defineRecordWithConfig :: TypeQ -> NameConfig -> String -> String -> [(String, TypeQ)] -> [Name] -> Q [Dec]
- Database.Record.TH: reifyRecordType :: Name -> Q ((TypeQ, ExpQ), (Maybe [Name], [TypeQ]))
- Database.Record.ToSql: updateValuesByUnique' :: RecordToSql q ra -> KeyConstraint Unique ra -> ra -> [q]
- Database.Record.TupleInstances: instance (Database.Record.FromSql.FromSql q a1, Database.Record.FromSql.FromSql q a2) => Database.Record.FromSql.FromSql q (a1, a2)
- Database.Record.TupleInstances: instance (Database.Record.FromSql.FromSql q a1, Database.Record.FromSql.FromSql q a2, Database.Record.FromSql.FromSql q a3) => Database.Record.FromSql.FromSql q (a1, a2, a3)
- Database.Record.TupleInstances: instance (Database.Record.FromSql.FromSql q a1, Database.Record.FromSql.FromSql q a2, Database.Record.FromSql.FromSql q a3, Database.Record.FromSql.FromSql q a4) => Database.Record.FromSql.FromSql q (a1, a2, a3, a4)
- Database.Record.TupleInstances: instance (Database.Record.FromSql.FromSql q a1, Database.Record.FromSql.FromSql q a2, Database.Record.FromSql.FromSql q a3, Database.Record.FromSql.FromSql q a4, Database.Record.FromSql.FromSql q a5) => Database.Record.FromSql.FromSql q (a1, a2, a3, a4, a5)
- Database.Record.TupleInstances: instance (Database.Record.FromSql.FromSql q a1, Database.Record.FromSql.FromSql q a2, Database.Record.FromSql.FromSql q a3, Database.Record.FromSql.FromSql q a4, Database.Record.FromSql.FromSql q a5, Database.Record.FromSql.FromSql q a6) => Database.Record.FromSql.FromSql q (a1, a2, a3, a4, a5, a6)
- Database.Record.TupleInstances: instance (Database.Record.FromSql.FromSql q a1, Database.Record.FromSql.FromSql q a2, Database.Record.FromSql.FromSql q a3, Database.Record.FromSql.FromSql q a4, Database.Record.FromSql.FromSql q a5, Database.Record.FromSql.FromSql q a6, Database.Record.FromSql.FromSql q a7) => Database.Record.FromSql.FromSql q (a1, a2, a3, a4, a5, a6, a7)
- Database.Record.TupleInstances: instance (Database.Record.Persistable.PersistableWidth a1, Database.Record.Persistable.PersistableWidth a2) => Database.Record.Persistable.PersistableWidth (a1, a2)
- Database.Record.TupleInstances: instance (Database.Record.Persistable.PersistableWidth a1, Database.Record.Persistable.PersistableWidth a2, Database.Record.Persistable.PersistableWidth a3) => Database.Record.Persistable.PersistableWidth (a1, a2, a3)
- Database.Record.TupleInstances: instance (Database.Record.Persistable.PersistableWidth a1, Database.Record.Persistable.PersistableWidth a2, Database.Record.Persistable.PersistableWidth a3, Database.Record.Persistable.PersistableWidth a4) => Database.Record.Persistable.PersistableWidth (a1, a2, a3, a4)
- Database.Record.TupleInstances: instance (Database.Record.Persistable.PersistableWidth a1, Database.Record.Persistable.PersistableWidth a2, Database.Record.Persistable.PersistableWidth a3, Database.Record.Persistable.PersistableWidth a4, Database.Record.Persistable.PersistableWidth a5) => Database.Record.Persistable.PersistableWidth (a1, a2, a3, a4, a5)
- Database.Record.TupleInstances: instance (Database.Record.Persistable.PersistableWidth a1, Database.Record.Persistable.PersistableWidth a2, Database.Record.Persistable.PersistableWidth a3, Database.Record.Persistable.PersistableWidth a4, Database.Record.Persistable.PersistableWidth a5, Database.Record.Persistable.PersistableWidth a6) => Database.Record.Persistable.PersistableWidth (a1, a2, a3, a4, a5, a6)
- Database.Record.TupleInstances: instance (Database.Record.Persistable.PersistableWidth a1, Database.Record.Persistable.PersistableWidth a2, Database.Record.Persistable.PersistableWidth a3, Database.Record.Persistable.PersistableWidth a4, Database.Record.Persistable.PersistableWidth a5, Database.Record.Persistable.PersistableWidth a6, Database.Record.Persistable.PersistableWidth a7) => Database.Record.Persistable.PersistableWidth (a1, a2, a3, a4, a5, a6, a7)
- Database.Record.TupleInstances: instance (Database.Record.ToSql.ToSql q a1, Database.Record.ToSql.ToSql q a2) => Database.Record.ToSql.ToSql q (a1, a2)
- Database.Record.TupleInstances: instance (Database.Record.ToSql.ToSql q a1, Database.Record.ToSql.ToSql q a2, Database.Record.ToSql.ToSql q a3) => Database.Record.ToSql.ToSql q (a1, a2, a3)
- Database.Record.TupleInstances: instance (Database.Record.ToSql.ToSql q a1, Database.Record.ToSql.ToSql q a2, Database.Record.ToSql.ToSql q a3, Database.Record.ToSql.ToSql q a4) => Database.Record.ToSql.ToSql q (a1, a2, a3, a4)
- Database.Record.TupleInstances: instance (Database.Record.ToSql.ToSql q a1, Database.Record.ToSql.ToSql q a2, Database.Record.ToSql.ToSql q a3, Database.Record.ToSql.ToSql q a4, Database.Record.ToSql.ToSql q a5) => Database.Record.ToSql.ToSql q (a1, a2, a3, a4, a5)
- Database.Record.TupleInstances: instance (Database.Record.ToSql.ToSql q a1, Database.Record.ToSql.ToSql q a2, Database.Record.ToSql.ToSql q a3, Database.Record.ToSql.ToSql q a4, Database.Record.ToSql.ToSql q a5, Database.Record.ToSql.ToSql q a6) => Database.Record.ToSql.ToSql q (a1, a2, a3, a4, a5, a6)
- Database.Record.TupleInstances: instance (Database.Record.ToSql.ToSql q a1, Database.Record.ToSql.ToSql q a2, Database.Record.ToSql.ToSql q a3, Database.Record.ToSql.ToSql q a4, Database.Record.ToSql.ToSql q a5, Database.Record.ToSql.ToSql q a6, Database.Record.ToSql.ToSql q a7) => Database.Record.ToSql.ToSql q (a1, a2, a3, a4, a5, a6, a7)
+ Database.Record.Persistable: instance Data.Functor.ProductIsomorphic.Class.ProductIsoFunctor (Database.Record.Persistable.ProductConst a)
+ Database.Record.Persistable: instance GHC.Base.Monoid a => Data.Functor.ProductIsomorphic.Class.ProductIsoApplicative (Database.Record.Persistable.ProductConst a)
+ Database.Record.TH: definePersistableWidthInstance :: TypeQ -> [Name] -> Q [Dec]
+ Database.Record.TH: defineSqlPersistableInstances :: TypeQ -> TypeQ -> [Name] -> Q [Dec]
+ Database.Record.ToSql: execToSqlM :: ToSqlM q a -> [q]
+ Database.Record.TupleInstances: instance (Database.Record.FromSql.FromSql q a0, Database.Record.FromSql.FromSql q b0) => Database.Record.FromSql.FromSql q (a0, b0)
+ Database.Record.TupleInstances: instance (Database.Record.FromSql.FromSql q a0, Database.Record.FromSql.FromSql q b0, Database.Record.FromSql.FromSql q c0) => Database.Record.FromSql.FromSql q (a0, b0, c0)
+ Database.Record.TupleInstances: instance (Database.Record.FromSql.FromSql q a0, Database.Record.FromSql.FromSql q b0, Database.Record.FromSql.FromSql q c0, Database.Record.FromSql.FromSql q d0) => Database.Record.FromSql.FromSql q (a0, b0, c0, d0)
+ Database.Record.TupleInstances: instance (Database.Record.FromSql.FromSql q a0, Database.Record.FromSql.FromSql q b0, Database.Record.FromSql.FromSql q c0, Database.Record.FromSql.FromSql q d0, Database.Record.FromSql.FromSql q e0) => Database.Record.FromSql.FromSql q (a0, b0, c0, d0, e0)
+ Database.Record.TupleInstances: instance (Database.Record.FromSql.FromSql q a0, Database.Record.FromSql.FromSql q b0, Database.Record.FromSql.FromSql q c0, Database.Record.FromSql.FromSql q d0, Database.Record.FromSql.FromSql q e0, Database.Record.FromSql.FromSql q f0) => Database.Record.FromSql.FromSql q (a0, b0, c0, d0, e0, f0)
+ Database.Record.TupleInstances: instance (Database.Record.FromSql.FromSql q a0, Database.Record.FromSql.FromSql q b0, Database.Record.FromSql.FromSql q c0, Database.Record.FromSql.FromSql q d0, Database.Record.FromSql.FromSql q e0, Database.Record.FromSql.FromSql q f0, Database.Record.FromSql.FromSql q g0) => Database.Record.FromSql.FromSql q (a0, b0, c0, d0, e0, f0, g0)
+ Database.Record.TupleInstances: instance (Database.Record.Persistable.PersistableWidth a0, Database.Record.Persistable.PersistableWidth b0) => Database.Record.Persistable.PersistableWidth (a0, b0)
+ Database.Record.TupleInstances: instance (Database.Record.Persistable.PersistableWidth a0, Database.Record.Persistable.PersistableWidth b0, Database.Record.Persistable.PersistableWidth c0) => Database.Record.Persistable.PersistableWidth (a0, b0, c0)
+ Database.Record.TupleInstances: instance (Database.Record.Persistable.PersistableWidth a0, Database.Record.Persistable.PersistableWidth b0, Database.Record.Persistable.PersistableWidth c0, Database.Record.Persistable.PersistableWidth d0) => Database.Record.Persistable.PersistableWidth (a0, b0, c0, d0)
+ Database.Record.TupleInstances: instance (Database.Record.Persistable.PersistableWidth a0, Database.Record.Persistable.PersistableWidth b0, Database.Record.Persistable.PersistableWidth c0, Database.Record.Persistable.PersistableWidth d0, Database.Record.Persistable.PersistableWidth e0) => Database.Record.Persistable.PersistableWidth (a0, b0, c0, d0, e0)
+ Database.Record.TupleInstances: instance (Database.Record.Persistable.PersistableWidth a0, Database.Record.Persistable.PersistableWidth b0, Database.Record.Persistable.PersistableWidth c0, Database.Record.Persistable.PersistableWidth d0, Database.Record.Persistable.PersistableWidth e0, Database.Record.Persistable.PersistableWidth f0) => Database.Record.Persistable.PersistableWidth (a0, b0, c0, d0, e0, f0)
+ Database.Record.TupleInstances: instance (Database.Record.Persistable.PersistableWidth a0, Database.Record.Persistable.PersistableWidth b0, Database.Record.Persistable.PersistableWidth c0, Database.Record.Persistable.PersistableWidth d0, Database.Record.Persistable.PersistableWidth e0, Database.Record.Persistable.PersistableWidth f0, Database.Record.Persistable.PersistableWidth g0) => Database.Record.Persistable.PersistableWidth (a0, b0, c0, d0, e0, f0, g0)
+ Database.Record.TupleInstances: instance (Database.Record.ToSql.ToSql q a0, Database.Record.ToSql.ToSql q b0) => Database.Record.ToSql.ToSql q (a0, b0)
+ Database.Record.TupleInstances: instance (Database.Record.ToSql.ToSql q a0, Database.Record.ToSql.ToSql q b0, Database.Record.ToSql.ToSql q c0) => Database.Record.ToSql.ToSql q (a0, b0, c0)
+ Database.Record.TupleInstances: instance (Database.Record.ToSql.ToSql q a0, Database.Record.ToSql.ToSql q b0, Database.Record.ToSql.ToSql q c0, Database.Record.ToSql.ToSql q d0) => Database.Record.ToSql.ToSql q (a0, b0, c0, d0)
+ Database.Record.TupleInstances: instance (Database.Record.ToSql.ToSql q a0, Database.Record.ToSql.ToSql q b0, Database.Record.ToSql.ToSql q c0, Database.Record.ToSql.ToSql q d0, Database.Record.ToSql.ToSql q e0) => Database.Record.ToSql.ToSql q (a0, b0, c0, d0, e0)
+ Database.Record.TupleInstances: instance (Database.Record.ToSql.ToSql q a0, Database.Record.ToSql.ToSql q b0, Database.Record.ToSql.ToSql q c0, Database.Record.ToSql.ToSql q d0, Database.Record.ToSql.ToSql q e0, Database.Record.ToSql.ToSql q f0) => Database.Record.ToSql.ToSql q (a0, b0, c0, d0, e0, f0)
+ Database.Record.TupleInstances: instance (Database.Record.ToSql.ToSql q a0, Database.Record.ToSql.ToSql q b0, Database.Record.ToSql.ToSql q c0, Database.Record.ToSql.ToSql q d0, Database.Record.ToSql.ToSql q e0, Database.Record.ToSql.ToSql q f0, Database.Record.ToSql.ToSql q g0) => Database.Record.ToSql.ToSql q (a0, b0, c0, d0, e0, f0, g0)
- Database.Record.FromSql: class FromSql q a
+ Database.Record.FromSql: class FromSql q a where recordFromSql = to <$> gFromSql
- Database.Record.Persistable: class PersistableWidth a
+ Database.Record.Persistable: class PersistableWidth a where persistableWidth = pmapConst (Sum . lastA) genericFieldOffsets where lastA a = a ! (snd $ bounds a)
- Database.Record.TH: defineColumnOffsets :: ConName -> [TypeQ] -> Q [Dec]
+ Database.Record.TH: defineColumnOffsets :: ConName -> Q [Dec]
- Database.Record.ToSql: class PersistableWidth a => ToSql q a
+ Database.Record.ToSql: class PersistableWidth a => ToSql q a where recordToSql = from `mapToSql` gToSql
- Database.Record.ToSql: unsafeUpdateValuesWithIndexes :: RecordToSql q ra -> [Int] -> ra -> [q]
+ Database.Record.ToSql: unsafeUpdateValuesWithIndexes :: ToSql q ra => [Int] -> ra -> [q]
Files
- ChangeLog.md +5/−14
- persistable-record.cabal +2/−1
- src/Database/Record.hs +3/−3
- src/Database/Record/FromSql.hs +1/−1
- src/Database/Record/InternalTH.hs +43/−22
- src/Database/Record/Persistable.hs +14/−14
- src/Database/Record/TH.hs +28/−119
- src/Database/Record/ToSql.hs +14/−21
ChangeLog.md view
@@ -1,21 +1,12 @@ <!-- -*- Markdown -*- --> -## 0.5.2.2--- fix example of NameConfig customization.--## 0.5.2.1--- bugfix: pass correct table name to macro for field label defintion.--## 0.5.2.0+## 0.6.0.0 -- check width of Int type and add instances. (backport)-- fix typo.+- divide and apply product-isomorphic interfaces. ## 0.5.1.1 -- Update this changelog.+- update this changelog. ## 0.5.1.0 @@ -27,11 +18,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
persistable-record.cabal view
@@ -1,5 +1,5 @@ name: persistable-record-version: 0.5.2.2+version: 0.6.0.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,6 +37,7 @@ build-depends: base <5 , template-haskell , th-data-compat+ , product-isomorphic >= 0.0.3 , array , containers , transformers
src/Database/Record.hs view
@@ -28,7 +28,7 @@ -- ** 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 @@ 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 ()
src/Database/Record/FromSql.hs view
@@ -60,7 +60,7 @@ foo = ... bar :: 'RecordFromSql' SqlValue Bar bar = ...- baz :: 'RecordFromSql' SqlValue Baz+ baz :: 'RecordFromSql' SqlValue Bar baz = ... @
src/Database/Record/InternalTH.hs view
@@ -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) |]- []+ (((tyCon, avs), _), _) <- reifyRecordType $ tupleTypeName n+ definePersistableWidthInstance tyCon avs -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) |]- []+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
src/Database/Record/Persistable.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | -- Module : Database.Record.Persistable@@ -34,11 +35,13 @@ ) 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 @@ -- | 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 @@ 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 @@ -- | 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 @@ 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.
src/Database/Record/TH.hs view
@@ -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 @@ -- * 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 @@ 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,18 +72,17 @@ (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. data NameConfig = NameConfig { recordTypeName :: String -> String -> ConName- -- ^ Make record type name generated from the table's definition.- -- The first argument is the schema name of the table, and the second argument is the table name.+ -- ^ Make record type symbol name from schema name and table name in SQL , columnName :: String -> String -> VarName- -- ^ Make each field label of the record type generated from the table's definition.- -- The first argument is the table name, and the second argument is the column name.+ -- ^ Make column variable symbol name from table name and column name in SQL } -- | Dummy show instance. Handy to define show instance recursively.@@ -100,15 +90,7 @@ show = const "<nameConfig>" -- | Default implementation of 'NameConfig' type.--- To change how the generated record type and its columns are named,--- use record update syntax:------ > defaultNameConfig--- > { recordTypeName = \schema table -> varCamelcaseName $ schema ++ "_" ++ table--- > ^ append the table name after the schema name. e.g. "schemaTable"--- > , columnName = \table column -> varCamelcaseName $ table ++ "_" ++ column--- > ^ append the column name after the table name. e.g. "tableColumn"--- > }+-- To customize this, use record update syntax. defaultNameConfig :: NameConfig defaultNameConfig = NameConfig@@ -132,14 +114,14 @@ 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 |]@@ -147,7 +129,7 @@ -- | 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@@ -163,7 +145,7 @@ -- | 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 |] @@ -175,24 +157,19 @@ $(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)@@ -202,84 +179,16 @@ {- 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 table 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-+ [ (columnName config schema n, t) | (n, t) <- columns ] -- | Templates for single column value type. deriveNotNullType :: TypeQ -> Q [Dec]
src/Database/Record/ToSql.hs view
@@ -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 @@ -- | 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 @@ 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 @@ -- | 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 @@ -- @ -- -- 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 @@ -- 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)