diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,38 @@ + + +## 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 --- a/persistable-record.cabal +++ b/persistable-record.cabal @@ -1,5 +1,5 @@ name: persistable-record -version: 0.4.2.0 +version: 0.5.0.0 synopsis: Binding between SQL database values and haskell records. description: This package contiains types to represent table constraints and interfaces to bind between SQL database values and Haskell records. @@ -12,23 +12,31 @@ category: Database build-type: Simple cabal-version: >=1.10 -tested-with: GHC == 8.2.1 - , GHC == 8.0.1, GHC == 8.0.2 +tested-with: GHC == 8.0.1, GHC == 8.0.2 , GHC == 7.10.1, GHC == 7.10.2, GHC == 7.10.3 , GHC == 7.8.1, GHC == 7.8.2, GHC == 7.8.3, GHC == 7.8.4 , GHC == 7.6.1, GHC == 7.6.2, GHC == 7.6.3 , GHC == 7.4.1, GHC == 7.4.2 +extra-source-files: ChangeLog.md +flag ghc74-generic + description: Enable for generic programming using old ghc. If true use ghc-prim. + default: False + library exposed-modules: Database.Record.FromSql Database.Record.ToSql Database.Record.Persistable + Database.Record.TupleInstances Database.Record.Instances Database.Record.KeyConstraint Database.Record Database.Record.TH + other-modules: + Database.Record.InternalTH + build-depends: base <5 , template-haskell , th-data-compat @@ -37,6 +45,9 @@ , transformers , dlist , names-th + if flag(ghc74-generic) + build-depends: ghc-prim == 0.2.* + hs-source-dirs: src ghc-options: -Wall default-language: Haskell2010 @@ -45,9 +56,12 @@ build-depends: base <5 , quickcheck-simple , persistable-record + if flag(ghc74-generic) + build-depends: ghc-prim == 0.2.* type: exitcode-stdio-1.0 main-is: nestedEq.hs + other-modules: Model hs-source-dirs: test ghc-options: -Wall default-language: Haskell2010 diff --git a/src/Database/Record.hs b/src/Database/Record.hs --- a/src/Database/Record.hs +++ b/src/Database/Record.hs @@ -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 --git a/src/Database/Record/FromSql.hs b/src/Database/Record/FromSql.hs --- a/src/Database/Record/FromSql.hs +++ b/src/Database/Record/FromSql.hs @@ -1,10 +1,12 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DefaultSignatures #-} -- | -- Module : Database.Record.FromSql --- Copyright : 2013 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -29,13 +31,15 @@ valueRecordFromSql, ) where +import GHC.Generics (Generic, Rep, U1 (..), K1 (..), M1 (..), (:*:)(..), to) +import Control.Applicative ((<$>), Applicative (pure, (<*>))) +import Control.Monad (liftM, ap) + import Database.Record.Persistable (PersistableType) import qualified Database.Record.Persistable as Persistable import Database.Record.KeyConstraint (HasColumnConstraint(columnConstraint), ColumnConstraint, NotNull, index) -import Control.Monad (liftM, ap) -import Control.Applicative ((<$>), Applicative(pure, (<*>))) {- $recordFromSql Structure of 'RecordFromSql' 'q' 'a' is similar to parser. @@ -128,11 +132,26 @@ -- | 'RecordFromSql' proof object. recordFromSql :: RecordFromSql q a --- | Inference rule of 'RecordFromSql' proof object which can convert --- from list of SQL type ['q'] into Haskell tuple ('a', 'b') type. -instance (FromSql q a, FromSql q b) => FromSql q (a, b) where - recordFromSql = recordFromSql <&> recordFromSql + default recordFromSql :: (Generic a, GFromSql q (Rep a)) => RecordFromSql q a + recordFromSql = to <$> gFromSql + +class GFromSql q f where + gFromSql :: RecordFromSql q (f a) + +instance GFromSql q U1 where + gFromSql = createRecordFromSql $ (,) U1 + +instance (GFromSql q a, GFromSql q b) => GFromSql q (a :*: b) where + gFromSql = (:*:) <$> gFromSql <*> gFromSql + +instance GFromSql q a => GFromSql q (M1 i c a) where + gFromSql = M1 <$> gFromSql + +instance FromSql q a => GFromSql q (K1 i a) where + gFromSql = K1 <$> recordFromSql + + -- | Inference rule of 'RecordFromSql' proof object which can convert -- from list of SQL type ['q'] into Haskell 'Maybe' type. instance (HasColumnConstraint NotNull a, FromSql q a, PersistableType q) @@ -141,8 +160,7 @@ -- | Inference rule of 'RecordFromSql' proof object which can convert -- from /empty/ list of SQL type ['q'] into Haskell unit () type. -instance FromSql q () where - recordFromSql = RecordFromSql (\qs -> ((), qs)) +instance FromSql q () -- default generic instance -- | Run inferred 'RecordFromSql' proof object. -- Convert from list of SQL type ['q'] into haskell type 'a' and rest of list ['q']. diff --git a/src/Database/Record/InternalTH.hs b/src/Database/Record/InternalTH.hs new file mode 100644 --- /dev/null +++ b/src/Database/Record/InternalTH.hs @@ -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 --git a/src/Database/Record/Persistable.hs b/src/Database/Record/Persistable.hs --- a/src/Database/Record/Persistable.hs +++ b/src/Database/Record/Persistable.hs @@ -1,9 +1,12 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DefaultSignatures #-} -- | -- Module : Database.Record.Persistable --- Copyright : 2013 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -21,12 +24,23 @@ unsafePersistableRecordWidth, unsafeValueWidth, (<&>), maybeWidth, -- * Inference rules for proof objects - PersistableType(..), sqlNullValue, - PersistableWidth (..), derivedWidth + PersistableWidth (..), derivedWidth, + + -- * low-level interfaces + GFieldWidthList, + ProductConst, getProductConst, + genericFieldOffsets, ) where +import GHC.Generics (Generic, Rep, U1 (..), K1 (..), M1 (..), (:*:)(..), to) +import Control.Applicative ((<$>), pure, (<*>), Const (..)) +import Data.Monoid (Monoid, Sum (..)) +import Data.Array (Array, listArray, bounds, (!)) +import Data.DList (DList) +import qualified Data.DList as DList + -- | Proof object to specify type 'q' is SQL type newtype PersistableSqlType q = PersistableSqlType q @@ -40,35 +54,54 @@ unsafePersistableSqlTypeFromNull = PersistableSqlType +-- | Restricted in product isomorphism record type b +newtype ProductConst a b = + ProductConst { unPC :: Const a b } + +-- | extract constant value of 'ProductConst'. +getProductConst :: ProductConst a b -> a +getProductConst = getConst . unPC +{-# INLINE getProductConst #-} + -- | Proof object to specify width of Haskell type 'a' -- when converting to SQL type list. -newtype PersistableRecordWidth a = - PersistableRecordWidth Int +type PersistableRecordWidth a = ProductConst (Sum Int) a +-- unsafely map PersistableRecordWidth +pmap :: Monoid e => (a -> b) -> ProductConst e a -> ProductConst e b +f `pmap` prw = ProductConst $ f <$> unPC prw + +-- unsafely ap PersistableRecordWidth +pap :: Monoid e => ProductConst e (a -> b) -> ProductConst e a -> ProductConst e b +wf `pap` prw = ProductConst $ unPC wf <*> unPC prw + + -- | Get width 'Int' value of record type 'a'. runPersistableRecordWidth :: PersistableRecordWidth a -> Int -runPersistableRecordWidth (PersistableRecordWidth w) = w +runPersistableRecordWidth = getSum . getConst . unPC +{-# INLINE runPersistableRecordWidth #-} +instance Show a => Show (ProductConst a b) where + show = ("PC " ++) . show . getConst . unPC + -- | Unsafely generate 'PersistableRecordWidth' proof object from specified width of Haskell type 'a'. unsafePersistableRecordWidth :: Int -- ^ Specify width of Haskell type 'a' -> PersistableRecordWidth a -- ^ Result proof object -unsafePersistableRecordWidth = PersistableRecordWidth +unsafePersistableRecordWidth = ProductConst . Const . Sum +{-# INLINE unsafePersistableRecordWidth #-} -- | Unsafely generate 'PersistableRecordWidth' proof object for Haskell type 'a' which is single column type. unsafeValueWidth :: PersistableRecordWidth a unsafeValueWidth = unsafePersistableRecordWidth 1 +{-# INLINE unsafeValueWidth #-} -- | Derivation rule of 'PersistableRecordWidth' for tuple (,) type. (<&>) :: PersistableRecordWidth a -> PersistableRecordWidth b -> PersistableRecordWidth (a, b) -a <&> b = PersistableRecordWidth $ runPersistableRecordWidth a + runPersistableRecordWidth b +a <&> b = (,) `pmap` a `pap` b -- | Derivation rule of 'PersistableRecordWidth' from from Haskell type 'a' into for Haskell type 'Maybe' 'a'. maybeWidth :: PersistableRecordWidth a -> PersistableRecordWidth (Maybe a) -maybeWidth = PersistableRecordWidth . runPersistableRecordWidth - --- | Axiom of 'PersistableRecordWidth' for Haskell unit () type. -voidWidth :: PersistableRecordWidth () -voidWidth = unsafePersistableRecordWidth 0 +maybeWidth = pmap Just -- | Interface of inference rule for 'PersistableSqlType' proof object @@ -84,17 +117,45 @@ class PersistableWidth a where persistableWidth :: PersistableRecordWidth a --- | Inference rule of 'PersistableRecordWidth' proof object for tuple ('a', 'b') type. -instance (PersistableWidth a, PersistableWidth b) => PersistableWidth (a, b) where - persistableWidth = persistableWidth <&> persistableWidth + default persistableWidth :: (Generic a, GFieldWidthList (Rep a)) => PersistableRecordWidth a + persistableWidth = pmapConst (Sum . lastA) genericFieldOffsets + where + lastA a = a ! (snd $ bounds a) + +pmapConst :: (a -> b) -> ProductConst a c -> ProductConst b c +pmapConst f = ProductConst . Const . f . getConst . unPC + +-- | Generic width value list of record fields. +class GFieldWidthList f where + gFieldWidthList :: ProductConst (DList Int) (f a) + +instance GFieldWidthList U1 where + gFieldWidthList = ProductConst $ pure U1 + +instance (GFieldWidthList a, GFieldWidthList b) => GFieldWidthList (a :*: b) where + gFieldWidthList = (:*:) `pmap` gFieldWidthList `pap` gFieldWidthList + +instance GFieldWidthList a => GFieldWidthList (M1 i c a) where + gFieldWidthList = M1 `pmap` gFieldWidthList + +instance PersistableWidth a => GFieldWidthList (K1 i a) where + gFieldWidthList = K1 `pmap` pmapConst (pure . getSum) persistableWidth + +offsets :: [Int] -> Array Int Int +offsets ws = listArray (0, length ws) $ scanl (+) 0 ws + +-- | Generic offset array of record fields. +genericFieldOffsets :: (Generic a, GFieldWidthList (Rep a)) => ProductConst (Array Int Int) a +genericFieldOffsets = pmapConst (offsets . DList.toList) $ to `pmap` gFieldWidthList + + -- | Inference rule of 'PersistableRecordWidth' proof object for 'Maybe' type. instance PersistableWidth a => PersistableWidth (Maybe a) where persistableWidth = maybeWidth persistableWidth -- | Inference rule of 'PersistableRecordWidth' for Haskell unit () type. Derive from axiom. -instance PersistableWidth () where - persistableWidth = voidWidth +instance PersistableWidth () -- default generic instance -- | Pass type parameter and inferred width value. derivedWidth :: PersistableWidth a => (PersistableRecordWidth a, Int) diff --git a/src/Database/Record/TH.hs b/src/Database/Record/TH.hs --- a/src/Database/Record/TH.hs +++ b/src/Database/Record/TH.hs @@ -4,7 +4,7 @@ -- | -- Module : Database.Record.TH --- Copyright : 2013 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -18,9 +18,6 @@ defineRecord, defineRecordWithConfig, - -- * Deriving class symbols - derivingEq, derivingShow, derivingRead, derivingData, derivingTypeable, - -- * Table constraint specified by key defineHasColumnConstraintInstance, defineHasPrimaryConstraintInstanceDerived, @@ -31,70 +28,60 @@ defineRecordType, defineRecordTypeWithConfig, - -- * Function declarations depending on SQL type - makeRecordPersistableWithSqlType, - makeRecordPersistableWithSqlTypeWithConfig, - makeRecordPersistableWithSqlTypeDefault, - -- * Function declarations against defined record types - makeRecordPersistableWithSqlTypeFromDefined, - makeRecordPersistableWithSqlTypeDefaultFromDefined, defineColumnOffsets, recordWidthTemplate, - defineRecordParser, - defineRecordPrinter, - - definePersistableInstance, - -- * Reify reifyRecordType, - -- * Templates about record type name + -- * Templates about record name NameConfig, defaultNameConfig, recordTypeName, columnName, - recordType, + recordTemplate, columnOffsetsVarNameDefault, - persistableFunctionNamesDefault, - -- * Not nullable single column type - deriveNotNullType - ) where + deriveNotNullType, + -- * Template for tuple types + defineTupleInstances, + ) where -import Control.Applicative (pure, (<*>)) -import Data.List (foldl') -import Data.Array (Array, listArray, (!)) -import Data.Data (Data, Typeable) +import GHC.Generics (Generic) +import Data.Array (Array) import Language.Haskell.TH.Name.CamelCase (ConName(conName), VarName(varName), conCamelcaseName, varCamelcaseName, varNameWithPrefix, - toTypeCon, toDataCon, toVarExp) -import Language.Haskell.TH.Lib.Extra (integralE, simpleValD) + toTypeCon, toDataCon, ) +import Language.Haskell.TH.Lib.Extra (integralE, simpleValD, reportWarning) import Language.Haskell.TH.Compat.Data (dataD', unDataD) import Language.Haskell.TH - (Q, newName, nameBase, reify, Info(TyConI), Name, + (Q, nameBase, reify, Info(TyConI), Name, TypeQ, conT, Con (NormalC, RecC), - Dec, sigD, valD, - ExpQ, Exp(ConE), conE, varE, lamE, listE, sigE, - varP, conP, normalB, recC, + Dec, + ExpQ, conE, listE, sigE, + recC, cxt, varStrictType, strictType, isStrict) +import Control.Arrow ((&&&)) + import Database.Record (HasColumnConstraint(columnConstraint), Primary, NotNull, HasKeyConstraint(keyConstraint), derivedCompositePrimary, PersistableRecordWidth, PersistableWidth(persistableWidth), - FromSql(recordFromSql), RecordFromSql, - ToSql(recordToSql), RecordToSql, wrapToSql, putRecord, putEmpty) + FromSql, ToSql, ) import Database.Record.KeyConstraint (unsafeSpecifyColumnConstraint, unsafeSpecifyNotNullValue, unsafeSpecifyKeyConstraint) -import Database.Record.Persistable (unsafePersistableRecordWidth, runPersistableRecordWidth) +import Database.Record.Persistable + (runPersistableRecordWidth, + ProductConst, getProductConst, genericFieldOffsets) import qualified Database.Record.Persistable as Persistable +import Database.Record.InternalTH (defineTupleInstances) -- | 'NameConfig' type to customize names of expanded record templates. @@ -119,12 +106,12 @@ , columnName = const varCamelcaseName } --- | Record type constructor template from SQL table name 'String'. -recordType :: NameConfig -- ^ name rule config - -> String -- ^ Schema name string in SQL - -> String -- ^ Table name string in SQL - -> TypeQ -- ^ Record type constructor -recordType config scm = toTypeCon . recordTypeName config scm +-- | Record constructor templates from SQL table name 'String'. +recordTemplate :: NameConfig -- ^ name rule config + -> String -- ^ Schema name string in SQL + -> String -- ^ Table name string in SQL + -> (TypeQ, ExpQ) -- ^ Record type and data constructor +recordTemplate config scm = (toTypeCon &&& toDataCon) . recordTypeName config scm -- | Variable expression of record column offset array. columnOffsetsVarNameDefault :: Name -- ^ Table type name @@ -170,31 +157,6 @@ defineHasNotNullKeyInstance = defineHasColumnConstraintInstance [t| NotNull |] -{-# DEPRECATED derivingEq "Use TH quasi-quotation like ''Eq instead of this." #-} --- | Name to specify deriving 'Eq' -derivingEq :: Name -derivingEq = ''Eq - -{-# DEPRECATED derivingShow "Use TH quasi-quotation like ''Show instead of this." #-} --- | Name to specify deriving 'Show' -derivingShow :: Name -derivingShow = ''Show - -{-# DEPRECATED derivingRead "Use TH quasi-quotation like ''Read instead of this." #-} --- | Name to specify deriving 'Read' -derivingRead :: Name -derivingRead = ''Read - -{-# DEPRECATED derivingData "Use TH quasi-quotation like ''Data instead of this." #-} --- | Name to specify deriving 'Data' -derivingData :: Name -derivingData = ''Data - -{-# DEPRECATED derivingTypeable "Use TH quasi-quotation like ''Typeable instead of this." #-} --- | Name to specify deriving 'Typeable' -derivingTypeable :: Name -derivingTypeable = ''Typeable - -- | Record type width expression template. recordWidthTemplate :: TypeQ -- ^ Record type constructor. -> ExpQ -- ^ Expression to get record width. @@ -211,10 +173,8 @@ let ofsVar = columnOffsetsVarNameDefault $ conName typeName' widthIxE = integralE $ length tys ar <- simpleValD (varName ofsVar) [t| Array Int Int |] - [| listArray (0 :: Int, $widthIxE) $ - scanl (+) (0 :: Int) $(listE $ map recordWidthTemplate tys) |] - pw <- [d| instance PersistableWidth $(toTypeCon typeName') where - persistableWidth = unsafePersistableRecordWidth $ $(toVarExp ofsVar) ! $widthIxE + [| getProductConst (genericFieldOffsets :: ProductConst (Array Int Int) $(toTypeCon typeName')) |] + pw <- [d| instance PersistableWidth $(toTypeCon typeName') |] return $ ar ++ pw @@ -226,9 +186,14 @@ defineRecordType typeName' columns derives = do let typeName = conName typeName' fld (n, tq) = varStrictType (varName n) (strictType isStrict tq) - rec <- dataD' (cxt []) typeName [] [recC typeName (map fld columns)] derives + derives1 <- if (''Generic `notElem` derives) + then do reportWarning "HRR needs Generic instance, please add ''Generic manually." + return $ ''Generic : derives + {- DROP this hack in future version ups. -} + else return derives + rec' <- dataD' (cxt []) typeName [] [recC typeName (map fld columns)] derives1 offs <- defineColumnOffsets typeName' [ty | (_, ty) <- columns] - return $ rec : offs + return $ rec' : offs -- | Record type declaration template with configured names. defineRecordTypeWithConfig :: NameConfig -> String -> String -> [(String, TypeQ)] -> [Name] -> Q [Dec] @@ -238,79 +203,6 @@ [ (columnName config schema n, t) | (n, t) <- columns ] --- | Record parser template. -defineRecordParser :: TypeQ -- ^ SQL value type. - -> VarName -- ^ Name of record parser. - -> (TypeQ, ExpQ) -- ^ Record type constructor and data constructor. - -> Int -- ^ Count of record columns. - -> Q [Dec] -- ^ Declaration of record construct function from SQL values. -defineRecordParser sqlValType name' (tyCon, dataCon) width = do - let name = varName name' - sig <- sigD name [t| RecordFromSql $sqlValType $tyCon |] - var <- valD (varP name) - (normalB - (foldl' (\a x -> [| $a <*> $x |]) [| pure $dataCon |] - $ replicate width [| recordFromSql |]) - ) - [] - return [sig, var] - -dataConInfo :: Exp -> Q Name -dataConInfo = d where - d (ConE n) = return n - d e = fail $ "Not record data constructor: " ++ show e - --- | Record printer template. -defineRecordPrinter :: TypeQ -- ^ SQL value type. - -> VarName -- ^ Name of record printer. - -> (TypeQ, ExpQ) -- ^ Record type constructor and data constructor. - -> Int -- ^ Count of record columns. - -> Q [Dec] -- ^ Declaration of record construct function from SQL values. -defineRecordPrinter sqlValType name' (tyCon, dataCon) width = do - let name = varName name' - sig <- sigD name [t| RecordToSql $sqlValType $tyCon |] - names <- mapM (newName . ('f':) . show) [1 .. width] - dcn <- dataCon >>= dataConInfo - var <- valD (varP name) - (normalB [| wrapToSql - $(lamE - [ conP dcn [ varP n | n <- names ] ] - (foldr (\a x -> [| $a >> $x |]) [| putEmpty () |] - [ [| putRecord $(varE n) |] | n <- names ])) |]) - [] - return [sig, var] - --- | Record parser and printer instance templates for converting --- between list of SQL type and Haskell record type. -definePersistableInstance :: TypeQ -- ^ SQL value type. - -> TypeQ -- ^ Record type constructor. - -> VarName -- ^ Record parser name. - -> VarName -- ^ Record printer name. - -> Int -- ^ Count of record columns. - -> Q [Dec] -- ^ Instance declarations for 'Persistable'. -definePersistableInstance sqlType typeCon parserName printerName _width = do - [d| instance FromSql $sqlType $typeCon where - recordFromSql = $(toVarExp parserName) - - instance ToSql $sqlType $typeCon where - recordToSql = $(toVarExp printerName) - |] - --- | All templates depending on SQL value type. -makeRecordPersistableWithSqlType :: TypeQ -- ^ SQL value type. - -> (VarName, VarName) -- ^ Constructor function name and decompose function name. - -> (TypeQ, ExpQ) -- ^ Record type constructor and data constructor. - -> Int -- ^ Count of record columns. - -> Q [Dec] -- ^ Result declarations. -makeRecordPersistableWithSqlType - sqlValueType - (cF, dF) conPair@(tyCon, _) - width = do - fromSQL <- defineRecordParser sqlValueType cF conPair width - toSQL <- defineRecordPrinter sqlValueType dF conPair width - instSQL <- definePersistableInstance sqlValueType tyCon cF dF width - return $ fromSQL ++ toSQL ++ instSQL - -- | Default name of record construction function from SQL table name. fromSqlNameDefault :: String -> VarName fromSqlNameDefault = (`varNameWithPrefix` "fromSqlOf") @@ -319,29 +211,6 @@ toSqlNameDefault :: String -> VarName toSqlNameDefault = (`varNameWithPrefix` "toSqlOf") --- | All templates depending on SQL value type with configured names. -makeRecordPersistableWithSqlTypeWithConfig :: TypeQ -- ^ SQL value type - -> NameConfig -- ^ name rule config - -> String -- ^ Schema name of database - -> String -- ^ Table name of database - -> Int -- ^ Count of record columns - -> Q [Dec] -- ^ Result declarations -makeRecordPersistableWithSqlTypeWithConfig sqlValueType config schema table width = - makeRecordPersistableWithSqlType - sqlValueType - (persistableFunctionNamesDefault . conName . conCamelcaseName $ table) - (recordType config schema table, toDataCon . recordTypeName config schema $ table) - width - --- | All templates depending on SQL value type with default names. -makeRecordPersistableWithSqlTypeDefault :: TypeQ -- ^ SQL value type - -> String -- ^ Schema name - -> String -- ^ Table name - -> Int -- ^ Count of record columns - -> Q [Dec] -- ^ Result declarations -makeRecordPersistableWithSqlTypeDefault sqlValueType = - makeRecordPersistableWithSqlTypeWithConfig sqlValueType defaultNameConfig - recordInfo' :: Info -> Maybe ((TypeQ, ExpQ), (Maybe [Name], [TypeQ])) recordInfo' = d where d (TyConI tcon) = do @@ -362,41 +231,29 @@ return (recordInfo' tyConInfo) --- | Generate persistable function symbol names using default rule. -persistableFunctionNamesDefault :: Name -> (VarName, VarName) -persistableFunctionNamesDefault recTypeName = (fromSqlNameDefault bn, toSqlNameDefault bn) where - bn = nameBase recTypeName - --- | All templates depending on SQL value type. Defined record type information is used. -makeRecordPersistableWithSqlTypeFromDefined :: TypeQ -- ^ SQL value type - -> (VarName, VarName) -- ^ Constructor function name and decompose function name - -> Name -- ^ Record type constructor name - -> Q [Dec] -- ^ Result declarations -makeRecordPersistableWithSqlTypeFromDefined sqlValueType fnames recTypeName = do - (conPair, (_, cts)) <- reifyRecordType recTypeName - makeRecordPersistableWithSqlType sqlValueType fnames conPair $ length cts - --- | All templates depending on SQL value type with default names. Defined record type information is used. -makeRecordPersistableWithSqlTypeDefaultFromDefined :: TypeQ -- ^ SQL value type - -> Name -- ^ Record type constructor name - -> Q [Dec] -- ^ Result declarations -makeRecordPersistableWithSqlTypeDefaultFromDefined sqlValueType recTypeName = - makeRecordPersistableWithSqlTypeFromDefined sqlValueType (persistableFunctionNamesDefault recTypeName) recTypeName +-- | Record parser and printer instance templates for converting +-- between list of SQL type and Haskell record type. +definePersistableInstance :: TypeQ -- ^ SQL value type. + -> TypeQ -- ^ Record type constructor. + -> Q [Dec] -- ^ Instance declarations. +definePersistableInstance sqlType typeCon = do + [d| instance FromSql $sqlType $typeCon + instance ToSql $sqlType $typeCon + |] -- | All templates for record type. defineRecord :: TypeQ -- ^ SQL value type - -> (VarName, VarName) -- ^ Constructor function name and decompose function name -> ConName -- ^ Record type name -> [(VarName, TypeQ)] -- ^ Column schema -> [Name] -- ^ Record derivings -> Q [Dec] -- ^ Result declarations defineRecord sqlValueType - fnames tyC + tyC columns drvs = do typ <- defineRecordType tyC columns drvs - withSql <- makeRecordPersistableWithSqlType sqlValueType fnames (toTypeCon tyC, toDataCon tyC) $ length columns + withSql <- definePersistableInstance sqlValueType $ toTypeCon tyC return $ typ ++ withSql -- | All templates for record type with configured names. @@ -409,7 +266,8 @@ -> Q [Dec] -- ^ Result declarations defineRecordWithConfig sqlValueType config schema table columns derives = do typ <- defineRecordTypeWithConfig config schema table columns derives - withSql <- makeRecordPersistableWithSqlTypeWithConfig sqlValueType config schema table $ length columns + withSql <- definePersistableInstance sqlValueType . fst $ recordTemplate config schema table + return $ typ ++ withSql diff --git a/src/Database/Record/ToSql.hs b/src/Database/Record/ToSql.hs --- a/src/Database/Record/ToSql.hs +++ b/src/Database/Record/ToSql.hs @@ -1,10 +1,12 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DefaultSignatures #-} -- | -- Module : Database.Record.ToSql --- Copyright : 2013 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -35,6 +37,7 @@ unsafeUpdateValuesWithIndexes ) where +import GHC.Generics (Generic, Rep, U1 (..), K1 (..), M1 (..), (:*:)(..), from) import Data.Array (listArray, (!)) import Data.Set (toList, fromList, (\\)) import Control.Monad.Trans.Writer (Writer, execWriter, tell) @@ -75,12 +78,21 @@ -> RecordToSql q a -- ^ Result proof object createRecordToSql f = wrapToSql $ tell . DList.fromList . f --- | Derivation rule of 'RecordToSql' proof object for Haskell tuple (,) type. -(<&>) :: RecordToSql q a -> RecordToSql q b -> RecordToSql q (a, b) -ra <&> rb = RecordToSql $ \(a, b) -> do +-- unsafely map record +mapToSql :: (a -> b) -> RecordToSql q b -> RecordToSql q a +mapToSql f x = wrapToSql $ runRecordToSql x . f + +-- unsafely put product record +productToSql :: (c -> (a -> b -> ToSqlM q ()) -> ToSqlM q ()) + -> RecordToSql q a -> RecordToSql q b -> RecordToSql q c +productToSql run ra rb = wrapToSql $ \c -> run c $ \a b -> do runRecordToSql ra a runRecordToSql rb b +-- | Derivation rule of 'RecordToSql' proof object for Haskell tuple (,) type. +(<&>) :: RecordToSql q a -> RecordToSql q b -> RecordToSql q (a, b) +(<&>) = productToSql $ flip uncurry + -- | Derivation rule of 'RecordToSql' proof object for Haskell 'Maybe' type. maybeRecord :: PersistableSqlType q -> PersistableRecordWidth a -> RecordToSql q a -> RecordToSql q (Maybe a) maybeRecord qt w ra = wrapToSql d where @@ -91,24 +103,37 @@ -- | Inference rule interface for 'RecordToSql' proof object. -class PersistableWidth a => ToSql q a where +class ToSql q a where -- | Infer 'RecordToSql' proof object. recordToSql :: RecordToSql q a --- | Inference rule of 'RecordToSql' proof object which can convert --- from Haskell tuple ('a', 'b') type into list of SQL type ['q']. -instance (ToSql q a, ToSql q b) => ToSql q (a, b) where - recordToSql = recordToSql <&> recordToSql + default recordToSql :: (Generic a, GToSql q (Rep a)) => RecordToSql q a + recordToSql = from `mapToSql` gToSql +class GToSql q f where + gToSql :: RecordToSql q (f a) + +instance GToSql q U1 where + gToSql = wrapToSql $ \U1 -> tell DList.empty + +instance (GToSql q a, GToSql q b) => GToSql q (a :*: b) where + gToSql = productToSql (\ (a:*:b) f -> f a b) gToSql gToSql + +instance GToSql q a => GToSql q (M1 i c a) where + gToSql = (\(M1 a) -> a) `mapToSql` gToSql + +instance ToSql q a => GToSql q (K1 i a) where + gToSql = (\(K1 a) -> a) `mapToSql` recordToSql + + -- | Inference rule of 'RecordToSql' proof object which can convert -- from Haskell 'Maybe' type into list of SQL type ['q']. -instance (PersistableType q, ToSql q a) => ToSql q (Maybe a) where +instance (PersistableType q, PersistableWidth a, ToSql q a) => ToSql q (Maybe a) where recordToSql = maybeRecord persistableType persistableWidth recordToSql -- | Inference rule of 'RecordToSql' proof object which can convert -- from Haskell unit () type into /empty/ list of SQL type ['q']. -instance ToSql q () where - recordToSql = wrapToSql $ \() -> tell DList.empty +instance ToSql q () -- default generic instance -- | Run inferred 'RecordToSql' proof object. -- Context to convert haskell record type 'a' into SQL type 'q' list. diff --git a/src/Database/Record/TupleInstances.hs b/src/Database/Record/TupleInstances.hs new file mode 100644 --- /dev/null +++ b/src/Database/Record/TupleInstances.hs @@ -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 --git a/test/Model.hs b/test/Model.hs new file mode 100644 --- /dev/null +++ b/test/Model.hs @@ -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 "" + + +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 --- a/test/nestedEq.hs +++ b/test/nestedEq.hs @@ -1,74 +1,60 @@ {-# OPTIONS -fno-warn-orphans #-} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} -import Control.Applicative ((<$>), (<*>)) import Test.QuickCheck.Simple (defaultMain, eqTest) -import Database.Record - (PersistableType (..), PersistableWidth (..), - FromSql (..), valueRecordFromSql, toRecord, - ToSql (..), valueRecordToSql) -import Database.Record.Persistable - (unsafePersistableSqlTypeFromNull, unsafeValueWidth) - - -instance PersistableType String where - persistableType = unsafePersistableSqlTypeFromNull "" - - -instance FromSql String String where - recordFromSql = valueRecordFromSql id - -instance FromSql String Int where - recordFromSql = valueRecordFromSql read - -instance PersistableWidth String where - persistableWidth = unsafeValueWidth - -instance ToSql String String where - recordToSql = valueRecordToSql id - -instance PersistableWidth Int where - persistableWidth = unsafeValueWidth +import Database.Record (toRecord, fromRecord, persistableWidth, PersistableRecordWidth) +import Database.Record.Persistable (runPersistableRecordWidth) -instance ToSql String Int where - recordToSql = valueRecordToSql show +import Model (User (..), Group (..), Membership (..)) -data User = - User - { uid :: Int - , uname :: String - , note :: String - } deriving (Eq, Show) - -data Group = - Group - { gid :: Int - , gname :: String - } deriving (Eq, Show) - -data Membership = - Membership - { user :: User - , group :: Group - } deriving (Eq, Show) - -instance FromSql String User where - recordFromSql = User <$> recordFromSql <*> recordFromSql <*> recordFromSql - -instance FromSql String Group where - recordFromSql = Group <$> recordFromSql <*> recordFromSql - -instance FromSql String Membership where - recordFromSql = Membership <$> recordFromSql <*> recordFromSql - main :: IO () main = defaultMain [ eqTest - "nestedEq" + "toRecord just" (Membership { user = User { uid = 1, uname = "Kei Hibino", note = "HRR developer" } - , group = Group { gid = 1, gname = "Haskellers" } + , group = Just $ Group { gid = 1, gname = "Haskellers" } } ) - (toRecord ["1", "Kei Hibino", "HRR developer", "1", "Haskellers"]) ] + (toRecord ["1", "Kei Hibino", "HRR developer", "1", "Haskellers"]) + , eqTest + "toRecord nothing" + (Membership { user = User { uid = 1, uname = "Kei Hibino", note = "HRR developer" } + , group = Nothing + } ) + (toRecord ["1", "Kei Hibino", "HRR developer", "", ""]) + , eqTest + "fromRecord just" + (fromRecord $ Membership { user = User { uid = 1, uname = "Kei Hibino", note = "HRR developer" } + , group = Just $ Group { gid = 1, gname = "Haskellers" } + } ) + ["1", "Kei Hibino", "HRR developer", "1", "Haskellers"] + , eqTest + "fromRecord note" + (fromRecord $ Membership { user = User { uid = 1, uname = "Kei Hibino", note = "HRR developer" } + , group = Nothing + } ) + ["1", "Kei Hibino", "HRR developer", "", ""] + + , eqTest + "toRecord pair" + (User { uid = 1, uname = "Kei Hibino", note = "HRR developer" }, + Just $ Group { gid = 1, gname = "Haskellers" }) + (toRecord ["1", "Kei Hibino", "HRR developer", "1", "Haskellers"]) + , eqTest + "fromRecord pair" + (fromRecord $ (User { uid = 1, uname = "Kei Hibino", note = "HRR developer" }, + Just $ Group { gid = 1, gname = "Haskellers" })) + ["1", "Kei Hibino", "HRR developer", "1", "Haskellers"] + , eqTest + "width pair" + (runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth User) + + runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth Group)) + (runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth (User, Group))) + , eqTest + "width record" + (runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth User) + + runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth (Maybe Group))) + (runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth Membership)) + ]