summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorKeiHibino <>2017-07-17 04:06:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-07-17 04:06:00 (GMT)
commitd0c6659074d5556f4abd26c3e92a15701460ac82 (patch)
tree6a40985fbf4f29a3c5828c200a1fe590c1952a87
parent25d2bff40eff4a6d37d3203c75b73fc1c312d4e3 (diff)
version 0.4.1.20.4.1.2
-rw-r--r--ChangeLog.md42
-rw-r--r--persistable-record.cabal16
-rw-r--r--src/Database/Record.hs1
-rw-r--r--src/Database/Record/FromSql.hs36
-rw-r--r--src/Database/Record/InternalTH.hs45
-rw-r--r--src/Database/Record/Persistable.hs97
-rw-r--r--src/Database/Record/TH.hs242
-rw-r--r--src/Database/Record/ToSql.hs45
-rw-r--r--src/Database/Record/TupleInstances.hs13
-rw-r--r--test/Model.hs74
-rw-r--r--test/nestedEq.hs99
11 files changed, 285 insertions, 425 deletions
diff --git a/ChangeLog.md b/ChangeLog.md
deleted file mode 100644
index 8f52395..0000000
--- a/ChangeLog.md
+++ /dev/null
@@ -1,42 +0,0 @@
-<!-- -*- Markdown -*- -->
-
-## 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 --git a/persistable-record.cabal b/persistable-record.cabal
index 1d7489c..661c84f 100644
--- a/persistable-record.cabal
+++ b/persistable-record.cabal
@@ -1,5 +1,5 @@
name: persistable-record
-version: 0.5.0.1
+version: 0.4.1.2
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,27 +12,23 @@ copyright: Copyright (c) 2013-2017 Kei Hibino
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
@@ -41,9 +37,6 @@ library
, 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
@@ -52,12 +45,9 @@ test-suite nested
build-depends: base <5
, quickcheck-simple
, persistable-record
- if impl(ghc == 7.4.*)
- build-depends: ghc-prim == 0.2.*
type: exitcode-stdio-1.0
main-is: nestedEq.hs
- other-modules: Model
hs-source-dirs: test
ghc-options: -Wall
default-language: Haskell2010
diff --git a/src/Database/Record.hs b/src/Database/Record.hs
index 62f8889..99ca60c 100644
--- a/src/Database/Record.hs
+++ b/src/Database/Record.hs
@@ -48,7 +48,6 @@ import Database.Record.ToSql
(ToSqlM, RecordToSql, ToSql(..), valueRecordToSql,
runFromRecord, wrapToSql, putRecord, putEmpty, fromRecord,
updateValuesByUnique, updateValuesByPrimary)
-import Database.Record.TupleInstances ()
{- $concepts
On most drivers for SQL database,
diff --git a/src/Database/Record/FromSql.hs b/src/Database/Record/FromSql.hs
index e0e1a18..4882ed6 100644
--- a/src/Database/Record/FromSql.hs
+++ b/src/Database/Record/FromSql.hs
@@ -1,12 +1,10 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE DefaultSignatures #-}
-- |
-- Module : Database.Record.FromSql
--- Copyright : 2013-2017 Kei Hibino
+-- Copyright : 2013 Kei Hibino
-- License : BSD3
--
-- Maintainer : ex8k.hibino@gmail.com
@@ -31,15 +29,13 @@ module Database.Record.FromSql (
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.
@@ -132,25 +128,10 @@ class FromSql q a where
-- | 'RecordFromSql' proof object.
recordFromSql :: RecordFromSql q a
- default recordFromSql :: (Generic a, GFromSql q (Rep a)) => RecordFromSql q a
- recordFromSql = to <$> gFromSql
-
-
-class GFromSql q f where
- gFromSql :: RecordFromSql q (f a)
-
-instance GFromSql q U1 where
- gFromSql = createRecordFromSql $ (,) U1
-
-instance (GFromSql q a, GFromSql q b) => GFromSql q (a :*: b) where
- gFromSql = (:*:) <$> gFromSql <*> gFromSql
-
-instance GFromSql q a => GFromSql q (M1 i c a) where
- gFromSql = M1 <$> gFromSql
-
-instance FromSql q a => GFromSql q (K1 i a) where
- gFromSql = K1 <$> recordFromSql
-
+-- | 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
-- | Inference rule of 'RecordFromSql' proof object which can convert
-- from list of SQL type ['q'] into Haskell 'Maybe' type.
@@ -160,7 +141,8 @@ instance (HasColumnConstraint NotNull a, FromSql q a, PersistableType q)
-- | Inference rule of 'RecordFromSql' proof object which can convert
-- from /empty/ list of SQL type ['q'] into Haskell unit () type.
-instance FromSql q () -- default generic instance
+instance FromSql q () where
+ recordFromSql = RecordFromSql (\qs -> ((), qs))
-- | Run inferred 'RecordFromSql' proof object.
-- Convert from list of SQL type ['q'] into haskell type 'a' and rest of list ['q'].
diff --git a/src/Database/Record/InternalTH.hs b/src/Database/Record/InternalTH.hs
deleted file mode 100644
index 9310810..0000000
--- a/src/Database/Record/InternalTH.hs
+++ /dev/null
@@ -1,45 +0,0 @@
-{-# 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 --git a/src/Database/Record/Persistable.hs b/src/Database/Record/Persistable.hs
index a1e741e..40aaf46 100644
--- a/src/Database/Record/Persistable.hs
+++ b/src/Database/Record/Persistable.hs
@@ -1,12 +1,9 @@
-{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE DefaultSignatures #-}
-- |
-- Module : Database.Record.Persistable
--- Copyright : 2013-2017 Kei Hibino
+-- Copyright : 2013 Kei Hibino
-- License : BSD3
--
-- Maintainer : ex8k.hibino@gmail.com
@@ -24,22 +21,11 @@ module Database.Record.Persistable (
unsafePersistableRecordWidth, unsafeValueWidth, (<&>), maybeWidth,
-- * Inference rules for proof objects
- PersistableType(..), sqlNullValue,
- PersistableWidth (..), derivedWidth,
- -- * low-level interfaces
- GFieldWidthList,
- ProductConst, getProductConst,
- genericFieldOffsets,
+ PersistableType(..), sqlNullValue,
+ PersistableWidth (..), derivedWidth
) where
-import GHC.Generics (Generic, Rep, U1 (..), K1 (..), M1 (..), (:*:)(..), to)
-import Control.Applicative ((<$>), pure, (<*>), Const (..))
-import Data.Monoid (Monoid, Sum (..))
-import Data.Array (Array, listArray, bounds, (!))
-import Data.DList (DList)
-import qualified Data.DList as DList
-
-- | Proof object to specify type 'q' is SQL type
newtype PersistableSqlType q = PersistableSqlType q
@@ -54,54 +40,35 @@ unsafePersistableSqlTypeFromNull :: q -- ^ SQL null value of
unsafePersistableSqlTypeFromNull = PersistableSqlType
--- | Restricted in product isomorphism record type b
-newtype ProductConst a b =
- ProductConst { unPC :: Const a b }
-
--- | extract constant value of 'ProductConst'.
-getProductConst :: ProductConst a b -> a
-getProductConst = getConst . unPC
-{-# INLINE getProductConst #-}
-
-- | Proof object to specify width of Haskell type 'a'
-- when converting to SQL type list.
-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
-
+newtype PersistableRecordWidth a =
+ PersistableRecordWidth Int
-- | Get width 'Int' value of record type 'a'.
runPersistableRecordWidth :: PersistableRecordWidth a -> Int
-runPersistableRecordWidth = getSum . getConst . unPC
-{-# INLINE runPersistableRecordWidth #-}
-
-instance Show a => Show (ProductConst a b) where
- show = ("PC " ++) . show . getConst . unPC
+runPersistableRecordWidth (PersistableRecordWidth w) = w
-- | Unsafely generate 'PersistableRecordWidth' proof object from specified width of Haskell type 'a'.
unsafePersistableRecordWidth :: Int -- ^ Specify width of Haskell type 'a'
-> PersistableRecordWidth a -- ^ Result proof object
-unsafePersistableRecordWidth = ProductConst . Const . Sum
-{-# INLINE unsafePersistableRecordWidth #-}
+unsafePersistableRecordWidth = PersistableRecordWidth
-- | Unsafely generate 'PersistableRecordWidth' proof object for Haskell type 'a' which is single column type.
unsafeValueWidth :: PersistableRecordWidth a
unsafeValueWidth = unsafePersistableRecordWidth 1
-{-# INLINE unsafeValueWidth #-}
-- | Derivation rule of 'PersistableRecordWidth' for tuple (,) type.
(<&>) :: PersistableRecordWidth a -> PersistableRecordWidth b -> PersistableRecordWidth (a, b)
-a <&> b = (,) `pmap` a `pap` b
+a <&> b = PersistableRecordWidth $ runPersistableRecordWidth a + runPersistableRecordWidth b
-- | Derivation rule of 'PersistableRecordWidth' from from Haskell type 'a' into for Haskell type 'Maybe' 'a'.
maybeWidth :: PersistableRecordWidth a -> PersistableRecordWidth (Maybe a)
-maybeWidth = pmap Just
+maybeWidth = PersistableRecordWidth . runPersistableRecordWidth
+
+-- | Axiom of 'PersistableRecordWidth' for Haskell unit () type.
+voidWidth :: PersistableRecordWidth ()
+voidWidth = unsafePersistableRecordWidth 0
-- | Interface of inference rule for 'PersistableSqlType' proof object
@@ -117,45 +84,17 @@ sqlNullValue = runPersistableNullValue persistableType
class PersistableWidth a where
persistableWidth :: PersistableRecordWidth a
- default persistableWidth :: (Generic a, GFieldWidthList (Rep a)) => PersistableRecordWidth a
- persistableWidth = pmapConst (Sum . lastA) genericFieldOffsets
- where
- lastA a = a ! (snd $ bounds a)
-
-
-pmapConst :: (a -> b) -> ProductConst a c -> ProductConst b c
-pmapConst f = ProductConst . Const . f . getConst . unPC
-
--- | Generic width value list of record fields.
-class GFieldWidthList f where
- gFieldWidthList :: ProductConst (DList Int) (f a)
-
-instance GFieldWidthList U1 where
- gFieldWidthList = ProductConst $ pure U1
-
-instance (GFieldWidthList a, GFieldWidthList b) => GFieldWidthList (a :*: b) where
- gFieldWidthList = (:*:) `pmap` gFieldWidthList `pap` gFieldWidthList
-
-instance GFieldWidthList a => GFieldWidthList (M1 i c a) where
- gFieldWidthList = M1 `pmap` gFieldWidthList
-
-instance PersistableWidth a => GFieldWidthList (K1 i a) where
- gFieldWidthList = K1 `pmap` pmapConst (pure . getSum) persistableWidth
-
-offsets :: [Int] -> Array Int Int
-offsets ws = listArray (0, length ws) $ scanl (+) 0 ws
-
--- | Generic offset array of record fields.
-genericFieldOffsets :: (Generic a, GFieldWidthList (Rep a)) => ProductConst (Array Int Int) a
-genericFieldOffsets = pmapConst (offsets . DList.toList) $ to `pmap` gFieldWidthList
-
+-- | Inference rule of 'PersistableRecordWidth' proof object for tuple ('a', 'b') type.
+instance (PersistableWidth a, PersistableWidth b) => PersistableWidth (a, b) where
+ persistableWidth = persistableWidth <&> persistableWidth
-- | Inference rule of 'PersistableRecordWidth' proof object for 'Maybe' type.
instance PersistableWidth a => PersistableWidth (Maybe a) where
persistableWidth = maybeWidth persistableWidth
-- | Inference rule of 'PersistableRecordWidth' for Haskell unit () type. Derive from axiom.
-instance PersistableWidth () -- default generic instance
+instance PersistableWidth () where
+ persistableWidth = voidWidth
-- | Pass type parameter and inferred width value.
derivedWidth :: PersistableWidth a => (PersistableRecordWidth a, Int)
diff --git a/src/Database/Record/TH.hs b/src/Database/Record/TH.hs
index b8865a3..c0559b4 100644
--- a/src/Database/Record/TH.hs
+++ b/src/Database/Record/TH.hs
@@ -4,7 +4,7 @@
-- |
-- Module : Database.Record.TH
--- Copyright : 2013-2017 Kei Hibino
+-- Copyright : 2013 Kei Hibino
-- License : BSD3
--
-- Maintainer : ex8k.hibino@gmail.com
@@ -18,6 +18,9 @@ module Database.Record.TH (
defineRecord,
defineRecordWithConfig,
+ -- * Deriving class symbols
+ derivingEq, derivingShow, derivingRead, derivingData, derivingTypeable,
+
-- * Table constraint specified by key
defineHasColumnConstraintInstance,
defineHasPrimaryConstraintInstanceDerived,
@@ -28,60 +31,70 @@ module Database.Record.TH (
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 name
+ -- * Templates about record type name
NameConfig, defaultNameConfig,
recordTypeName, columnName,
- recordTemplate,
+ recordType,
columnOffsetsVarNameDefault,
- -- * Not nullable single column type
- deriveNotNullType,
+ persistableFunctionNamesDefault,
- -- * Template for tuple types
- defineTupleInstances,
+ -- * Not nullable single column type
+ deriveNotNullType
) where
-import GHC.Generics (Generic)
-import Data.Array (Array)
+
+import Control.Applicative (pure, (<*>))
+import Data.List (foldl')
+import Data.Array (Array, listArray, (!))
+import Data.Data (Data, Typeable)
import Language.Haskell.TH.Name.CamelCase
(ConName(conName), VarName(varName),
conCamelcaseName, varCamelcaseName, varNameWithPrefix,
- toTypeCon, toDataCon, )
-import Language.Haskell.TH.Lib.Extra (integralE, simpleValD, reportWarning)
+ toTypeCon, toDataCon, toVarExp)
+import Language.Haskell.TH.Lib.Extra (integralE, simpleValD)
import Language.Haskell.TH.Compat.Data (dataD', unDataD)
import Language.Haskell.TH
- (Q, nameBase, reify, Info(TyConI), Name,
+ (Q, newName, nameBase, reify, Info(TyConI), Name,
TypeQ, conT, Con (NormalC, RecC),
- Dec,
- ExpQ, conE, listE, sigE,
- recC,
+ Dec, sigD, valD,
+ ExpQ, Exp(ConE), conE, varE, lamE, listE, sigE,
+ varP, conP, normalB, recC,
cxt, varStrictType, strictType, isStrict)
-import Control.Arrow ((&&&))
-
import Database.Record
(HasColumnConstraint(columnConstraint), Primary, NotNull,
HasKeyConstraint(keyConstraint), derivedCompositePrimary,
PersistableRecordWidth, PersistableWidth(persistableWidth),
- FromSql, ToSql, )
+ FromSql(recordFromSql), RecordFromSql,
+ ToSql(recordToSql), RecordToSql, wrapToSql, putRecord, putEmpty)
import Database.Record.KeyConstraint
(unsafeSpecifyColumnConstraint, unsafeSpecifyNotNullValue, unsafeSpecifyKeyConstraint)
-import Database.Record.Persistable
- (runPersistableRecordWidth,
- ProductConst, getProductConst, genericFieldOffsets)
+import Database.Record.Persistable (unsafePersistableRecordWidth, runPersistableRecordWidth)
import qualified Database.Record.Persistable as Persistable
-import Database.Record.InternalTH (defineTupleInstances)
-- | 'NameConfig' type to customize names of expanded record templates.
@@ -106,12 +119,12 @@ defaultNameConfig =
, columnName = const varCamelcaseName
}
--- | Record constructor templates from SQL table name 'String'.
-recordTemplate :: NameConfig -- ^ name rule config
- -> String -- ^ Schema name string in SQL
- -> String -- ^ Table name string in SQL
- -> (TypeQ, ExpQ) -- ^ Record type and data constructor
-recordTemplate config scm = (toTypeCon &&& toDataCon) . recordTypeName config scm
+-- | 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
-- | Variable expression of record column offset array.
columnOffsetsVarNameDefault :: Name -- ^ Table type name
@@ -157,6 +170,31 @@ defineHasNotNullKeyInstance :: TypeQ -- ^ Type constructor of record
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.
@@ -173,8 +211,10 @@ defineColumnOffsets typeName' tys = do
let ofsVar = columnOffsetsVarNameDefault $ conName typeName'
widthIxE = integralE $ length tys
ar <- simpleValD (varName ofsVar) [t| Array Int Int |]
- [| getProductConst (genericFieldOffsets :: ProductConst (Array Int Int) $(toTypeCon typeName')) |]
- pw <- [d| instance PersistableWidth $(toTypeCon typeName')
+ [| listArray (0 :: Int, $widthIxE) $
+ scanl (+) (0 :: Int) $(listE $ map recordWidthTemplate tys) |]
+ pw <- [d| instance PersistableWidth $(toTypeCon typeName') where
+ persistableWidth = unsafePersistableRecordWidth $ $(toVarExp ofsVar) ! $widthIxE
|]
return $ ar ++ pw
@@ -186,14 +226,9 @@ defineRecordType :: ConName -- ^ Name of the data type of table recor
defineRecordType typeName' columns derives = do
let typeName = conName typeName'
fld (n, tq) = varStrictType (varName n) (strictType isStrict tq)
- derives1 <- if (''Generic `notElem` derives)
- then do reportWarning "HRR needs Generic instance, please add ''Generic manually."
- return $ ''Generic : derives
- {- DROP this hack in future version ups. -}
- else return derives
- rec' <- dataD' (cxt []) typeName [] [recC typeName (map fld columns)] derives1
+ rec <- dataD' (cxt []) typeName [] [recC typeName (map fld columns)] derives
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]
@@ -203,6 +238,79 @@ defineRecordTypeWithConfig config schema table columns =
[ (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")
@@ -211,6 +319,29 @@ fromSqlNameDefault = (`varNameWithPrefix` "fromSqlOf")
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
@@ -231,29 +362,41 @@ reifyRecordType recTypeName = do
return
(recordInfo' tyConInfo)
--- | Record parser and printer instance templates for converting
--- between list of SQL type and Haskell record type.
-definePersistableInstance :: TypeQ -- ^ SQL value type.
- -> TypeQ -- ^ Record type constructor.
- -> Q [Dec] -- ^ Instance declarations.
-definePersistableInstance sqlType typeCon = do
- [d| instance FromSql $sqlType $typeCon
- instance ToSql $sqlType $typeCon
- |]
+-- | 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
-- | 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
- tyC
+ fnames tyC
columns drvs = do
typ <- defineRecordType tyC columns drvs
- withSql <- definePersistableInstance sqlValueType $ toTypeCon tyC
+ withSql <- makeRecordPersistableWithSqlType sqlValueType fnames (toTypeCon tyC, toDataCon tyC) $ length columns
return $ typ ++ withSql
-- | All templates for record type with configured names.
@@ -266,8 +409,7 @@ defineRecordWithConfig :: TypeQ -- ^ SQL value type
-> Q [Dec] -- ^ Result declarations
defineRecordWithConfig sqlValueType config schema table columns derives = do
typ <- defineRecordTypeWithConfig config schema table columns derives
- withSql <- definePersistableInstance sqlValueType . fst $ recordTemplate config schema table
-
+ withSql <- makeRecordPersistableWithSqlTypeWithConfig sqlValueType config schema table $ length columns
return $ typ ++ withSql
diff --git a/src/Database/Record/ToSql.hs b/src/Database/Record/ToSql.hs
index 5a2fcb6..eee5850 100644
--- a/src/Database/Record/ToSql.hs
+++ b/src/Database/Record/ToSql.hs
@@ -1,12 +1,10 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE DefaultSignatures #-}
-- |
-- Module : Database.Record.ToSql
--- Copyright : 2013-2017 Kei Hibino
+-- Copyright : 2013 Kei Hibino
-- License : BSD3
--
-- Maintainer : ex8k.hibino@gmail.com
@@ -37,7 +35,6 @@ module Database.Record.ToSql (
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)
@@ -78,20 +75,11 @@ createRecordToSql :: (a -> [q]) -- ^ Convert function body
-> RecordToSql q a -- ^ Result proof object
createRecordToSql f = wrapToSql $ tell . DList.fromList . f
--- unsafely map record
-mapToSql :: (a -> b) -> RecordToSql q b -> RecordToSql q a
-mapToSql f x = wrapToSql $ runRecordToSql x . f
-
--- unsafely put product record
-productToSql :: (c -> (a -> b -> ToSqlM q ()) -> ToSqlM q ())
- -> RecordToSql q a -> RecordToSql q b -> RecordToSql q c
-productToSql run ra rb = wrapToSql $ \c -> run c $ \a b -> do
- runRecordToSql ra a
- runRecordToSql rb b
-
-- | Derivation rule of 'RecordToSql' proof object for Haskell tuple (,) type.
(<&>) :: RecordToSql q a -> RecordToSql q b -> RecordToSql q (a, b)
-(<&>) = productToSql $ flip uncurry
+ra <&> rb = RecordToSql $ \(a, b) -> do
+ runRecordToSql ra a
+ runRecordToSql rb b
-- | Derivation rule of 'RecordToSql' proof object for Haskell 'Maybe' type.
maybeRecord :: PersistableSqlType q -> PersistableRecordWidth a -> RecordToSql q a -> RecordToSql q (Maybe a)
@@ -107,24 +95,10 @@ class ToSql q a where
-- | Infer 'RecordToSql' proof object.
recordToSql :: RecordToSql q a
- default recordToSql :: (Generic a, GToSql q (Rep a)) => RecordToSql q a
- recordToSql = from `mapToSql` gToSql
-
-class GToSql q f where
- gToSql :: RecordToSql q (f a)
-
-instance GToSql q U1 where
- gToSql = wrapToSql $ \U1 -> tell DList.empty
-
-instance (GToSql q a, GToSql q b) => GToSql q (a :*: b) where
- gToSql = productToSql (\ (a:*:b) f -> f a b) gToSql gToSql
-
-instance GToSql q a => GToSql q (M1 i c a) where
- gToSql = (\(M1 a) -> a) `mapToSql` gToSql
-
-instance ToSql q a => GToSql q (K1 i a) where
- gToSql = (\(K1 a) -> a) `mapToSql` recordToSql
-
+-- | 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'].
@@ -133,7 +107,8 @@ instance (PersistableType q, PersistableWidth a, ToSql q a) => ToSql q (Maybe a)
-- | Inference rule of 'RecordToSql' proof object which can convert
-- from Haskell unit () type into /empty/ list of SQL type ['q'].
-instance ToSql q () -- default generic instance
+instance ToSql q () where
+ recordToSql = wrapToSql $ \() -> tell DList.empty
-- | Run inferred 'RecordToSql' proof object.
-- Context to convert haskell record type 'a' into SQL type 'q' list.
diff --git a/src/Database/Record/TupleInstances.hs b/src/Database/Record/TupleInstances.hs
deleted file mode 100644
index 381cbde..0000000
--- a/src/Database/Record/TupleInstances.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-{-# 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 --git a/test/Model.hs b/test/Model.hs
deleted file mode 100644
index 553266d..0000000
--- a/test/Model.hs
+++ /dev/null
@@ -1,74 +0,0 @@
-{-# 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 --git a/test/nestedEq.hs b/test/nestedEq.hs
index 54bb0f6..bfd7fdc 100644
--- a/test/nestedEq.hs
+++ b/test/nestedEq.hs
@@ -1,60 +1,67 @@
{-# OPTIONS -fno-warn-orphans #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
+import Control.Applicative ((<$>), (<*>))
import Test.QuickCheck.Simple (defaultMain, eqTest)
-import Database.Record (toRecord, fromRecord, persistableWidth, PersistableRecordWidth)
-import Database.Record.Persistable (runPersistableRecordWidth)
+import Database.Record
+ (PersistableType (..),
+ FromSql (..), valueRecordFromSql, toRecord,
+ ToSql (..), valueRecordToSql)
+import Database.Record.Persistable (unsafePersistableSqlTypeFromNull)
-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
- "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"
+ "nestedEq"
(Membership { user = User { uid = 1, uname = "Kei Hibino", note = "HRR developer" }
- , group = Nothing
+ , group = Group { gid = 1, gname = "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))
- ]
+ (toRecord ["1", "Kei Hibino", "HRR developer", "1", "Haskellers"]) ]