packages feed

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 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)