diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ +## 0.11.1.0 + +- add compatibility module Database.Relational.Query.TH for upgrading from 0.9. + ## 0.11.0.0 - same as 0.10.1.1. re-versioned for TH incompatibility against 0.10.0. @@ -10,7 +14,7 @@ ## 0.10.1.0 -- define projections with overloaded-labels. +- define projections with overloaded-labels. -- Thanks for Ryan Mulligan - add a portable sequence number operation. ## 0.10.0.0 diff --git a/relational-query.cabal b/relational-query.cabal --- a/relational-query.cabal +++ b/relational-query.cabal @@ -1,5 +1,5 @@ name: relational-query -version: 0.11.0.0 +version: 0.11.1.0 synopsis: Typeful, Modular, Relational, algebraic query engine description: This package contiains typeful relation structure and relational-algebraic query building DSL which can @@ -70,9 +70,11 @@ Database.Relational.Derives Database.Relational.TH + -- definitions and namespaces compatible with <= 0.9 Database.Relational.Compat Database.Relational.Query Database.Relational.Query.Arrow + Database.Relational.Query.TH -- for GHC version equal or more than 8.0 Database.Relational.OverloadedProjection diff --git a/src/Database/Relational/Config.hs b/src/Database/Relational/Config.hs --- a/src/Database/Relational/Config.hs +++ b/src/Database/Relational/Config.hs @@ -16,4 +16,4 @@ import Database.Relational.Internal.Config (NameConfig (..), ProductUnitSupport (..), SchemaNameMode (..), IdentifierQuotation (..), - Config (..), defaultConfig,) + Config (..), defaultConfig, defaultNameConfig) diff --git a/src/Database/Relational/Internal/Config.hs b/src/Database/Relational/Internal/Config.hs --- a/src/Database/Relational/Internal/Config.hs +++ b/src/Database/Relational/Internal/Config.hs @@ -9,18 +9,27 @@ -- -- This module defines configuration datatype used in query products. module Database.Relational.Internal.Config ( + Config, + + defaultConfig, + + {- field labels of 'Config' type. + To avoid haddock bug ( https://github.com/haskell/haddock/issues/456 ), + they are not listed in Config ( ... ). -} + productUnitSupport, + chunksInsertSize, + schemaNameMode, + normalizedTableName, + verboseAsCompilerWarning, + disableOverloadedProjection, + disableSpecializedProjection, + identifierQuotation, + nameConfig, + NameConfig (..), + defaultNameConfig, + ProductUnitSupport (..), SchemaNameMode (..), IdentifierQuotation (..), - Config ( productUnitSupport - , chunksInsertSize - , schemaNameMode - , normalizedTableName - , verboseAsCompilerWarning - , disableOverloadedProjection - , disableSpecializedProjection - , identifierQuotation - , nameConfig), - defaultConfig, ) where import Language.Haskell.TH.Name.CamelCase (VarName, varCamelcaseName) @@ -31,12 +40,24 @@ data NameConfig = NameConfig { recordConfig :: RecordTH.NameConfig + -- ^ Configurations related to the names of generated record types + -- and their field labels. , relationVarName :: String -> String -> VarName + -- ^ Function to build the name of 'Database.Relational.Monad.BaseType.Relation' representing the table. + -- The first argument is the scheme name, and second argument is the table name. } instance Show NameConfig where show = const "" +-- | Default implementation of 'NameConfig' type. +defaultNameConfig :: NameConfig +defaultNameConfig = + NameConfig + { recordConfig = RecordTH.defaultNameConfig + , relationVarName = const varCamelcaseName + } + -- | Unit of product is supported or not. data ProductUnitSupport = PUSupported | PUNotSupported deriving Show @@ -56,14 +77,39 @@ , chunksInsertSize :: !Int , schemaNameMode :: !SchemaNameMode , normalizedTableName :: !Bool + -- ^ If True, schema names become uppercase, and table names become lowercase. , verboseAsCompilerWarning :: !Bool + -- ^ If True, more detailed logs are printed when generating record types from schema. , disableOverloadedProjection :: !Bool + -- ^ If True, instance of 'Database.Relational.OverloadedProjection.HasProjection' for each column is NOT generated. , disableSpecializedProjection :: !Bool + -- ^ If True, 'Database.Relational.Pi.Pi' for each column is NOT generated. , identifierQuotation :: !IdentifierQuotation , nameConfig :: !NameConfig } deriving Show --- | Default configuration. +-- | Default configuration of 'Config'. +-- To change some behaviour of relational-query, +-- use record update syntax: +-- +-- @ +-- defaultConfig +-- { productUnitSupport = 'PUSupported' +-- , chunksInsertSize = 256 +-- , schemaNameMode = 'SchemaQualified' +-- , normalizedTableName = True +-- , verboseAsCompilerWarning = False +-- , disableOverloadedProjection = False +-- , disableSpecializedProjection = False +-- , identifierQuotation = 'NoQuotation' +-- , nameConfig = +-- defaultNameConfig +-- { recordConfig = 'RecordTH.defaultNameConfig' +-- , relationVarName = \\schema table -> 'varCamelcaseName' $ table ++ "_" ++ scheme +-- -- ^ append the table name after the schema name. e.g. "schemaTable" +-- } +-- } +-- @ defaultConfig :: Config defaultConfig = Config { productUnitSupport = PUSupported @@ -74,7 +120,5 @@ , disableOverloadedProjection = False , disableSpecializedProjection = False , identifierQuotation = NoQuotation - , nameConfig = NameConfig { recordConfig = RecordTH.defaultNameConfig - , relationVarName = const varCamelcaseName - } + , nameConfig = defaultNameConfig } diff --git a/src/Database/Relational/Query/TH.hs b/src/Database/Relational/Query/TH.hs new file mode 100644 --- /dev/null +++ b/src/Database/Relational/Query/TH.hs @@ -0,0 +1,17 @@ +-- | +-- Module : Database.Relational.Query.TH +-- Copyright : 2018 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module contains backword compatibility interface of +-- relational-query <= 0.9.* +module Database.Relational.Query.TH + {-# DEPRECATED "Should switch namespace to Database.Relational.TH" #-} + ( module Database.Relational.TH + ) where + +import Database.Relational.TH diff --git a/src/Database/Relational/Sequence.hs b/src/Database/Relational/Sequence.hs --- a/src/Database/Relational/Sequence.hs +++ b/src/Database/Relational/Sequence.hs @@ -1,10 +1,11 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DefaultSignatures #-} -- | -- Module : Database.Relational.Sequence --- Copyright : 2017 Kei Hibino +-- Copyright : 2017-2018 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -13,9 +14,12 @@ -- -- This module provides structures about sequence tables. module Database.Relational.Sequence ( - Sequence (..), seqRelation, + Sequence, seqTable, seqExtract, seqKey, seqRelation, unsafeSpecifySequence, + SeqBinding, boundTable, boundKey, boundSequence, + unsafeSpecifyBinding, primaryBinding, + SequenceDerivable (..), Binding (..), fromRelation, @@ -34,6 +38,8 @@ import Database.Relational.Monad.Trans.Assigning ((<-#)) import Database.Relational.Table (TableDerivable, derivedTable, Table) import Database.Relational.Pi (Pi) +import Database.Relational.Constraint + (HasConstraintKey (..), Key, Primary, projectionKey) import Database.Relational.Projectable ((.<=.), value, unitPlaceHolder, (!)) import Database.Relational.ProjectableClass (ShowConstantTermsSQL) import Database.Relational.Relation (tableOf) @@ -42,12 +48,14 @@ import Database.Relational.Type (Update, typedUpdate) --- | Basic record to express sequence table +-- | Basic record to express sequence-table. +-- actual sequence-table is a table which has only one column +-- of integer type. data Sequence s i = Sequence - { seqTable :: Table s - , seqExtract :: s -> i - , seqKey :: Pi s i + { seqTable :: Table s -- ^ actual sequence-table + , seqExtract :: s -> i -- ^ sequence number selector for sequence record + , seqKey :: Pi s i -- ^ sequence number projection for sequence record } -- | Unsafely specify sequence table. @@ -62,11 +70,38 @@ class TableDerivable s => SequenceDerivable s i | s -> i where derivedSequence :: Sequence s i +-- | Record to express binding between normal-table and sequence-table. +data SeqBinding r s i = + SeqBinding + { boundTable :: Table r -- ^ normal-table bound to sequence-table + , boundKey :: Pi r i -- ^ sequence key projection for bound record + , boundSequence :: Sequence s i -- ^ sequence table record + } + +-- | Unsafely specify binding between normal-table and sequence-table. +unsafeSpecifyBinding :: (TableDerivable r, SequenceDerivable s i) + => Pi r i -> SeqBinding r s i +unsafeSpecifyBinding k = SeqBinding derivedTable k derivedSequence + +-- | Derive binding using primary key. +primaryBinding :: (TableDerivable r, SequenceDerivable s i, + HasConstraintKey Primary r i) + => SeqBinding r s i +primaryBinding = unsafeSpecifyBinding $ primaryKey constraintKey + where + primaryKey :: Key Primary r ct -> Pi r ct + primaryKey = projectionKey + -- | Derivation rule for binding between 'Table' and 'Sequence' class (TableDerivable r, SequenceDerivable s i) => Binding r s i | r -> s where - fromTable :: Table r -> Sequence s i - fromTable = const derivedSequence + binding :: SeqBinding r s i + + default binding :: HasConstraintKey Primary r i => SeqBinding r s i + binding = primaryBinding + +fromTable :: Binding r s i => Table r -> Sequence s i +fromTable = const derivedSequence -- | Derive 'Sequence' from corresponding 'Relation' fromRelation :: Binding r s i diff --git a/src/Database/Relational/TH.hs b/src/Database/Relational/TH.hs --- a/src/Database/Relational/TH.hs +++ b/src/Database/Relational/TH.hs @@ -77,7 +77,7 @@ import Language.Haskell.TH.Compat.Reify (unVarI) import Language.Haskell.TH.Name.CamelCase (VarName, varName, ConName (ConName), conName, - varNameWithPrefix, varCamelcaseName, toVarExp, toTypeCon) + varCamelcaseName, toVarExp, toTypeCon) import Language.Haskell.TH.Lib.Extra (simpleValD, maybeD, integralE) import Database.Record.TH @@ -258,6 +258,9 @@ quote NoQuotation s = s quote (Quotation q) s = q : (escape s) ++ q : [] where escape = (>>= (\c -> if c == q then [q, q] else [c])) + +varNameWithPrefix :: String -> String -> VarName +varNameWithPrefix n p = varCamelcaseName $ p ++ "_" ++ n derivationVarNameDefault :: String -> VarName derivationVarNameDefault = (`varNameWithPrefix` "derivationFrom")