persistable-record 0.4.2.0 → 0.5.0.0

raw patch · 11 files changed

+427/−294 lines, 11 filesdep +ghc-primPVP ok

version bump matches the API change (PVP)

Dependencies added: ghc-prim

API changes (from Hackage documentation)

Files

• ChangeLog.md +38/−0
• persistable-record.cabal +17/−3
• src/Database/Record.hs +1/−0
• src/Database/Record/FromSql.hs +27/−9
• src/Database/Record/InternalTH.hs +45/−0
• src/Database/Record/Persistable.hs +79/−18
• src/Database/Record/TH.hs +50/−192
• src/Database/Record/ToSql.hs +37/−12
• src/Database/Record/TupleInstances.hs +13/−0
• test/Model.hs +74/−0
• test/nestedEq.hs +46/−60

@@ -0,0 +1,38 @@+<!-- -*- Markdown -*- -->++## 0.5.0.0++- Add generic instances of FromSql, ToSql and PersistableWidth.++## 0.4.1.1++- Tested with GHC 8.0.2+- Add a small test set.++## 0.4.1.0++- Export columnName of NameConfig.++## 0.4.0.3++- Drop an unreferenced definition.++## 0.4.0.2++- Add tested-with.++## 0.4.0.1++- Apply th-data-compat.++## 0.4.0.0++- Divide PersistableValue interface to FromSql and ToSql.++## 0.3.0.0++- Add symbol name configurations of templates.++## 0.2.0.0++- TH quotation of derive class names.

@@ -1,5 +1,5 @@ name:                persistable-record-version:             0.4.2.0+version:             0.5.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.@@ -12,23 +12,31 @@ category:            Database build-type:          Simple cabal-version:       >=1.10-tested-with:           GHC == 8.2.1-                     , GHC == 8.0.1, GHC == 8.0.2+tested-with:           GHC == 8.0.1, GHC == 8.0.2                      , GHC == 7.10.1, GHC == 7.10.2, GHC == 7.10.3                      , GHC == 7.8.1, GHC == 7.8.2, GHC == 7.8.3, GHC == 7.8.4                      , GHC == 7.6.1, GHC == 7.6.2, GHC == 7.6.3                      , GHC == 7.4.1, GHC == 7.4.2+extra-source-files:  ChangeLog.md +flag ghc74-generic+  description: Enable for generic programming using old ghc. If true use ghc-prim.+  default:     False+ library   exposed-modules:                         Database.Record.FromSql                         Database.Record.ToSql                         Database.Record.Persistable+                        Database.Record.TupleInstances                         Database.Record.Instances                         Database.Record.KeyConstraint                         Database.Record                         Database.Record.TH +  other-modules:+                        Database.Record.InternalTH+   build-depends:          base <5                         , template-haskell                         , th-data-compat@@ -37,6 +45,9 @@                         , transformers                         , dlist                         , names-th+  if flag(ghc74-generic)+    build-depends:        ghc-prim == 0.2.*+   hs-source-dirs:       src   ghc-options:          -Wall   default-language:     Haskell2010@@ -45,9 +56,12 @@   build-depends:          base <5                         , quickcheck-simple                         , persistable-record+  if flag(ghc74-generic)+    build-depends:        ghc-prim == 0.2.*    type:                 exitcode-stdio-1.0   main-is:              nestedEq.hs+  other-modules:        Model   hs-source-dirs:       test   ghc-options:          -Wall   default-language:     Haskell2010

@@ -48,6 +48,7 @@   (ToSqlM, RecordToSql, ToSql(..), valueRecordToSql,    runFromRecord, wrapToSql, putRecord, putEmpty, fromRecord,    updateValuesByUnique, updateValuesByPrimary)+import Database.Record.TupleInstances ()  {- $concepts On most drivers for SQL database,

@@ -1,10 +1,12 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DefaultSignatures #-}  -- | -- Module      : Database.Record.FromSql--- Copyright   : 2013 Kei Hibino+-- Copyright   : 2013-2017 Kei Hibino -- License     : BSD3 -- -- Maintainer  : ex8k.hibino@gmail.com@@ -29,13 +31,15 @@   valueRecordFromSql,   ) where +import GHC.Generics (Generic, Rep, U1 (..), K1 (..), M1 (..), (:*:)(..), to)+import Control.Applicative ((<$>), Applicative (pure, (<*>)))+import Control.Monad (liftM, ap)+ import Database.Record.Persistable (PersistableType) import qualified Database.Record.Persistable as Persistable import Database.Record.KeyConstraint   (HasColumnConstraint(columnConstraint), ColumnConstraint, NotNull, index) -import Control.Monad (liftM, ap)-import Control.Applicative ((<$>), Applicative(pure, (<*>)))  {- $recordFromSql Structure of 'RecordFromSql' 'q' 'a' is similar to parser.@@ -128,11 +132,26 @@   -- | 'RecordFromSql' proof object.   recordFromSql :: RecordFromSql q a --- | Inference rule of 'RecordFromSql' proof object which can convert---   from list of SQL type ['q'] into Haskell tuple ('a', 'b') type.-instance (FromSql q a, FromSql q b) => FromSql q (a, b)  where-  recordFromSql = recordFromSql <&> recordFromSql+  default recordFromSql :: (Generic a, GFromSql q (Rep a)) => RecordFromSql q a+  recordFromSql = to <$> gFromSql ++class GFromSql q f where+  gFromSql :: RecordFromSql q (f a)++instance GFromSql q U1 where+  gFromSql = createRecordFromSql $ (,) U1++instance (GFromSql q a, GFromSql q b) => GFromSql q (a :*: b) where+  gFromSql = (:*:) <$> gFromSql <*> gFromSql++instance GFromSql q a => GFromSql q (M1 i c a) where+  gFromSql = M1 <$> gFromSql++instance FromSql q a => GFromSql q (K1 i a) where+  gFromSql = K1 <$> recordFromSql++ -- | Inference rule of 'RecordFromSql' proof object which can convert --   from list of SQL type ['q'] into Haskell 'Maybe' type. instance (HasColumnConstraint NotNull a, FromSql q a, PersistableType q)@@ -141,8 +160,7 @@  -- | Inference rule of 'RecordFromSql' proof object which can convert --   from /empty/ list of SQL type ['q'] into Haskell unit () type.-instance FromSql q () where-  recordFromSql = RecordFromSql (\qs -> ((), qs))+instance FromSql q ()  -- default generic instance  -- | Run inferred 'RecordFromSql' proof object. --   Convert from list of SQL type ['q'] into haskell type 'a' and rest of list ['q'].

@@ -0,0 +1,45 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ConstraintKinds #-}++module Database.Record.InternalTH (+  defineTupleInstances+  ) where++import Control.Applicative ((<$>))+import Data.List (foldl')+import Language.Haskell.TH+  (Q, mkName, Name,+   conT, varT, tupleT, appT, classP,+   Dec, instanceD, )++import Database.Record.Persistable (PersistableWidth)+import Database.Record.FromSql (FromSql)+import Database.Record.ToSql (ToSql)+++persistableWidth :: Int -> Q [Dec]+persistableWidth n = do+  let vs = [ varT . mkName $ "a" ++ show i | i <- [1 .. n] ]+  (:[]) <$> instanceD+    -- in template-haskell 2.8 or older, Pred is not Type+    (mapM (classP ''PersistableWidth . (:[])) vs)+    [t| PersistableWidth $(foldl' appT (tupleT n) vs) |]+    []++tupleInstance2 :: Int -> Name -> Q [Dec]+tupleInstance2 n clazz = do+  let vs = [ varT . mkName $ "a" ++ show i | i <- [1 .. n] ]+      q = varT $ mkName "q"+  (:[]) <$> instanceD+    -- in template-haskell 2.8 or older, Pred is not Type+    (mapM (\v -> classP clazz [q, v]) vs)+    [t| $(conT clazz) $q $(foldl' appT (tupleT n) vs) |]+    []++-- | 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 ]

@@ -1,9 +1,12 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DefaultSignatures #-}  -- | -- Module      : Database.Record.Persistable--- Copyright   : 2013 Kei Hibino+-- Copyright   : 2013-2017 Kei Hibino -- License     : BSD3 -- -- Maintainer  : ex8k.hibino@gmail.com@@ -21,12 +24,23 @@   unsafePersistableRecordWidth, unsafeValueWidth, (<&>), maybeWidth,    -- * Inference rules for proof objects-   PersistableType(..), sqlNullValue,-  PersistableWidth (..), derivedWidth+  PersistableWidth (..), derivedWidth,++  -- * low-level interfaces+  GFieldWidthList,+  ProductConst, getProductConst,+  genericFieldOffsets,   ) where +import GHC.Generics (Generic, Rep, U1 (..), K1 (..), M1 (..), (:*:)(..), to)+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 + -- | Proof object to specify type 'q' is SQL type newtype PersistableSqlType q = PersistableSqlType q @@ -40,35 +54,54 @@ unsafePersistableSqlTypeFromNull =  PersistableSqlType  +-- | Restricted in product isomorphism record type b+newtype ProductConst a b =+  ProductConst { unPC :: Const a b }++-- | extract constant value of 'ProductConst'.+getProductConst :: ProductConst a b -> a+getProductConst = getConst . unPC+{-# INLINE getProductConst #-}+ -- | Proof object to specify width of Haskell type 'a' --   when converting to SQL type list.-newtype PersistableRecordWidth a =-  PersistableRecordWidth Int+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++ -- | Get width 'Int' value of record type 'a'. runPersistableRecordWidth :: PersistableRecordWidth a -> Int-runPersistableRecordWidth (PersistableRecordWidth w) = w+runPersistableRecordWidth = getSum . getConst . unPC+{-# INLINE runPersistableRecordWidth #-} +instance Show a => Show (ProductConst a b) where+  show = ("PC " ++) . show . getConst . unPC+ -- | Unsafely generate 'PersistableRecordWidth' proof object from specified width of Haskell type 'a'. unsafePersistableRecordWidth :: Int                      -- ^ Specify width of Haskell type 'a'                              -> PersistableRecordWidth a -- ^ Result proof object-unsafePersistableRecordWidth =  PersistableRecordWidth+unsafePersistableRecordWidth = ProductConst . Const . Sum+{-# INLINE unsafePersistableRecordWidth #-}  -- | Unsafely generate 'PersistableRecordWidth' proof object for Haskell type 'a' which is single column type. unsafeValueWidth :: PersistableRecordWidth a unsafeValueWidth =  unsafePersistableRecordWidth 1+{-# INLINE unsafeValueWidth #-}  -- | Derivation rule of 'PersistableRecordWidth' for tuple (,) type. (<&>) :: PersistableRecordWidth a -> PersistableRecordWidth b -> PersistableRecordWidth (a, b)-a <&> b = PersistableRecordWidth $ runPersistableRecordWidth a + runPersistableRecordWidth 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 =  PersistableRecordWidth . runPersistableRecordWidth---- | Axiom of 'PersistableRecordWidth' for Haskell unit () type.-voidWidth :: PersistableRecordWidth ()-voidWidth =  unsafePersistableRecordWidth 0+maybeWidth = pmap Just   -- | Interface of inference rule for 'PersistableSqlType' proof object@@ -84,17 +117,45 @@ class PersistableWidth a where   persistableWidth :: PersistableRecordWidth a --- | Inference rule of 'PersistableRecordWidth' proof object for tuple ('a', 'b') type.-instance (PersistableWidth a, PersistableWidth b) => PersistableWidth (a, b) where-  persistableWidth = persistableWidth <&> persistableWidth+  default persistableWidth :: (Generic a, GFieldWidthList (Rep a)) => PersistableRecordWidth a+  persistableWidth = pmapConst (Sum . lastA) genericFieldOffsets+    where+      lastA a = a ! (snd $ bounds a) ++pmapConst :: (a -> b) -> ProductConst a c -> ProductConst b c+pmapConst f = ProductConst . Const . f . getConst . unPC++-- | Generic width value list of record fields.+class GFieldWidthList f where+  gFieldWidthList :: ProductConst (DList Int) (f a)++instance GFieldWidthList U1 where+  gFieldWidthList = ProductConst $ pure U1++instance (GFieldWidthList a, GFieldWidthList b) => GFieldWidthList (a :*: b) where+  gFieldWidthList = (:*:) `pmap` gFieldWidthList `pap` gFieldWidthList++instance GFieldWidthList a => GFieldWidthList (M1 i c a) where+  gFieldWidthList = M1 `pmap` gFieldWidthList++instance PersistableWidth a => GFieldWidthList (K1 i a) where+  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++ -- | Inference rule of 'PersistableRecordWidth' proof object for 'Maybe' type. instance PersistableWidth a => PersistableWidth (Maybe a) where   persistableWidth = maybeWidth persistableWidth  -- | Inference rule of 'PersistableRecordWidth' for Haskell unit () type. Derive from axiom.-instance PersistableWidth () where-  persistableWidth = voidWidth+instance PersistableWidth ()  -- default generic instance  -- | Pass type parameter and inferred width value. derivedWidth :: PersistableWidth a => (PersistableRecordWidth a, Int)

@@ -4,7 +4,7 @@  -- | -- Module      : Database.Record.TH--- Copyright   : 2013 Kei Hibino+-- Copyright   : 2013-2017 Kei Hibino -- License     : BSD3 -- -- Maintainer  : ex8k.hibino@gmail.com@@ -18,9 +18,6 @@   defineRecord,   defineRecordWithConfig, -  -- * Deriving class symbols-  derivingEq, derivingShow, derivingRead, derivingData, derivingTypeable,-   -- * Table constraint specified by key   defineHasColumnConstraintInstance,   defineHasPrimaryConstraintInstanceDerived,@@ -31,70 +28,60 @@   defineRecordType,   defineRecordTypeWithConfig, -  -- * Function declarations depending on SQL type-  makeRecordPersistableWithSqlType,-  makeRecordPersistableWithSqlTypeWithConfig,-  makeRecordPersistableWithSqlTypeDefault,-   -- * Function declarations against defined record types-  makeRecordPersistableWithSqlTypeFromDefined,-  makeRecordPersistableWithSqlTypeDefaultFromDefined,   defineColumnOffsets,    recordWidthTemplate, -  defineRecordParser,-  defineRecordPrinter,--  definePersistableInstance,-   -- * Reify   reifyRecordType, -  -- * Templates about record type name+  -- * Templates about record name   NameConfig,  defaultNameConfig,   recordTypeName, columnName, -  recordType,+  recordTemplate,    columnOffsetsVarNameDefault, -  persistableFunctionNamesDefault,-   -- * Not nullable single column type-  deriveNotNullType-  ) where+  deriveNotNullType, +  -- * Template for tuple types+  defineTupleInstances,+  ) where -import Control.Applicative (pure, (<*>))-import Data.List (foldl')-import Data.Array (Array, listArray, (!))-import Data.Data (Data, Typeable)+import GHC.Generics (Generic)+import Data.Array (Array) import Language.Haskell.TH.Name.CamelCase   (ConName(conName), VarName(varName),    conCamelcaseName, varCamelcaseName, varNameWithPrefix,-   toTypeCon, toDataCon, toVarExp)-import Language.Haskell.TH.Lib.Extra (integralE, simpleValD)+   toTypeCon, toDataCon, )+import Language.Haskell.TH.Lib.Extra (integralE, simpleValD, reportWarning) import Language.Haskell.TH.Compat.Data (dataD', unDataD) import Language.Haskell.TH-  (Q, newName, nameBase, reify, Info(TyConI), Name,+  (Q, nameBase, reify, Info(TyConI), Name,    TypeQ, conT, Con (NormalC, RecC),-   Dec, sigD, valD,-   ExpQ, Exp(ConE), conE, varE, lamE, listE, sigE,-   varP, conP, normalB, 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),-   FromSql(recordFromSql), RecordFromSql,-   ToSql(recordToSql), RecordToSql, wrapToSql, putRecord, putEmpty)+   FromSql, ToSql, )  import Database.Record.KeyConstraint   (unsafeSpecifyColumnConstraint, unsafeSpecifyNotNullValue, unsafeSpecifyKeyConstraint)-import Database.Record.Persistable (unsafePersistableRecordWidth, runPersistableRecordWidth)+import Database.Record.Persistable+  (runPersistableRecordWidth,+   ProductConst, getProductConst, genericFieldOffsets) import qualified Database.Record.Persistable as Persistable+import Database.Record.InternalTH (defineTupleInstances)   -- | 'NameConfig' type to customize names of expanded record templates.@@ -119,12 +106,12 @@   , columnName      =  const varCamelcaseName   } --- | Record type constructor template from SQL table name 'String'.-recordType :: NameConfig -- ^ name rule config-           -> String     -- ^ Schema name string in SQL-           -> String     -- ^ Table name string in SQL-           -> TypeQ      -- ^ Record type constructor-recordType config scm = toTypeCon . recordTypeName config scm+-- | Record constructor templates from SQL table name 'String'.+recordTemplate :: NameConfig    -- ^ name rule config+               -> String        -- ^ Schema name string in SQL+               -> String        -- ^ Table name string in SQL+               -> (TypeQ, ExpQ) -- ^ Record type and data constructor+recordTemplate config scm = (toTypeCon &&& toDataCon) . recordTypeName config scm  -- | Variable expression of record column offset array. columnOffsetsVarNameDefault :: Name    -- ^ Table type name@@ -170,31 +157,6 @@ defineHasNotNullKeyInstance =   defineHasColumnConstraintInstance [t| NotNull |] -{-# DEPRECATED derivingEq "Use TH quasi-quotation like ''Eq instead of this." #-}--- | Name to specify deriving 'Eq'-derivingEq   :: Name-derivingEq   = ''Eq--{-# DEPRECATED derivingShow "Use TH quasi-quotation like ''Show instead of this." #-}--- | Name to specify deriving 'Show'-derivingShow :: Name-derivingShow = ''Show--{-# DEPRECATED derivingRead "Use TH quasi-quotation like ''Read instead of this." #-}--- | Name to specify deriving 'Read'-derivingRead :: Name-derivingRead = ''Read--{-# DEPRECATED derivingData "Use TH quasi-quotation like ''Data instead of this." #-}--- | Name to specify deriving 'Data'-derivingData :: Name-derivingData = ''Data--{-# DEPRECATED derivingTypeable "Use TH quasi-quotation like ''Typeable instead of this." #-}--- | Name to specify deriving 'Typeable'-derivingTypeable :: Name-derivingTypeable = ''Typeable- -- | Record type width expression template. recordWidthTemplate :: TypeQ -- ^ Record type constructor.                     -> ExpQ  -- ^ Expression to get record width.@@ -211,10 +173,8 @@   let ofsVar = columnOffsetsVarNameDefault $ conName typeName'       widthIxE = integralE $ length tys   ar <- simpleValD (varName ofsVar) [t| Array Int Int |]-        [| listArray (0 :: Int, $widthIxE) $-           scanl (+) (0 :: Int) $(listE $ map recordWidthTemplate tys) |]-  pw <- [d| instance PersistableWidth $(toTypeCon typeName') where-              persistableWidth = unsafePersistableRecordWidth $ $(toVarExp ofsVar) ! $widthIxE+        [| getProductConst (genericFieldOffsets :: ProductConst (Array Int Int) $(toTypeCon typeName')) |]+  pw <- [d| instance PersistableWidth $(toTypeCon typeName')           |]   return $ ar ++ pw @@ -226,9 +186,14 @@ defineRecordType typeName' columns derives = do   let typeName = conName typeName'       fld (n, tq) = varStrictType (varName n) (strictType isStrict tq)-  rec  <- dataD' (cxt []) typeName [] [recC typeName (map fld columns)] derives+  derives1 <- if (''Generic `notElem` derives)+              then do reportWarning "HRR needs Generic instance, please add ''Generic manually."+                      return $ ''Generic : derives+                      {- 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+  return $ rec' : offs  -- | Record type declaration template with configured names. defineRecordTypeWithConfig :: NameConfig -> String -> String -> [(String, TypeQ)] -> [Name] -> Q [Dec]@@ -238,79 +203,6 @@   [ (columnName config schema n, t) | (n, t) <- columns ]  --- | Record parser template.-defineRecordParser :: TypeQ         -- ^ SQL value type.-                   -> VarName       -- ^ Name of record parser.-                   -> (TypeQ, ExpQ) -- ^ Record type constructor and data constructor.-                   -> Int           -- ^ Count of record columns.-                   -> Q [Dec]       -- ^ Declaration of record construct function from SQL values.-defineRecordParser sqlValType name' (tyCon, dataCon) width = do-  let name = varName name'-  sig <- sigD name [t| RecordFromSql $sqlValType $tyCon |]-  var <- valD (varP name)-         (normalB-          (foldl' (\a x -> [| $a <*> $x |]) [| pure $dataCon |]-           $ replicate width [| recordFromSql |])-         )-         []-  return [sig, var]--dataConInfo :: Exp -> Q Name-dataConInfo =  d  where-  d (ConE n) = return n-  d e        = fail $ "Not record data constructor: " ++ show e---- | Record printer template.-defineRecordPrinter :: TypeQ         -- ^ SQL value type.-                    -> VarName       -- ^ Name of record printer.-                    -> (TypeQ, ExpQ) -- ^ Record type constructor and data constructor.-                    -> Int           -- ^ Count of record columns.-                    -> Q [Dec]       -- ^ Declaration of record construct function from SQL values.-defineRecordPrinter sqlValType name' (tyCon, dataCon) width = do-  let name = varName name'-  sig <- sigD name [t| RecordToSql $sqlValType $tyCon |]-  names <- mapM (newName . ('f':) . show) [1 .. width]-  dcn <- dataCon >>= dataConInfo-  var <- valD (varP name)-         (normalB [| wrapToSql-                     $(lamE-                       [ conP dcn [ varP n | n <- names ] ]-                       (foldr (\a x -> [| $a >> $x |]) [| putEmpty () |]-                        [ [| putRecord $(varE n) |] | n <- names ])) |])-         []-  return [sig, var]---- | 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.-                           -> VarName -- ^ Record parser name.-                           -> VarName -- ^ Record printer name.-                           -> Int     -- ^ Count of record columns.-                           -> Q [Dec] -- ^ Instance declarations for 'Persistable'.-definePersistableInstance sqlType typeCon parserName printerName _width = do-  [d| instance FromSql $sqlType $typeCon where-        recordFromSql = $(toVarExp parserName)--      instance ToSql $sqlType $typeCon where-        recordToSql = $(toVarExp printerName)-    |]---- | All templates depending on SQL value type.-makeRecordPersistableWithSqlType :: TypeQ              -- ^ SQL value type.-                                 -> (VarName, VarName) -- ^ Constructor function name and decompose function name.-                                 -> (TypeQ, ExpQ)      -- ^ Record type constructor and data constructor.-                                 -> Int                -- ^ Count of record columns.-                                 -> Q [Dec]            -- ^ Result declarations.-makeRecordPersistableWithSqlType-  sqlValueType-  (cF, dF) conPair@(tyCon, _)-  width = do-  fromSQL  <- defineRecordParser sqlValueType cF conPair width-  toSQL    <- defineRecordPrinter sqlValueType dF conPair width-  instSQL  <- definePersistableInstance sqlValueType tyCon cF dF width-  return $ fromSQL ++ toSQL ++ instSQL- -- | Default name of record construction function from SQL table name. fromSqlNameDefault :: String -> VarName fromSqlNameDefault =  (`varNameWithPrefix` "fromSqlOf")@@ -319,29 +211,6 @@ toSqlNameDefault :: String -> VarName toSqlNameDefault =  (`varNameWithPrefix` "toSqlOf") --- | All templates depending on SQL value type with configured names.-makeRecordPersistableWithSqlTypeWithConfig :: TypeQ      -- ^ SQL value type-                                         -> NameConfig -- ^ name rule config-                                         -> String     -- ^ Schema name of database-                                         -> String     -- ^ Table name of database-                                         -> Int        -- ^ Count of record columns-                                         -> Q [Dec]    -- ^ Result declarations-makeRecordPersistableWithSqlTypeWithConfig sqlValueType config schema table width =-  makeRecordPersistableWithSqlType-    sqlValueType-    (persistableFunctionNamesDefault . conName . conCamelcaseName $ table)-    (recordType config schema table, toDataCon . recordTypeName config schema $ table)-    width---- | All templates depending on SQL value type with default names.-makeRecordPersistableWithSqlTypeDefault :: TypeQ   -- ^ SQL value type-                                        -> String  -- ^ Schema name-                                        -> String  -- ^ Table name-                                        -> Int     -- ^ Count of record columns-                                        -> Q [Dec] -- ^ Result declarations-makeRecordPersistableWithSqlTypeDefault sqlValueType =-  makeRecordPersistableWithSqlTypeWithConfig sqlValueType defaultNameConfig- recordInfo' :: Info -> Maybe ((TypeQ, ExpQ), (Maybe [Name], [TypeQ])) recordInfo' =  d  where   d (TyConI tcon) = do@@ -362,41 +231,29 @@     return     (recordInfo' tyConInfo) --- | Generate persistable function symbol names using default rule.-persistableFunctionNamesDefault :: Name -> (VarName, VarName)-persistableFunctionNamesDefault recTypeName = (fromSqlNameDefault bn, toSqlNameDefault bn)  where-  bn = nameBase recTypeName---- | All templates depending on SQL value type. Defined record type information is used.-makeRecordPersistableWithSqlTypeFromDefined :: TypeQ              -- ^ SQL value type-                                            -> (VarName, VarName) -- ^ Constructor function name and decompose function name-                                            -> Name               -- ^ Record type constructor name-                                            -> Q [Dec]            -- ^ Result declarations-makeRecordPersistableWithSqlTypeFromDefined sqlValueType fnames recTypeName = do-  (conPair, (_, cts)) <- reifyRecordType recTypeName-  makeRecordPersistableWithSqlType sqlValueType fnames conPair $ length cts---- | All templates depending on SQL value type with default names. Defined record type information is used.-makeRecordPersistableWithSqlTypeDefaultFromDefined :: TypeQ   -- ^ SQL value type-                                                   -> Name    -- ^ Record type constructor name-                                                   -> Q [Dec] -- ^ Result declarations-makeRecordPersistableWithSqlTypeDefaultFromDefined sqlValueType recTypeName =-  makeRecordPersistableWithSqlTypeFromDefined sqlValueType (persistableFunctionNamesDefault recTypeName) recTypeName+-- | 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-             -> (VarName, VarName) -- ^ Constructor function name and decompose function name              -> ConName            -- ^ Record type name              -> [(VarName, TypeQ)] -- ^ Column schema              -> [Name]             -- ^ Record derivings              -> Q [Dec]            -- ^ Result declarations defineRecord   sqlValueType-  fnames tyC+  tyC   columns drvs = do    typ     <- defineRecordType tyC columns drvs-  withSql <- makeRecordPersistableWithSqlType sqlValueType fnames (toTypeCon tyC, toDataCon tyC) $ length columns+  withSql <- definePersistableInstance sqlValueType $ toTypeCon tyC   return $ typ ++ withSql  -- | All templates for record type with configured names.@@ -409,7 +266,8 @@                      -> Q [Dec]           -- ^ Result declarations defineRecordWithConfig sqlValueType config schema table columns derives = do   typ     <- defineRecordTypeWithConfig config schema table columns derives-  withSql <- makeRecordPersistableWithSqlTypeWithConfig sqlValueType config schema table $ length columns+  withSql <- definePersistableInstance sqlValueType . fst $ recordTemplate config schema table+   return $ typ ++ withSql  

@@ -1,10 +1,12 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DefaultSignatures #-}  -- | -- Module      : Database.Record.ToSql--- Copyright   : 2013 Kei Hibino+-- Copyright   : 2013-2017 Kei Hibino -- License     : BSD3 -- -- Maintainer  : ex8k.hibino@gmail.com@@ -35,6 +37,7 @@   unsafeUpdateValuesWithIndexes   ) where +import GHC.Generics (Generic, Rep, U1 (..), K1 (..), M1 (..), (:*:)(..), from) import Data.Array (listArray, (!)) import Data.Set (toList, fromList, (\\)) import Control.Monad.Trans.Writer (Writer, execWriter, tell)@@ -75,12 +78,21 @@                   -> RecordToSql q a -- ^ Result proof object createRecordToSql f =  wrapToSql $ tell . DList.fromList . f --- | Derivation rule of 'RecordToSql' proof object for Haskell tuple (,) type.-(<&>) :: RecordToSql q a -> RecordToSql q b -> RecordToSql q (a, b)-ra <&> rb = RecordToSql $ \(a, b) -> do+-- unsafely map record+mapToSql :: (a -> b) -> RecordToSql q b -> RecordToSql q a+mapToSql f x = wrapToSql $ runRecordToSql x . f++-- unsafely put product record+productToSql :: (c -> (a -> b -> ToSqlM q ()) -> ToSqlM q ())+             -> RecordToSql q a -> RecordToSql q b -> RecordToSql q c+productToSql run ra rb = wrapToSql $ \c -> run c $ \a b -> do   runRecordToSql ra a   runRecordToSql rb b +-- | Derivation rule of 'RecordToSql' proof object for Haskell tuple (,) type.+(<&>) :: RecordToSql q a -> RecordToSql q b -> RecordToSql q (a, b)+(<&>) = productToSql $ flip uncurry+ -- | Derivation rule of 'RecordToSql' proof object for Haskell 'Maybe' type. maybeRecord :: PersistableSqlType q -> PersistableRecordWidth a -> RecordToSql q a -> RecordToSql q (Maybe a) maybeRecord qt w ra =  wrapToSql d  where@@ -91,24 +103,37 @@   -- | Inference rule interface for 'RecordToSql' proof object.-class PersistableWidth a => ToSql q a where+class ToSql q a where   -- | Infer 'RecordToSql' proof object.   recordToSql :: RecordToSql q a --- | Inference rule of 'RecordToSql' proof object which can convert---   from Haskell tuple ('a', 'b') type into list of SQL type ['q'].-instance (ToSql q a, ToSql q b) => ToSql q (a, b) where-  recordToSql = recordToSql <&> recordToSql+  default recordToSql :: (Generic a, GToSql q (Rep a)) => RecordToSql q a+  recordToSql = from `mapToSql` gToSql +class GToSql q f where+  gToSql :: RecordToSql q (f a)++instance GToSql q U1 where+  gToSql = wrapToSql $ \U1 -> tell DList.empty++instance (GToSql q a, GToSql q b) => GToSql q (a :*: b) where+  gToSql = productToSql (\ (a:*:b) f -> f a b) gToSql gToSql++instance GToSql q a => GToSql q (M1 i c a) where+  gToSql = (\(M1 a) -> a) `mapToSql` gToSql++instance ToSql q a => GToSql q (K1 i a) where+  gToSql = (\(K1 a) -> a) `mapToSql` recordToSql++ -- | Inference rule of 'RecordToSql' proof object which can convert --   from Haskell 'Maybe' type into list of SQL type ['q'].-instance (PersistableType q, ToSql q a) => ToSql q (Maybe a)  where+instance (PersistableType q, PersistableWidth a, ToSql q a) => ToSql q (Maybe a)  where   recordToSql = maybeRecord persistableType persistableWidth recordToSql  -- | Inference rule of 'RecordToSql' proof object which can convert --   from Haskell unit () type into /empty/ list of SQL type ['q'].-instance ToSql q () where-  recordToSql = wrapToSql $ \() -> tell DList.empty+instance ToSql q ()  -- default generic instance  -- | Run inferred 'RecordToSql' proof object. --   Context to convert haskell record type 'a' into SQL type 'q' list.

@@ -0,0 +1,13 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}++module Database.Record.TupleInstances () where++import Control.Applicative ((<$>))++import Database.Record.InternalTH (defineTupleInstances)+++$(concat <$> mapM defineTupleInstances [2..7])+-- Generic instances of tuple types are generated from 2 to 7 in GHC.Generics.

@@ -0,0 +1,74 @@+{-# OPTIONS -fno-warn-orphans #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+{-# LANGUAGE DeriveGeneric #-}+module Model where++import GHC.Generics (Generic)++import Database.Record+  (PersistableType (..), PersistableWidth (..),+   FromSql (..), valueRecordFromSql,+   ToSql (..), valueRecordToSql)+import Database.Record.KeyConstraint (HasColumnConstraint (..), NotNull, unsafeSpecifyColumnConstraint)+import Database.Record.Persistable (unsafePersistableSqlTypeFromNull, unsafeValueWidth, )+++instance PersistableType String where+  persistableType = unsafePersistableSqlTypeFromNull "<null>"+++instance PersistableWidth String where+  persistableWidth = unsafeValueWidth++instance PersistableWidth Int where+  persistableWidth = unsafeValueWidth++instance FromSql String String where+  recordFromSql = valueRecordFromSql id++instance FromSql String Int where+  recordFromSql = valueRecordFromSql read++instance ToSql String String where+  recordToSql = valueRecordToSql id++instance ToSql String Int where+  recordToSql = valueRecordToSql show+++data User =+  User+  { uid    ::  Int+  , uname  ::  String+  , note   ::  String+  } deriving (Eq, Show, Generic)++data Group =+  Group+  { gid    ::  Int+  , gname  ::  String+  } deriving (Eq, Show, Generic)++data Membership =+  Membership+  { user   ::  User+  , group  ::  Maybe Group+  } deriving (Eq, Show, Generic)++instance HasColumnConstraint NotNull User where+  columnConstraint = unsafeSpecifyColumnConstraint 0++instance HasColumnConstraint NotNull Group where+  columnConstraint = unsafeSpecifyColumnConstraint 0++instance PersistableWidth User+instance PersistableWidth Group+instance PersistableWidth Membership++instance FromSql String User+instance FromSql String Group+instance FromSql String Membership++instance ToSql String User+instance ToSql String Group+instance ToSql String Membership

@@ -1,74 +1,60 @@ {-# OPTIONS -fno-warn-orphans #-} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} -import Control.Applicative ((<$>), (<*>)) import Test.QuickCheck.Simple (defaultMain, eqTest) -import Database.Record-  (PersistableType (..), PersistableWidth (..),-   FromSql (..), valueRecordFromSql, toRecord,-   ToSql (..), valueRecordToSql)-import Database.Record.Persistable-  (unsafePersistableSqlTypeFromNull, unsafeValueWidth)---instance PersistableType String where-  persistableType = unsafePersistableSqlTypeFromNull "<null>"---instance FromSql String String where-  recordFromSql = valueRecordFromSql id--instance FromSql String Int where-  recordFromSql = valueRecordFromSql read--instance PersistableWidth String where-  persistableWidth = unsafeValueWidth--instance ToSql String String where-  recordToSql = valueRecordToSql id--instance PersistableWidth Int where-  persistableWidth = unsafeValueWidth+import Database.Record (toRecord, fromRecord, persistableWidth, PersistableRecordWidth)+import Database.Record.Persistable (runPersistableRecordWidth) -instance ToSql String Int where-  recordToSql = valueRecordToSql show+import Model (User (..), Group (..), Membership (..))  -data User =-  User-  { uid    ::  Int-  , uname  ::  String-  , note   ::  String-  } deriving (Eq, Show)--data Group =-  Group-  { gid    ::  Int-  , gname  ::  String-  } deriving (Eq, Show)--data Membership =-  Membership-  { user   ::  User-  , group  ::  Group-  } deriving (Eq, Show)--instance FromSql String User where-  recordFromSql = User <$> recordFromSql <*> recordFromSql <*> recordFromSql--instance FromSql String Group where-  recordFromSql = Group <$> recordFromSql <*> recordFromSql--instance FromSql String Membership where-  recordFromSql = Membership <$> recordFromSql <*> recordFromSql- main :: IO () main =   defaultMain   [ eqTest-    "nestedEq"+    "toRecord just"     (Membership { user  = User { uid = 1, uname = "Kei Hibino", note = "HRR developer" }-                , group = Group { gid = 1, gname = "Haskellers" }+                , group = Just $ Group { gid = 1, gname = "Haskellers" }                 } )-    (toRecord ["1", "Kei Hibino", "HRR developer", "1", "Haskellers"]) ]+    (toRecord ["1", "Kei Hibino", "HRR developer", "1", "Haskellers"])+  , eqTest+    "toRecord nothing"+    (Membership { user  = User { uid = 1, uname = "Kei Hibino", note = "HRR developer" }+                , group = Nothing+                } )+    (toRecord ["1", "Kei Hibino", "HRR developer", "<null>", "<null>"])+  , eqTest+    "fromRecord just"+    (fromRecord $ Membership { user  = User { uid = 1, uname = "Kei Hibino", note = "HRR developer" }+                             , group = Just $ Group { gid = 1, gname = "Haskellers" }+                             } )+    ["1", "Kei Hibino", "HRR developer", "1", "Haskellers"]+  , eqTest+    "fromRecord note"+    (fromRecord $ Membership { user  = User { uid = 1, uname = "Kei Hibino", note = "HRR developer" }+                             , group = Nothing+                             } )+    ["1", "Kei Hibino", "HRR developer", "<null>", "<null>"]++  , eqTest+    "toRecord pair"+    (User { uid = 1, uname = "Kei Hibino", note = "HRR developer" },+     Just $ Group { gid = 1, gname = "Haskellers" })+    (toRecord ["1", "Kei Hibino", "HRR developer", "1", "Haskellers"])+  , eqTest+    "fromRecord pair"+    (fromRecord $ (User { uid = 1, uname = "Kei Hibino", note = "HRR developer" },+                   Just $ Group { gid = 1, gname = "Haskellers" }))+    ["1", "Kei Hibino", "HRR developer", "1", "Haskellers"]+  , eqTest+    "width pair"+    (runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth User) ++     runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth Group))+    (runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth (User, Group)))+  , eqTest+    "width record"+    (runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth User) ++     runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth (Maybe Group)))+    (runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth Membership))+  ]