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 - [email protected]
+
+- 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 : [email protected]
@@ -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.html#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
+@
--- | 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 : [email protected]
-- 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.html#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
--- | 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 : [email protected]
@@ -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 : [email protected]
@@ -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.html#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
--- | 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))
+ ]
