Hello community, here is the log from the commit of package ghc-persistable-record for openSUSE:Factory checked in at 2017-08-31 20:57:47 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-persistable-record (Old) and /work/SRC/openSUSE:Factory/.ghc-persistable-record.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-persistable-record" Thu Aug 31 20:57:47 2017 rev:4 rq:513447 version:0.5.1.1 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-persistable-record/ghc-persistable-record.changes 2017-03-14 10:05:44.223258660 +0100 +++ /work/SRC/openSUSE:Factory/.ghc-persistable-record.new/ghc-persistable-record.changes 2017-08-31 20:57:48.344101199 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:08:05 UTC 2017 - psimons@suse.com + +- Update to version 0.5.1.1. + +------------------------------------------------------------------- Old: ---- persistable-record-0.4.1.1.tar.gz New: ---- persistable-record-0.5.1.1.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-persistable-record.spec ++++++ --- /var/tmp/diff_new_pack.Adt3jq/_old 2017-08-31 20:57:49.243974763 +0200 +++ /var/tmp/diff_new_pack.Adt3jq/_new 2017-08-31 20:57:49.247974202 +0200 @@ -19,7 +19,7 @@ %global pkg_name persistable-record %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.4.1.1 +Version: 0.5.1.1 Release: 0 Summary: Binding between SQL database values and haskell records License: BSD-3-Clause @@ -80,5 +80,6 @@ %files devel -f %{name}-devel.files %defattr(-,root,root,-) +%doc ChangeLog.md %changelog ++++++ persistable-record-0.4.1.1.tar.gz -> persistable-record-0.5.1.1.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistable-record-0.4.1.1/ChangeLog.md new/persistable-record-0.5.1.1/ChangeLog.md --- old/persistable-record-0.4.1.1/ChangeLog.md 1970-01-01 01:00:00.000000000 +0100 +++ new/persistable-record-0.5.1.1/ChangeLog.md 2017-07-20 17:31:36.000000000 +0200 @@ -0,0 +1,54 @@ +<!-- -*- Markdown -*- --> + +## 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. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistable-record-0.4.1.1/persistable-record.cabal new/persistable-record-0.5.1.1/persistable-record.cabal --- old/persistable-record-0.4.1.1/persistable-record.cabal 2017-02-19 08:43:07.000000000 +0100 +++ new/persistable-record-0.5.1.1/persistable-record.cabal 2017-07-20 17:31:36.000000000 +0200 @@ -1,5 +1,5 @@ name: persistable-record -version: 0.4.1.1 +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. @@ -12,22 +12,28 @@ category: Database build-type: Simple cabal-version: >=1.10 -tested-with: GHC == 8.0.1, GHC == 8.0.2 +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 @@ -36,6 +42,9 @@ , 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 @@ -44,9 +53,12 @@ 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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistable-record-0.4.1.1/src/Database/Record/FromSql.hs new/persistable-record-0.5.1.1/src/Database/Record/FromSql.hs --- old/persistable-record-0.4.1.1/src/Database/Record/FromSql.hs 2017-02-19 08:43:07.000000000 +0100 +++ new/persistable-record-0.5.1.1/src/Database/Record/FromSql.hs 2017-07-20 17:31:36.000000000 +0200 @@ -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 @@ -12,35 +14,39 @@ -- Portability : unknown -- -- This module defines interfaces --- from list of SQL type into Haskell type. +-- from list of database value type into Haskell type. + module Database.Record.FromSql ( - -- * Conversion from list of SQL type into record type - -- $recordFromSql + -- * Conversion from list of database value type into record type RecordFromSql, runTakeRecord, runToRecord, createRecordFromSql, (<&>), maybeRecord, - -- * Inference rules of 'RecordFromSql' conversion + -- * 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) -import Control.Monad (liftM, ap) -import Control.Applicative ((<$>), Applicative(pure, (<*>))) - -{- $recordFromSql -Structure of 'RecordFromSql' 'q' 'a' is similar to parser. -While running 'RecordFromSql' behavior is the same as parser -which parse list of SQL type ['q'] stream. +{- | +'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. @@ -65,25 +71,23 @@ myRecord = MyRecord \<$\> foo \<*\> bar \<*\> baz @ -} - --- | Proof object type to convert from sql value type 'q' list into Haskell type 'a'. newtype RecordFromSql q a = RecordFromSql ([q] -> (a, [q])) --- | Run 'RecordFromSql' proof object. --- Convert from list of SQL type ['q'] into Haskell type 'a' and rest of list ['q']. -runTakeRecord :: RecordFromSql q a -- ^ Proof object which has capability to convert - -> [q] -- ^ list of SQL type +-- | 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 SQL type 'q' and Haskell type 'a' +-- | Axiom of 'RecordFromSql' for database value type 'q' and Haskell type 'a' createRecordFromSql :: ([q] -> (a, [q])) -- ^ Convert function body - -> RecordFromSql q a -- ^ Result proof object + -> RecordFromSql q a -- ^ Result parser function object createRecordFromSql = RecordFromSql --- | Run 'RecordFromSql' proof object. Convert from list of SQL type ['q'] into Haskell type 'a'. -runToRecord :: RecordFromSql q a -- ^ Proof object which has capability to convert - -> [q] -- ^ list of SQL type +-- | 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 @@ -104,14 +108,14 @@ pure = return (<*>) = ap --- | Derivation rule of 'RecordFromSql' proof object for Haskell tuple (,) type. +-- | 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' proof object for Haskell 'Maybe' type. +-- | Derivation rule of 'RecordFromSql' parser function object for Haskell 'Maybe' type. maybeRecord :: PersistableType q => RecordFromSql q a -> ColumnConstraint NotNull a @@ -122,38 +126,67 @@ | 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 (https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts...) +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 +@ --- | Inference rule interface for 'RecordFromSql' proof object. +-} class FromSql q a where - -- | 'RecordFromSql' proof object. + -- | 'RecordFromSql' 'q' 'a' record parser function. 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. +-- | 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 --- | 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)) +-- | 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 inferred 'RecordFromSql' proof object. --- Convert from list of SQL type ['q'] into haskell type 'a' and rest of list ['q']. +-- | 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 inferred 'RecordFromSql' proof object. --- Convert from list of SQL type ['q'] into haskell type 'a'. +-- | 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' proof object for value convert function. +-- | 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) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistable-record-0.4.1.1/src/Database/Record/InternalTH.hs new/persistable-record-0.5.1.1/src/Database/Record/InternalTH.hs --- old/persistable-record-0.4.1.1/src/Database/Record/InternalTH.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/persistable-record-0.5.1.1/src/Database/Record/InternalTH.hs 2017-07-20 17:31:36.000000000 +0200 @@ -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 ] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistable-record-0.4.1.1/src/Database/Record/Persistable.hs new/persistable-record-0.5.1.1/src/Database/Record/Persistable.hs --- old/persistable-record-0.4.1.1/src/Database/Record/Persistable.hs 2017-02-19 08:43:07.000000000 +0100 +++ new/persistable-record-0.5.1.1/src/Database/Record/Persistable.hs 2017-07-20 17:31:36.000000000 +0200 @@ -1,100 +1,176 @@ +{-# 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 -- Stability : experimental -- Portability : unknown -- --- This module defines interfaces --- between Haskell type and list of SQL type. +-- This module defines proposition interfaces +-- for database value type and record type width. module Database.Record.Persistable ( - -- * Specify SQL type + -- * Specify database value type PersistableSqlType, runPersistableNullValue, unsafePersistableSqlTypeFromNull, -- * Specify record width PersistableRecordWidth, runPersistableRecordWidth, unsafePersistableRecordWidth, unsafeValueWidth, (<&>), maybeWidth, - -- * Inference rules for proof objects - + -- * Implicit derivation rules, database value type and record type width 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 +-- | Proposition to specify type 'q' is database value type, contains null value newtype PersistableSqlType q = PersistableSqlType q --- | Null value of SQL type 'q'. +-- | Null value of database value type 'q'. runPersistableNullValue :: PersistableSqlType q -> q runPersistableNullValue (PersistableSqlType q) = q --- | Unsafely generate 'PersistableSqlType' proof object from specified SQL null value which type is 'q'. -unsafePersistableSqlTypeFromNull :: q -- ^ SQL null value of SQL type '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 --- | Proof object to specify width of Haskell type 'a' --- when converting to SQL type list. -newtype PersistableRecordWidth a = - PersistableRecordWidth Int +-- | 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 (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'. +-- | 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 = PersistableRecordWidth +unsafePersistableRecordWidth = ProductConst . Const . Sum +{-# INLINE unsafePersistableRecordWidth #-} --- | Unsafely generate 'PersistableRecordWidth' proof object for Haskell type 'a' which is single column type. +-- | 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 = 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 +maybeWidth = pmap Just --- | Axiom of 'PersistableRecordWidth' for Haskell unit () type. -voidWidth :: PersistableRecordWidth () -voidWidth = unsafePersistableRecordWidth 0 - --- | Interface of inference rule for 'PersistableSqlType' proof object +-- | Interface of derivation rule for 'PersistableSqlType'. class Eq q => PersistableType q where persistableType :: PersistableSqlType q --- | Inferred Null value of SQL type. +-- | Implicitly derived null value of database value type. sqlNullValue :: PersistableType q => q sqlNullValue = runPersistableNullValue persistableType --- | Interface of inference rule for 'PersistableRecordWidth' proof object +{- | +'PersistableWidth' 'a' is implicit rule to derive 'PersistableRecordWidth' 'a' width proposition for type 'a'. + +Generic programming (https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts...) +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 --- | 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) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistable-record-0.4.1.1/src/Database/Record/TH.hs new/persistable-record-0.5.1.1/src/Database/Record/TH.hs --- old/persistable-record-0.4.1.1/src/Database/Record/TH.hs 2017-02-19 08:43:07.000000000 +0100 +++ new/persistable-record-0.5.1.1/src/Database/Record/TH.hs 2017-07-20 17:31:36.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistable-record-0.4.1.1/src/Database/Record/ToSql.hs new/persistable-record-0.5.1.1/src/Database/Record/ToSql.hs --- old/persistable-record-0.4.1.1/src/Database/Record/ToSql.hs 2017-02-19 08:43:07.000000000 +0100 +++ new/persistable-record-0.5.1.1/src/Database/Record/ToSql.hs 2017-07-20 17:31:36.000000000 +0200 @@ -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 @@ -12,29 +14,30 @@ -- Portability : unknown -- -- This module defines interfaces --- from Haskell type into list of SQL type. +-- from Haskell type into list of database value type. module Database.Record.ToSql ( - -- * Conversion from record type into list of SQL type + -- * Conversion from record type into list of database value type ToSqlM, RecordToSql, runFromRecord, createRecordToSql, (<&>), - -- * Inference rules of 'RecordToSql' conversion + -- * Derivation rules of 'RecordToSql' conversion ToSql (recordToSql), putRecord, putEmpty, fromRecord, wrapToSql, valueRecordToSql, -- * Make parameter list for updating with key - updateValuesByUnique', 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) @@ -48,13 +51,20 @@ (Primary, Unique, KeyConstraint, HasKeyConstraint(keyConstraint), unique, indexes) --- | Context type to convert SQL type list. +-- | 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 --- | Proof object type to convert from Haskell type 'a' into list of SQL type ['q']. +{- | +'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 () @@ -64,24 +74,33 @@ wrapToSql :: (a -> ToSqlM q ()) -> RecordToSql q a wrapToSql = RecordToSql --- | Run 'RecordToSql' proof object. Convert from Haskell type 'a' into list of SQL type ['q']. -runFromRecord :: RecordToSql q a -- ^ Proof object which has capability to convert +-- | 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 SQL type + -> [q] -- ^ list of database value runFromRecord r = runToSqlM . runRecordToSql r --- | Axiom of 'RecordToSql' for SQL type 'q' and Haksell type 'a'. +-- | Axiom of 'RecordToSql' for database value type 'q' and Haksell type 'a'. createRecordToSql :: (a -> [q]) -- ^ Convert function body - -> RecordToSql q a -- ^ Result proof object + -> RecordToSql q a -- ^ Result printer function 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 'Maybe' type. +-- | 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 @@ -89,29 +108,85 @@ infixl 4 <&> +{- | +'ToSql' 'q' 'a' is implicit rule to derive 'RecordToSql' 'q' 'a' record printer function for type 'a'. --- | Inference rule interface for 'RecordToSql' proof object. -class ToSql q a where - -- | Infer 'RecordToSql' proof object. +Generic programming (https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts...) +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 --- | 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 - --- | Inference rule of 'RecordToSql' proof object which can convert --- from Haskell 'Maybe' type into list of SQL type ['q']. -instance (PersistableType q, PersistableWidth a, ToSql q a) => ToSql q (Maybe a) where + 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 --- | 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 +-- | 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 inferred 'RecordToSql' proof object. --- Context to convert haskell record type 'a' into SQL type 'q' list. +-- | 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 @@ -119,19 +194,21 @@ putEmpty :: () -> ToSqlM q () putEmpty = putRecord --- | Run inferred 'RecordToSql' proof object. --- Convert from haskell type 'a' into list of SQL type ['q']. +-- | 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' proof object for value convert function. +-- | 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 = ?, ..., cn = ? WHERE key0 = ? AND key1 = ? AND key2 = ? ... / +-- @ +-- 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 @@ -140,11 +217,13 @@ otherThanKey = toList $ fromList [0 .. maxIx] \\ fromList key -- | Unsafely specify key indexes to convert from Haskell type `ra` --- into SQL value `q` list expected by update form like +-- into database value `q` list expected by update form like -- --- /UPDATE <table> SET c0 = ?, c1 = ?, ..., cn = ? WHERE key0 = ? AND key1 = ? AND key2 = ? ... / +-- @ +-- UPDATE /table/ SET /c0/ = ?, /c1/ = ?, /c2/ = ? ... WHERE /key0/ = ? AND /key1/ = ? AND /key2/ = ? ... +-- @ -- --- using 'RecordToSql' proof object. +-- using 'RecordToSql' printer function object. unsafeUpdateValuesWithIndexes :: RecordToSql q ra -> [Int] -> ra @@ -156,25 +235,27 @@ valsA = listArray (0, width - 1) vals otherThanKey = untypedUpdateValuesIndex key width --- | Convert from Haskell type `ra` into SQL value `q` list expected by update form like +-- | Convert from Haskell type `ra` into database value `q` list expected by update form like -- --- /UPDATE <table> SET c0 = ?, c1 = ?, ..., cn = ? WHERE key0 = ? AND key1 = ? AND key2 = ? ... / +-- @ +-- UPDATE /table/ SET /c0/ = ?, /c1/ = ?, /c2/ = ? ... WHERE /key0/ = ? AND /key1/ = ? AND /key2/ = ? ... +-- @ -- --- using 'RecordToSql' proof object. +-- using 'RecordToSql' printer function object. updateValuesByUnique' :: RecordToSql q ra - -> KeyConstraint Unique ra -- ^ Unique key table constraint proof object. + -> KeyConstraint Unique ra -- ^ Unique key table constraint printer function object. -> ra -> [q] updateValuesByUnique' pr uk = unsafeUpdateValuesWithIndexes pr (indexes uk) --- | Convert like 'updateValuesByUnique'' using inferred 'RecordToSql' proof object. +-- | Convert like 'updateValuesByUnique'' using implicit 'RecordToSql' printer function object. updateValuesByUnique :: ToSql q ra - => KeyConstraint Unique ra -- ^ Unique key table constraint proof object. + => KeyConstraint Unique ra -- ^ Unique key table constraint printer function object. -> ra -> [q] updateValuesByUnique = updateValuesByUnique' recordToSql --- | Convert like 'updateValuesByUnique'' using inferred 'RecordToSql' and 'ColumnConstraint' proof objects. +-- | Convert like 'updateValuesByUnique'' using implicit 'RecordToSql' and 'ColumnConstraint'. updateValuesByPrimary :: (HasKeyConstraint Primary ra, ToSql q ra) => ra -> [q] updateValuesByPrimary = updateValuesByUnique (unique keyConstraint) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistable-record-0.4.1.1/src/Database/Record/TupleInstances.hs new/persistable-record-0.5.1.1/src/Database/Record/TupleInstances.hs --- old/persistable-record-0.4.1.1/src/Database/Record/TupleInstances.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/persistable-record-0.5.1.1/src/Database/Record/TupleInstances.hs 2017-07-20 17:31:36.000000000 +0200 @@ -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. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistable-record-0.4.1.1/src/Database/Record.hs new/persistable-record-0.5.1.1/src/Database/Record.hs --- old/persistable-record-0.4.1.1/src/Database/Record.hs 2017-02-19 08:43:07.000000000 +0100 +++ new/persistable-record-0.5.1.1/src/Database/Record.hs 2017-07-20 17:31:36.000000000 +0200 @@ -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, diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistable-record-0.4.1.1/test/Model.hs new/persistable-record-0.5.1.1/test/Model.hs --- old/persistable-record-0.4.1.1/test/Model.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/persistable-record-0.5.1.1/test/Model.hs 2017-07-20 17:31:36.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistable-record-0.4.1.1/test/nestedEq.hs new/persistable-record-0.5.1.1/test/nestedEq.hs --- old/persistable-record-0.4.1.1/test/nestedEq.hs 2017-02-19 08:43:07.000000000 +0100 +++ new/persistable-record-0.5.1.1/test/nestedEq.hs 2017-07-20 17:31:36.000000000 +0200 @@ -1,67 +1,60 @@ {-# OPTIONS -fno-warn-orphans #-} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} -import Control.Applicative ((<$>), (<*>)) import Test.QuickCheck.Simple (defaultMain, eqTest) -import Database.Record - (PersistableType (..), - FromSql (..), valueRecordFromSql, toRecord, - ToSql (..), valueRecordToSql) -import Database.Record.Persistable (unsafePersistableSqlTypeFromNull) +import Database.Record (toRecord, fromRecord, persistableWidth, PersistableRecordWidth) +import Database.Record.Persistable (runPersistableRecordWidth) +import Model (User (..), Group (..), Membership (..)) -instance PersistableType String where - persistableType = unsafePersistableSqlTypeFromNull "<null>" - - -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) - -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 = 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 = Group { gid = 1, gname = "Haskellers" } + , group = Nothing } ) - (toRecord ["1", "Kei Hibino", "HRR developer", "1", "Haskellers"]) ] + (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)) + ]