diff --git a/relational-query/src/Database/Relational/Query/Derives.hs b/relational-query/src/Database/Relational/Query/Derives.hs index 31c52134..ba897712 100644 --- a/relational-query/src/Database/Relational/Query/Derives.hs +++ b/relational-query/src/Database/Relational/Query/Derives.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts, Rank2Types #-} -- | -- Module : Database.Relational.Query.Derives @@ -30,7 +30,7 @@ module Database.Relational.Query.Derives ( specifyTableDerivation', specifyTableDerivation, TableDerivable (..), - derivedTable, derivedRelation, derivedInsert, + derivedTable, derivedRelation, derivedInsert, DerivedInsertQuery, derivedInsertQuery, derivedUniqueRelation ) where @@ -50,7 +50,8 @@ import Database.Relational.Query.Constraint (Key, Primary, Unique, projectionKey, uniqueKey, HasConstraintKey(constraintKey)) import qualified Database.Relational.Query.Constraint as Constraint -import Database.Relational.Query.Type (KeyUpdate, typedKeyUpdate, Insert, typedInsert) +import Database.Relational.Query.Type + (KeyUpdate, typedKeyUpdate, Insert, typedInsert, InsertQuery, typedInsertQuery) -- | Query restricted with specified key. @@ -114,21 +115,28 @@ primaryUpdate :: (HasConstraintKey Primary r p) primaryUpdate table' = updateByConstraintKey table' (uniqueKey constraintKey) +type DerivedInsertQuery r = forall p . Relation p r -> InsertQuery p + -- | Capabilities derived from table. data TableDerivation r = TableDerivation - { derivedTable' :: Table r - , derivedRelation' :: Relation () r - , derivedInsert' :: Insert r + { derivedTable' :: Table r + , derivedRelation' :: Relation () r + , derivedInsert' :: Insert r + , derivedInsertQuery' :: DerivedInsertQuery r } -- | Specify properties derived from table. -specifyTableDerivation' :: Table r -> Relation () r -> Insert r -> TableDerivation r +specifyTableDerivation' :: Table r + -> Relation () r + -> Insert r + -> DerivedInsertQuery r + -> TableDerivation r specifyTableDerivation' = TableDerivation -- | Specify properties derived from table. specifyTableDerivation :: Table r -> TableDerivation r -specifyTableDerivation t = specifyTableDerivation' t (table t) (typedInsert t) +specifyTableDerivation t = specifyTableDerivation' t (table t) (typedInsert t) (typedInsertQuery t) -- | Inference rule for 'TableDerivation'. class TableDerivable r where @@ -146,6 +154,10 @@ derivedRelation = derivedRelation' tableDerivation derivedInsert :: TableDerivable r => Insert r derivedInsert = derivedInsert' tableDerivation +-- | Infered 'Insert'. +derivedInsertQuery :: TableDerivable r => DerivedInsertQuery r +derivedInsertQuery = derivedInsertQuery' tableDerivation + -- | 'UniqueRelation' infered from table. derivedUniqueRelation :: TableDerivable r => Key Unique r k -- ^ Unique key proof object which record type is 'a' and key type is 'p'. diff --git a/relational-query/src/Database/Relational/Query/TH.hs b/relational-query/src/Database/Relational/Query/TH.hs index 0d0a9bf4..193fa809 100644 --- a/relational-query/src/Database/Relational/Query/TH.hs +++ b/relational-query/src/Database/Relational/Query/TH.hs @@ -72,7 +72,7 @@ import Database.Record.Instances () import Database.Relational.Query (Table, Pi, Relation, Config, ProductConstructor (..), - sqlFromRelationWith, Query, relationalQuery, KeyUpdate, Insert, + sqlFromRelationWith, Query, relationalQuery, KeyUpdate, Insert, InsertQuery, HasConstraintKey(constraintKey), projectionKey, Primary, NotNull) import Database.Relational.Query.Scalar (defineScalarDegree) @@ -81,8 +81,8 @@ import qualified Database.Relational.Query.Table as Table import Database.Relational.Query.Type (unsafeTypedQuery) import qualified Database.Relational.Query.Pi.Unsafe as UnsafePi import Database.Relational.Query.Derives - (primary, primaryUpdate, TableDerivable (..), TableDerivation, - specifyTableDerivation, derivedTable, derivedRelation, derivedInsert) + (primary, primaryUpdate, TableDerivable (..), TableDerivation, DerivedInsertQuery, + specifyTableDerivation, derivedTable, derivedRelation, derivedInsert, derivedInsertQuery) -- | Rule template to infer constraint key. @@ -187,9 +187,10 @@ defineTableDerivations :: VarName -- ^ TableDerivation declaration variable name -> VarName -- ^ Table declaration variable name -> VarName -- ^ Relation declaration variable name -> VarName -- ^ Insert statement declaration variable name + -> VarName -- ^ InsertQuery statement declaration variable name -> TypeQ -- ^ Record type -> Q [Dec] -- ^ Table and Relation declaration -defineTableDerivations derivationVar' tableVar' relVar' insVar' recordType = do +defineTableDerivations derivationVar' tableVar' relVar' insVar' insQVar' recordType = do let derivationVar = varName derivationVar' derivationDs <- simpleValD derivationVar [t| TableDerivation $recordType |] [| tableDerivation |] @@ -199,23 +200,27 @@ defineTableDerivations derivationVar' tableVar' relVar' insVar' recordType = do let relVar = varName relVar' relDs <- simpleValD relVar [t| Relation () $recordType |] [| derivedRelation |] - let insVar = varName insVar' + let insVar = varName insVar' insDs <- simpleValD insVar [t| Insert $recordType |] [| derivedInsert |] - return $ concat [derivationDs, tableDs, relDs, insDs] + let insQVar = varName insQVar' + insQDs <- simpleValD insQVar [t| DerivedInsertQuery $recordType |] + [| derivedInsertQuery |] + return $ concat [derivationDs, tableDs, relDs, insDs, insQDs] -- | 'Table' and 'Relation' templates. defineTableTypes :: VarName -- ^ TableDerivation declaration variable name -> VarName -- ^ Table declaration variable name -> VarName -- ^ Relation declaration variable name -> VarName -- ^ Insert statement declaration variable name + -> VarName -- ^ InsertQuery statement declaration variable name -> TypeQ -- ^ Record type -> String -- ^ Table name in SQL ex. FOO_SCHEMA.table0 -> [String] -- ^ Column names -> Q [Dec] -- ^ Table and Relation declaration -defineTableTypes derivationVar' tableVar' relVar' insVar' recordType table columns = do +defineTableTypes derivationVar' tableVar' relVar' insVar' insQVar' recordType table columns = do iDs <- defineTableDerivableInstance recordType table columns - dDs <- defineTableDerivations derivationVar' tableVar' relVar' insVar' recordType + dDs <- defineTableDerivations derivationVar' tableVar' relVar' insVar' insQVar' recordType return $ iDs ++ dDs tableSQL :: String -> String -> String @@ -273,6 +278,7 @@ defineTableTypesDefault schema table columns = do (tableVarNameDefault table) (relationVarNameDefault table) (table `varNameWithPrefix` "insert") + (table `varNameWithPrefix` "insertQuery") recordType (tableSQL schema table) (map (fst . fst) columns)