persistable-record-0.5.1.1/0000755000000000000000000000000013134146330013631 5ustar0000000000000000persistable-record-0.5.1.1/ChangeLog.md0000644000000000000000000000133513134146330016004 0ustar0000000000000000 ## 0.5.1.1 - Update this changelog. ## 0.5.1.0 - add class dependency from ToSql to PersistableWidth. ## 0.5.0.2 - add tested-with 8.2.1. ## 0.5.0.1 - Use Haskell implementation test instead of flag test in .cabal ## 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. persistable-record-0.5.1.1/persistable-record.cabal0000644000000000000000000000510513134146330020407 0ustar0000000000000000name: persistable-record version: 0.5.1.1 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. homepage: http://khibino.github.io/haskell-relational-record/ license: BSD3 license-file: LICENSE author: Kei Hibino maintainer: ex8k.hibino@gmail.com copyright: Copyright (c) 2013-2017 Kei Hibino category: Database build-type: Simple cabal-version: >=1.10 tested-with: GHC == 8.2.1 , 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 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 , array , containers , transformers , dlist , names-th if impl(ghc == 7.4.*) build-depends: ghc-prim == 0.2.* hs-source-dirs: src ghc-options: -Wall default-language: Haskell2010 test-suite nested build-depends: base <5 , quickcheck-simple , persistable-record if impl(ghc == 7.4.*) 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 source-repository head type: git location: https://github.com/khibino/haskell-relational-record source-repository head type: mercurial location: https://bitbucket.org/khibino/haskell-relational-record persistable-record-0.5.1.1/LICENSE0000644000000000000000000000275613134146330014650 0ustar0000000000000000Copyright (c) 2013, Kei Hibino All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Kei Hibino nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. persistable-record-0.5.1.1/Setup.hs0000644000000000000000000000005613134146330015266 0ustar0000000000000000import Distribution.Simple main = defaultMain persistable-record-0.5.1.1/src/0000755000000000000000000000000013134146330014420 5ustar0000000000000000persistable-record-0.5.1.1/src/Database/0000755000000000000000000000000013134146330016124 5ustar0000000000000000persistable-record-0.5.1.1/src/Database/Record.hs0000644000000000000000000000535613134146330017707 0ustar0000000000000000-- | -- Module : Database.Record -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This is integrated module which contains -- types to represent table constraints and -- interfaces to bind between SQL database values and Haskell records. module Database.Record ( -- * Concepts -- $concepts -- * Binding between SQL values and Haskell records -- $bindSqlAndHaskellRecords -- * Constraints used for 'RecordFromSql' inference -- $constraintsForInference -- * Modules which provide proof objects -- ** Table constraint specified by keys module Database.Record.KeyConstraint, -- ** Convert between Haskell type and list of SQL type module Database.Record.Persistable, -- ** Convert from list of SQL type module Database.Record.FromSql, -- ** Convert into list of SQL type module Database.Record.ToSql ) where import Database.Record.KeyConstraint (ColumnConstraint, HasColumnConstraint(..), Primary, PrimaryColumnConstraint, Unique, UniqueColumnConstraint, uniqueColumn, derivedUniqueColumnConstraint, NotNull, NotNullColumnConstraint, notNullColumn, derivedNotNullColumnConstraint, KeyConstraint, HasKeyConstraint(..), PrimaryConstraint, UniqueConstraint, deriveComposite, unique, derivedCompositePrimary, derivedUniqueConstraint) import Database.Record.Persistable (PersistableSqlType, PersistableType(..), sqlNullValue, PersistableRecordWidth, PersistableWidth(..), derivedWidth) import Database.Record.FromSql (RecordFromSql, FromSql(..), valueRecordFromSql, runTakeRecord, takeRecord, runToRecord, toRecord) import Database.Record.ToSql (ToSqlM, RecordToSql, ToSql(..), valueRecordToSql, runFromRecord, wrapToSql, putRecord, putEmpty, fromRecord, updateValuesByUnique, updateValuesByPrimary) import Database.Record.TupleInstances () {- $concepts On most drivers for SQL database, we need to write or read untyped SQL value sequence when accessing databases. This library maps between list of untyped SQL type and Haskell record type using type classes. -} {- $bindSqlAndHaskellRecords You will need to implement instances of 'FromSql' and 'ToSql' class to bind between SQL database values and Haskell records. You can use Database.Record.TH module in this package to generate instances from SQL database record column names and types. -} {- $constraintsForInference You will need to implement instances of 'HasColumnConstraint' 'NotNull' which is a premise to infer 'RecordFromSql' proof object using 'ToSql' 'q' ('Maybe' a) instance. This proof object cat convert from SQL type into 'Maybe' typed record when dealing with outer joined query. -} {-# ANN module "HLint: ignore Use import/export shortcut" #-} persistable-record-0.5.1.1/src/Database/Record/0000755000000000000000000000000013134146330017342 5ustar0000000000000000persistable-record-0.5.1.1/src/Database/Record/Persistable.hs0000644000000000000000000001515613134146330022163 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DefaultSignatures #-} -- | -- Module : Database.Record.Persistable -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines proposition interfaces -- for database value type and record type width. module Database.Record.Persistable ( -- * Specify database value type PersistableSqlType, runPersistableNullValue, unsafePersistableSqlTypeFromNull, -- * Specify record width PersistableRecordWidth, runPersistableRecordWidth, unsafePersistableRecordWidth, unsafeValueWidth, (<&>), maybeWidth, -- * Implicit derivation rules, database value type and record type width PersistableType(..), sqlNullValue, 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 -- | Proposition to specify type 'q' is database value type, contains null value newtype PersistableSqlType q = PersistableSqlType q -- | Null value of database value type 'q'. runPersistableNullValue :: PersistableSqlType q -> q runPersistableNullValue (PersistableSqlType q) = q -- | Unsafely specify 'PersistableSqlType' axiom from specified database null value which type is 'q'. unsafePersistableSqlTypeFromNull :: q -- ^ null value of database value type 'q' -> PersistableSqlType q -- ^ Result proof object 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 #-} -- | Proposition to specify width of Haskell type 'a'. -- The width is length of database value list which is converted from Haskell type 'a'. 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 = getSum . getConst . unPC {-# INLINE runPersistableRecordWidth #-} instance Show a => Show (ProductConst a b) where show = ("PC " ++) . show . getConst . unPC -- | Unsafely specify 'PersistableRecordWidth' axiom from specified width of Haskell type 'a'. unsafePersistableRecordWidth :: Int -- ^ Specify width of Haskell type 'a' -> PersistableRecordWidth a -- ^ Result proof object unsafePersistableRecordWidth = ProductConst . Const . Sum {-# INLINE unsafePersistableRecordWidth #-} -- | Unsafely specify 'PersistableRecordWidth' axiom 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 = (,) `pmap` a `pap` b -- | Derivation rule of 'PersistableRecordWidth' from from Haskell type 'a' into for Haskell type 'Maybe' 'a'. maybeWidth :: PersistableRecordWidth a -> PersistableRecordWidth (Maybe a) maybeWidth = pmap Just -- | Interface of derivation rule for 'PersistableSqlType'. class Eq q => PersistableType q where persistableType :: PersistableSqlType q -- | Implicitly derived null value of database value type. sqlNullValue :: PersistableType q => q sqlNullValue = runPersistableNullValue persistableType {- | 'PersistableWidth' 'a' is implicit rule to derive 'PersistableRecordWidth' 'a' width proposition for type 'a'. Generic programming () with default signature is available for 'PersistableWidth' class, so you can make instance like below: @ \{\-\# LANGUAGE DeriveGeneric \#\-\} import GHC.Generics (Generic) -- data Foo = Foo { ... } deriving Generic instance PersistableWidth Foo @ -} class PersistableWidth a where persistableWidth :: PersistableRecordWidth a 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 () -- default generic instance -- | Pass type parameter and inferred width value. derivedWidth :: PersistableWidth a => (PersistableRecordWidth a, Int) derivedWidth = (pw, runPersistableRecordWidth pw) where pw = persistableWidth persistable-record-0.5.1.1/src/Database/Record/KeyConstraint.hs0000644000000000000000000001375013134146330022501 0ustar0000000000000000{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.HDBC.Record.KeyConstraint -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides proof object definitions -- of table constraint specifiey by keys. module Database.Record.KeyConstraint ( -- * Constraint specified by keys ColumnConstraint, index, unsafeSpecifyColumnConstraint, Unique, UniqueColumnConstraint, NotNull, NotNullColumnConstraint, Primary, PrimaryColumnConstraint, KeyConstraint, indexes, unsafeSpecifyKeyConstraint, UniqueConstraint, PrimaryConstraint, -- * Deriviations uniqueColumn, notNullColumn, leftColumnConstraint, unsafeSpecifyNotNullValue, deriveComposite, unique, -- * Inferences HasColumnConstraint (columnConstraint), derivedUniqueColumnConstraint, derivedNotNullColumnConstraint, HasKeyConstraint (keyConstraint), derivedCompositePrimary, derivedUniqueConstraint ) where -- | Proof object to specify table constraint -- for table record type 'r' and constraint 'c' -- specified by a single column. newtype ColumnConstraint c r = ColumnConstraint Int -- | Index of key which specifies table constraint. index :: ColumnConstraint c r -> Int index (ColumnConstraint i) = i -- | Constraint type. Unique key. data Unique -- | Constraint type. Not-null key. data NotNull -- | Constraint type. Primary key. data Primary -- | Specialized unique constraint. type UniqueColumnConstraint = ColumnConstraint Unique -- | Specialized not-null constraint. type NotNullColumnConstraint = ColumnConstraint NotNull -- | Specialized primary constraint. type PrimaryColumnConstraint = ColumnConstraint Primary -- | Unsafely generate 'ColumnConstraint' proof object using specified key index. unsafeSpecifyColumnConstraint :: Int -- ^ Key index which specify this constraint -> ColumnConstraint c r -- ^ Result constraint proof object unsafeSpecifyColumnConstraint = ColumnConstraint -- | Derivation rule for 'UniqueColumnConstraint'. Derive Unique from Primary. uniqueColumn :: PrimaryColumnConstraint r -> UniqueColumnConstraint r uniqueColumn = unsafeSpecifyColumnConstraint . index -- | Derivation rule for 'NotNullColumnConstraint'. Derive NotNull from Primary. notNullColumn :: PrimaryColumnConstraint r -> NotNullColumnConstraint r notNullColumn = unsafeSpecifyColumnConstraint . index -- | Derivation rule of 'ColumnConstraint' 'NotNull' for tuple (,) type. leftColumnConstraint :: ColumnConstraint NotNull a -> ColumnConstraint NotNull (a, b) leftColumnConstraint pa = ColumnConstraint (index pa) -- | Interface of inference rule for 'ColumnConstraint' proof object. class HasColumnConstraint c a where -- | Infer 'ColumnConstraint' proof object. columnConstraint :: ColumnConstraint c a -- | Inference rule of 'ColumnConstraint' 'NotNull' for tuple (,) type. instance HasColumnConstraint NotNull a => HasColumnConstraint NotNull (a, b) where columnConstraint = leftColumnConstraint columnConstraint -- | Inferred 'UniqueColumnConstraint' proof object. -- Record type 'r' has unique key which is derived 'r' has primary key. derivedUniqueColumnConstraint :: HasColumnConstraint Primary r => UniqueColumnConstraint r derivedUniqueColumnConstraint = uniqueColumn columnConstraint -- | Inferred 'NotNullColumnConstraint' proof object. -- Record type 'r' has not-null key which is derived 'r' has primary key. derivedNotNullColumnConstraint :: HasColumnConstraint Primary r => NotNullColumnConstraint r derivedNotNullColumnConstraint = notNullColumn columnConstraint -- | Unsafely generate 'NotNullColumnConstraint' proof object of single column value. unsafeSpecifyNotNullValue :: NotNullColumnConstraint a unsafeSpecifyNotNullValue = unsafeSpecifyColumnConstraint 0 -- | Proof object to specify table constraint -- for table record type 'r' and constraint 'c'. -- Constraint is specified by composite key. newtype KeyConstraint c r = KeyConstraint [Int] -- | Index of key which specifies table constraint. indexes :: KeyConstraint c r -> [Int] indexes (KeyConstraint is) = is -- | Unsafely generate 'KeyConstraint' proof object using specified key indexes. unsafeSpecifyKeyConstraint :: [Int] -- ^ Key index which specify this constraint -> KeyConstraint c r -- ^ Result constraint proof object unsafeSpecifyKeyConstraint = KeyConstraint -- | Derivation rule for 'KeyConstraint'. Derive from 'ColumnConstraint'. deriveComposite :: ColumnConstraint c r -> KeyConstraint c r deriveComposite = unsafeSpecifyKeyConstraint . (:[]) . index -- | Specialized unique constraint. type UniqueConstraint = KeyConstraint Unique -- | Specialized primary constraint. type PrimaryConstraint = KeyConstraint Primary -- | Derivation rule for 'UniqueConstraint'. unique :: PrimaryConstraint r -> UniqueConstraint r unique = unsafeSpecifyKeyConstraint . indexes -- | Interface of inference rule for 'KeyConstraint' proof object. class HasKeyConstraint c a where -- | Infer 'ColumnConstraint' proof object. keyConstraint :: KeyConstraint c a -- | Inferred 'KeyConstraint' proof object. -- Record type 'r' has composite key which is derived 'r' has single column key. derivedCompositeConstraint :: HasColumnConstraint c r => KeyConstraint c r derivedCompositeConstraint = deriveComposite columnConstraint -- | Inferred 'PrimaryConstraint' proof object. -- Record type 'r' has composite primary key which is derived 'r' has single column primary key. derivedCompositePrimary :: HasColumnConstraint Primary r => PrimaryConstraint r derivedCompositePrimary = derivedCompositeConstraint -- | Inferred 'UniqueConstraint' proof object. -- Record type 'r' has unique key which is derived 'r' has primary key. derivedUniqueConstraint :: HasKeyConstraint Primary r => UniqueConstraint r derivedUniqueConstraint = unique keyConstraint persistable-record-0.5.1.1/src/Database/Record/Instances.hs0000644000000000000000000000131613134146330021626 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} -- | -- Module : Database.Record.Instances -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- Single column instances for example to load schema of system catalogs. module Database.Record.Instances () where import Data.Int (Int8, Int16, Int32, Int64) import Database.Record.TH (deriveNotNullType) $(fmap concat $ mapM deriveNotNullType [ [t| Bool |] , [t| Char |] , [t| String |] , [t| Int8 |] , [t| Int16 |] , [t| Int32 |] , [t| Int64 |] ]) persistable-record-0.5.1.1/src/Database/Record/TupleInstances.hs0000644000000000000000000000061713134146330022643 0ustar0000000000000000{-# 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. persistable-record-0.5.1.1/src/Database/Record/TH.hs0000644000000000000000000002634213134146330020220 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.Record.TH -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- 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, defineHasPrimaryKeyInstance, defineHasNotNullKeyInstance, -- * Record type defineRecordType, defineRecordTypeWithConfig, -- * Function declarations against defined record types defineColumnOffsets, recordWidthTemplate, -- * Reify reifyRecordType, -- * Templates about record name NameConfig, defaultNameConfig, recordTypeName, columnName, recordTemplate, columnOffsetsVarNameDefault, -- * Not nullable single column type deriveNotNullType, -- * Template for tuple types defineTupleInstances, ) where import GHC.Generics (Generic) import Data.Array (Array) import Language.Haskell.TH.Name.CamelCase (ConName(conName), VarName(varName), 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 (Q, nameBase, reify, Info(TyConI), Name, TypeQ, conT, Con (NormalC, RecC), Dec, ExpQ, conE, listE, sigE, recC, cxt, varStrictType, strictType, isStrict) import Control.Arrow ((&&&)) import Database.Record (HasColumnConstraint(columnConstraint), Primary, NotNull, HasKeyConstraint(keyConstraint), derivedCompositePrimary, PersistableRecordWidth, PersistableWidth(persistableWidth), FromSql, ToSql, ) import Database.Record.KeyConstraint (unsafeSpecifyColumnConstraint, unsafeSpecifyNotNullValue, unsafeSpecifyKeyConstraint) 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. data NameConfig = NameConfig { recordTypeName :: String -> String -> ConName -- ^ Make record type symbol name from schema name and table name in SQL , columnName :: String -> String -> VarName -- ^ Make column variable symbol name from table name and column name in SQL } -- | Dummy show instance. Handy to define show instance recursively. instance Show NameConfig where show = const "" -- | Default implementation of 'NameConfig' type. -- To customize this, use record update syntax. defaultNameConfig :: NameConfig defaultNameConfig = NameConfig { recordTypeName = const conCamelcaseName , columnName = const varCamelcaseName } -- | 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 -> VarName -- ^ Result expression variable name columnOffsetsVarNameDefault = (`varNameWithPrefix` "columnOffsets") . nameBase -- | Template of 'HasColumnConstraint' instance. defineHasColumnConstraintInstance :: TypeQ -- ^ Type which represent constraint type -> TypeQ -- ^ Type constructor of record -> Int -- ^ Key index which specifies this constraint -> Q [Dec] -- ^ Result declaration template defineHasColumnConstraintInstance constraint typeCon index = [d| instance HasColumnConstraint $constraint $typeCon where columnConstraint = unsafeSpecifyColumnConstraint $(integralE index) |] -- | Template of 'HasKeyConstraint' instance. defineHasPrimaryConstraintInstanceDerived ::TypeQ -- ^ Type constructor of record -> Q [Dec] -- ^ Result declaration template defineHasPrimaryConstraintInstanceDerived typeCon = [d| instance HasKeyConstraint Primary $typeCon where keyConstraint = derivedCompositePrimary |] -- | 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 defineHasPrimaryKeyInstance typeCon = d where d [] = return [] d [ix] = do col <- defineHasColumnConstraintInstance [t| Primary |] typeCon ix comp <- defineHasPrimaryConstraintInstanceDerived typeCon return $ col ++ comp d ixs = [d| instance HasKeyConstraint Primary $typeCon where keyConstraint = unsafeSpecifyKeyConstraint $(listE [integralE ix | ix <- ixs ]) |] -- | 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 defineHasNotNullKeyInstance = defineHasColumnConstraintInstance [t| NotNull |] -- | Record type width expression template. recordWidthTemplate :: TypeQ -- ^ Record type constructor. -> ExpQ -- ^ Expression to get record width. recordWidthTemplate ty = [| runPersistableRecordWidth $(sigE [| persistableWidth |] [t| PersistableRecordWidth $(ty) |]) |] -- | Column offset array and 'PersistableWidth' instance declaration. defineColumnOffsets :: ConName -- ^ Record type constructor. -> [TypeQ] -- ^ Types of record columns. -> Q [Dec] -- ^ Declaration of 'PersistableWidth' instance. defineColumnOffsets typeName' tys = 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 -- | Record type declaration template. defineRecordType :: ConName -- ^ Name of the data type of table record type. -> [(VarName, TypeQ)] -- ^ List of columns in the table. Must be legal, properly cased record columns. -> [Name] -- ^ Deriving type class names. -> Q [Dec] -- ^ The data type record declaration. defineRecordType typeName' columns derives = do let typeName = conName typeName' fld (n, tq) = varStrictType (varName n) (strictType isStrict tq) 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 -- | Record type declaration template with configured names. defineRecordTypeWithConfig :: NameConfig -> String -> String -> [(String, TypeQ)] -> [Name] -> Q [Dec] defineRecordTypeWithConfig config schema table columns = defineRecordType (recordTypeName config schema table) [ (columnName config schema n, t) | (n, t) <- columns ] -- | Default name of record construction function from SQL table name. fromSqlNameDefault :: String -> VarName fromSqlNameDefault = (`varNameWithPrefix` "fromSqlOf") -- | Default name of record decomposition function from SQL table name. toSqlNameDefault :: String -> VarName toSqlNameDefault = (`varNameWithPrefix` "toSqlOf") recordInfo' :: Info -> Maybe ((TypeQ, ExpQ), (Maybe [Name], [TypeQ])) recordInfo' = d where d (TyConI tcon) = do (_cxt, tcn, _bs, _mk, [r], _ds) <- unDataD tcon case r of NormalC dcn ts -> Just ((conT tcn, conE dcn), (Nothing, [return t | (_, t) <- ts])) RecC dcn vts -> Just ((conT tcn, conE dcn), (Just ns, ts)) where (ns, ts) = unzip [(n, return t) | (n, _, t) <- vts] _ -> Nothing d _ = Nothing -- | Low-level reify interface for record type name. reifyRecordType :: Name -> Q ((TypeQ, ExpQ), (Maybe [Name], [TypeQ])) reifyRecordType recTypeName = do tyConInfo <- reify recTypeName maybe (fail $ "Defined record type constructor not found: " ++ show recTypeName) return (recordInfo' tyConInfo) -- | Record parser and printer instance templates for converting -- between list of SQL type and Haskell record type. definePersistableInstance :: TypeQ -- ^ SQL value type. -> TypeQ -- ^ Record type constructor. -> Q [Dec] -- ^ Instance declarations. definePersistableInstance sqlType typeCon = do [d| instance FromSql $sqlType $typeCon instance ToSql $sqlType $typeCon |] -- | All templates for record type. defineRecord :: TypeQ -- ^ SQL value type -> ConName -- ^ Record type name -> [(VarName, TypeQ)] -- ^ Column schema -> [Name] -- ^ Record derivings -> Q [Dec] -- ^ Result declarations defineRecord sqlValueType tyC columns drvs = do typ <- defineRecordType tyC columns drvs withSql <- definePersistableInstance sqlValueType $ toTypeCon tyC return $ typ ++ withSql -- | All templates for record type with configured names. defineRecordWithConfig :: TypeQ -- ^ SQL value type -> NameConfig -- ^ name rule config -> String -- ^ Schema name -> String -- ^ Table name -> [(String, TypeQ)] -- ^ Column names and types -> [Name] -- ^ Record derivings -> Q [Dec] -- ^ Result declarations defineRecordWithConfig sqlValueType config schema table columns derives = do typ <- defineRecordTypeWithConfig config schema table columns derives withSql <- definePersistableInstance sqlValueType . fst $ recordTemplate config schema table return $ typ ++ withSql -- | Templates for single column value type. deriveNotNullType :: TypeQ -> Q [Dec] deriveNotNullType typeCon = [d| instance PersistableWidth $typeCon where persistableWidth = Persistable.unsafeValueWidth instance HasColumnConstraint NotNull $typeCon where columnConstraint = unsafeSpecifyNotNullValue |] persistable-record-0.5.1.1/src/Database/Record/InternalTH.hs0000644000000000000000000000247413134146330021715 0ustar0000000000000000{-# 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 ] persistable-record-0.5.1.1/src/Database/Record/ToSql.hs0000644000000000000000000002232213134146330020741 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DefaultSignatures #-} -- | -- Module : Database.Record.ToSql -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines interfaces -- 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, createRecordToSql, (<&>), -- * Derivation rules of 'RecordToSql' conversion ToSql (recordToSql), putRecord, putEmpty, fromRecord, wrapToSql, valueRecordToSql, -- * Make parameter list for updating with key updateValuesByUnique, updateValuesByPrimary, updateValuesByUnique', untypedUpdateValuesIndex, 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) import Data.DList (DList) import qualified Data.DList as DList import Database.Record.Persistable (PersistableSqlType, runPersistableNullValue, PersistableType (persistableType), PersistableRecordWidth, runPersistableRecordWidth, PersistableWidth(persistableWidth)) import Database.Record.KeyConstraint (Primary, Unique, KeyConstraint, HasKeyConstraint(keyConstraint), unique, indexes) -- | 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 {- | 'RecordToSql' 'q' 'a' is data-type wrapping function to convert from Haskell type 'a' into list of database value type (to send to database) ['q']. This structure is similar to printer. While running 'RecordToSql' behavior is the same as list printer. which appends list of database value type ['q'] stream. -} newtype RecordToSql q a = RecordToSql (a -> ToSqlM q ()) runRecordToSql :: RecordToSql q a -> a -> ToSqlM q () runRecordToSql (RecordToSql f) = f -- | Finalize 'RecordToSql' record printer. wrapToSql :: (a -> ToSqlM q ()) -> RecordToSql q a wrapToSql = RecordToSql -- | Run 'RecordToSql' printer function object. Convert from Haskell type 'a' into list of database value type ['q']. 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 -- | Axiom of 'RecordToSql' for database value type 'q' and Haksell type 'a'. createRecordToSql :: (a -> [q]) -- ^ Convert function body -> RecordToSql q a -- ^ Result printer function object createRecordToSql f = wrapToSql $ tell . DList.fromList . f -- 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' printer function object for Haskell tuple (,) type. (<&>) :: RecordToSql q a -> RecordToSql q b -> RecordToSql q (a, b) (<&>) = productToSql $ flip uncurry -- | Derivation rule of 'RecordToSql' printer function object for Haskell 'Maybe' type. maybeRecord :: PersistableSqlType q -> PersistableRecordWidth a -> RecordToSql q a -> RecordToSql q (Maybe a) maybeRecord qt w ra = wrapToSql d where d (Just r) = runRecordToSql ra r d Nothing = tell $ DList.replicate (runPersistableRecordWidth w) (runPersistableNullValue qt) infixl 4 <&> {- | 'ToSql' 'q' 'a' is implicit rule to derive 'RecordToSql' 'q' 'a' record printer function for type 'a'. Generic programming () with default signature is available for 'ToSql' class, so you can make instance like below: @ \{\-\# LANGUAGE DeriveGeneric \#\-\} import GHC.Generics (Generic) import Database.HDBC (SqlValue) -- data Foo = Foo { ... } deriving Generic instance ToSql SqlValue Foo @ To make instances of 'ToSql' manually, 'ToSql' 'q' 'a' and 'RecordToSql' 'q 'a' are composable with monadic context. When, you have data constructor and objects like below. @ data MyRecord = MyRecord Foo Bar Baz @ @ instance ToSql SqlValue Foo where ... instance ToSql SqlValue Bar where ... instance ToSql SqlValue Baz where ... @ You can get composed 'ToSql' implicit rule like below. @ instance ToSql SqlValue MyRecord where recordToSql = recordToSql = wrapToSql $ \\ (MyRecord x y z) -> do putRecord x putRecord y putRecord z @ -} class PersistableWidth a => ToSql q a where -- | Derived 'RecordToSql' printer function object. recordToSql :: RecordToSql q a 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 -- | Implicit derivation rule of 'RecordToSql' printer function object which can convert -- from Haskell 'Maybe' type into list of database value type ['q']. instance (PersistableType q, ToSql q a) => ToSql q (Maybe a) where recordToSql = maybeRecord persistableType persistableWidth recordToSql -- | Implicit derivation rule of 'RecordToSql' printer function object which can convert -- from Haskell unit () type into /empty/ list of database value type ['q']. instance ToSql q () -- default generic instance -- | Run implicit 'RecordToSql' printer function object. -- Context to convert haskell record type 'a' into lib of database value type ['q']. putRecord :: ToSql q a => a -> ToSqlM q () putRecord = runRecordToSql recordToSql -- | Run 'RecordToSql' empty printer. putEmpty :: () -> ToSqlM q () putEmpty = putRecord -- | Run implicit 'RecordToSql' printer function object. -- Convert from haskell type 'a' into list of database value type ['q']. fromRecord :: ToSql q a => a -> [q] fromRecord = runToSqlM . putRecord -- | Derivation rule of 'RecordToSql' printer function object for value convert function. valueRecordToSql :: (a -> q) -> RecordToSql q a valueRecordToSql = createRecordToSql . ((:[]) .) -- | Make untyped indexes to update column from key indexes and record width. -- Expected by update form like -- -- @ -- UPDATE /table/ SET /c0/ = ?, /c1/ = ?, /c2/ = ? ... WHERE /key0/ = ? AND /key1/ = ? AND key2 = ? ... -- @ untypedUpdateValuesIndex :: [Int] -- ^ Key indexes -> Int -- ^ Record width -> [Int] -- ^ Indexes to update other than key untypedUpdateValuesIndex key width = otherThanKey where maxIx = width - 1 otherThanKey = toList $ fromList [0 .. maxIx] \\ fromList key -- | Unsafely specify key indexes to convert from Haskell type `ra` -- into database value `q` list expected by update form like -- -- @ -- UPDATE /table/ SET /c0/ = ?, /c1/ = ?, /c2/ = ? ... WHERE /key0/ = ? AND /key1/ = ? AND /key2/ = ? ... -- @ -- -- using 'RecordToSql' printer function object. unsafeUpdateValuesWithIndexes :: RecordToSql q ra -> [Int] -> ra -> [q] unsafeUpdateValuesWithIndexes pr key a = [ valsA ! i | i <- otherThanKey ++ key ] where vals = runFromRecord pr a width = length vals valsA = listArray (0, width - 1) vals otherThanKey = untypedUpdateValuesIndex key width -- | Convert from Haskell type `ra` into database value `q` list expected by update form like -- -- @ -- 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. updateValuesByUnique :: ToSql q ra => KeyConstraint Unique ra -- ^ Unique key table constraint printer function object. -> ra -> [q] updateValuesByUnique = updateValuesByUnique' recordToSql -- | Convert like 'updateValuesByUnique'' using implicit 'RecordToSql' and 'ColumnConstraint'. updateValuesByPrimary :: (HasKeyConstraint Primary ra, ToSql q ra) => ra -> [q] updateValuesByPrimary = updateValuesByUnique (unique keyConstraint) persistable-record-0.5.1.1/src/Database/Record/FromSql.hs0000644000000000000000000001513513134146330021266 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DefaultSignatures #-} -- | -- Module : Database.Record.FromSql -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines interfaces -- from list of database value type into Haskell type. module Database.Record.FromSql ( -- * Conversion from list of database value type into record type RecordFromSql, runTakeRecord, runToRecord, createRecordFromSql, (<&>), maybeRecord, -- * Derivation rules of 'RecordFromSql' conversion FromSql (recordFromSql), takeRecord, toRecord, 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) {- | 'RecordFromSql' 'q' 'a' is data-type wrapping function to convert from list of database value type (to receive from database) ['q'] into Haskell type 'a' This structure is similar to parser. While running 'RecordFromSql' behavior is the same as non-fail-able parser which parse list of database value type ['q'] stream. So, 'RecordFromSql' 'q' is 'Monad' and 'Applicative' instance like parser monad. When, you have data constructor and objects like below. @ data MyRecord = MyRecord Foo Bar Baz @ @ foo :: 'RecordFromSql' SqlValue Foo foo = ... bar :: 'RecordFromSql' SqlValue Bar bar = ... baz :: 'RecordFromSql' SqlValue Bar baz = ... @ You can get composed 'RecordFromSql' like below. @ myRecord :: RecordFromSql SqlValue MyRecord myRecord = MyRecord \<$\> foo \<*\> bar \<*\> baz @ -} newtype RecordFromSql q a = RecordFromSql ([q] -> (a, [q])) -- | Run 'RecordFromSql' parser function object. -- Convert from list of database value type ['q'] into Haskell type 'a' and rest of list ['q']. runTakeRecord :: RecordFromSql q a -- ^ parser function object which has capability to convert -> [q] -- ^ list of database value type -> (a, [q]) -- ^ Haskell type and rest of list runTakeRecord (RecordFromSql f) = f -- | Axiom of 'RecordFromSql' for database value type 'q' and Haskell type 'a' createRecordFromSql :: ([q] -> (a, [q])) -- ^ Convert function body -> RecordFromSql q a -- ^ Result parser function object createRecordFromSql = RecordFromSql -- | Run 'RecordFromSql' parser function object. Convert from list of database value type ['q'] into Haskell type 'a'. runToRecord :: RecordFromSql q a -- ^ parser function object which has capability to convert -> [q] -- ^ list of database value type -> a -- ^ Haskell type runToRecord r = fst . runTakeRecord r -- | 'Monad' instance like parser 'Monad'. instance Monad (RecordFromSql q) where return a = createRecordFromSql ((,) a) ma >>= fmb = createRecordFromSql (\vals -> let (a, vals') = runTakeRecord ma vals in runTakeRecord (fmb a) vals') -- | Derived 'Functor' instance from 'Monad' instance instance Functor (RecordFromSql q) where fmap = liftM -- | Derived 'Applicative' instance from 'Monad' instance instance Applicative (RecordFromSql q) where pure = return (<*>) = ap -- | Derivation rule of 'RecordFromSql' parser function object for Haskell tuple (,) type. (<&>) :: RecordFromSql q a -> RecordFromSql q b -> RecordFromSql q (a, b) a <&> b = (,) <$> a <*> b infixl 4 <&> -- | Derivation rule of 'RecordFromSql' parser function object for Haskell 'Maybe' type. maybeRecord :: PersistableType q => RecordFromSql q a -> ColumnConstraint NotNull a -> RecordFromSql q (Maybe a) maybeRecord rec pkey = createRecordFromSql mayToRec where mayToRec vals | vals !! index pkey /= Persistable.sqlNullValue = (Just a, vals') | otherwise = (Nothing, vals') where (a, vals') = runTakeRecord rec vals {- | 'FromSql' 'q' 'a' is implicit rule to derive 'RecordFromSql' 'q' 'a' record parser function against type 'a'. Generic programming () with default signature is available for 'FromSql' class, so you can make instance like below: @ \{\-\# LANGUAGE DeriveGeneric \#\-\} import GHC.Generics (Generic) import Database.HDBC (SqlValue) -- data Foo = Foo { ... } deriving Generic instance FromSql SqlValue Foo @ -} class FromSql q a where -- | 'RecordFromSql' 'q' 'a' record parser function. recordFromSql :: RecordFromSql q a 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 -- | Implicit derivation rule of 'RecordFromSql' parser function object which can convert -- from list of database value type ['q'] into Haskell 'Maybe' type. instance (HasColumnConstraint NotNull a, FromSql q a, PersistableType q) => FromSql q (Maybe a) where recordFromSql = maybeRecord recordFromSql columnConstraint -- | Implicit derivation rule of 'RecordFromSql' parser function object which can convert -- from /empty/ list of database value type ['q'] into Haskell unit () type. instance FromSql q () -- default generic instance -- | Run implicit 'RecordFromSql' parser function object. -- Convert from list of database value type ['q'] into haskell type 'a' and rest of list ['q']. takeRecord :: FromSql q a => [q] -> (a, [q]) takeRecord = runTakeRecord recordFromSql -- | Run implicit 'RecordFromSql' parser function object. -- Convert from list of database value type ['q'] into haskell type 'a'. toRecord :: FromSql q a => [q] -> a toRecord = runToRecord recordFromSql -- | Derivation rule of 'RecordFromSql' parser function object for value convert function. valueRecordFromSql :: (q -> a) -> RecordFromSql q a valueRecordFromSql d = createRecordFromSql $ \qs -> (d $ head qs, tail qs) persistable-record-0.5.1.1/test/0000755000000000000000000000000013134146330014610 5ustar0000000000000000persistable-record-0.5.1.1/test/nestedEq.hs0000644000000000000000000000500213134146330016711 0ustar0000000000000000{-# OPTIONS -fno-warn-orphans #-} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} import Test.QuickCheck.Simple (defaultMain, eqTest) import Database.Record (toRecord, fromRecord, persistableWidth, PersistableRecordWidth) import Database.Record.Persistable (runPersistableRecordWidth) import Model (User (..), Group (..), Membership (..)) main :: IO () main = defaultMain [ eqTest "toRecord just" (Membership { user = User { uid = 1, uname = "Kei Hibino", note = "HRR developer" } , group = Just $ Group { gid = 1, gname = "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", "", ""]) , 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", "", ""] , 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)) ] persistable-record-0.5.1.1/test/Model.hs0000644000000000000000000000352613134146330016212 0ustar0000000000000000{-# 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 "" 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