Remove table derivation record cache implementation.

relational-query/src/Database/Relational/Query.hs

@@ -38,7 +38,7 @@ module Database.Relational.Query (
   module Database.Relational.Query.Derives
   ) where
 
-import Database.Relational.Query.Table (Table)
+import Database.Relational.Query.Table (Table, TableDerivable (..))
 import Database.Relational.Query.SQL (updateOtherThanKeySQL, insertSQL)
 import Database.Relational.Query.Pure
 import Database.Relational.Query.Pi
@@ -76,10 +76,9 @@ import Database.Relational.Query.Type
    KeyUpdate, updateKey, untypeKeyUpdate, typedKeyUpdate,
    Update, untypeUpdate, typedUpdate, targetUpdate, updateSQL,
    typedUpdateAllColumn, restrictedUpdateAllColumn,
-   Insert, untypeInsert, typedInsert,
-   InsertQuery, untypeInsertQuery, typedInsertQuery, insertQuerySQL,
+   Insert, untypeInsert, typedInsert, derivedInsert,
+   InsertQuery, untypeInsertQuery, typedInsertQuery, insertQuerySQL, derivedInsertQuery,
    Delete, untypeDelete, typedDelete, restrictedDelete, deleteSQL,
    UntypeableNoFetch (..))
 import Database.Relational.Query.Restriction
 import Database.Relational.Query.Derives
-  hiding (specifyTableDerivation', specifyTableDerivation)

relational-query/src/Database/Relational/Query/Derives.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleContexts, Rank2Types #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 -- |
 -- Module      : Database.Relational.Query.Derives
@@ -26,18 +26,12 @@ module Database.Relational.Query.Derives (
   updateValuesWithKey,
 
   -- * Derived objects from table
-  TableDerivation (..),
-  specifyTableDerivation', specifyTableDerivation,
-
-  TableDerivable (..),
-  derivedTable, derivedRelation, derivedInsert, DerivedInsertQuery, derivedInsertQuery,
-
   derivedUniqueRelation
   ) where
 
 import Database.Record (PersistableWidth, ToSql (recordToSql))
 import Database.Record.ToSql (unsafeUpdateValuesWithIndexes)
-import Database.Relational.Query.Table (Table)
+import Database.Relational.Query.Table (Table, TableDerivable)
 import Database.Relational.Query.Pi.Unsafe (Pi, unsafeExpandIndexes)
 import Database.Relational.Query.Projection (Projection)
 import qualified Database.Relational.Query.Projection as Projection
@@ -45,13 +39,12 @@ import Database.Relational.Query.Projectable (placeholder, (.=.))
 import Database.Relational.Query.ProjectableExtended ((!))
 import Database.Relational.Query.Monad.Class (wheres)
 import Database.Relational.Query.Relation
-  (Relation, relation, relation', query, table, UniqueRelation, unsafeUnique)
+  (Relation, derivedRelation, relation, relation', query, UniqueRelation, unsafeUnique)
 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, InsertQuery, typedInsertQuery)
+import Database.Relational.Query.Type (KeyUpdate, typedKeyUpdate)
 
 
 -- | Query restricted with specified key.
@@ -114,51 +107,6 @@ primaryUpdate :: (HasConstraintKey Primary r p)
               -> KeyUpdate p r -- ^ Result typed 'Update'
 primaryUpdate table' = updateByConstraintKey table' (uniqueKey constraintKey)
 
-
--- | Type for insert qeury.
-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
-  , derivedInsertQuery' :: DerivedInsertQuery r
-  }
-
--- | Specify properties derived from table.
-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) (typedInsertQuery t)
-
--- | Inference rule for 'TableDerivation'.
-class TableDerivable r where
-  tableDerivation :: TableDerivation r
-
--- | Infered 'Table'.
-derivedTable :: TableDerivable r => Table r
-derivedTable =  derivedTable' tableDerivation
-
--- | Infered 'Relation'.
-derivedRelation :: TableDerivable r => Relation () r
-derivedRelation =  derivedRelation' tableDerivation
-
--- | Infered 'Insert'.
-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'.

relational-query/src/Database/Relational/Query/Relation.hs

@@ -15,7 +15,7 @@ module Database.Relational.Query.Relation (
   -- * Relation type
   Relation,
 
-  table,
+  table, derivedRelation,
   relation, relation',
   aggregateRelation, aggregateRelation',
 
@@ -60,7 +60,7 @@ import Database.Relational.Query.Monad.Unique (QueryUnique)
 import qualified Database.Relational.Query.Monad.Unique as Unique
 
 import Database.Relational.Query.Component (columnSQL, Config, defaultConfig, Duplication (Distinct, All))
-import Database.Relational.Query.Table (Table)
+import Database.Relational.Query.Table (Table, TableDerivable, derivedTable)
 import Database.Relational.Query.Internal.SQL (StringSQL)
 import Database.Relational.Query.Internal.Product (NodeAttr(Just', Maybe))
 import Database.Relational.Query.Sub (SubQuery)
@@ -84,6 +84,10 @@ newtype Relation p r = SubQuery (ConfigureQuery SubQuery)
 table :: Table r -> Relation () r
 table =  SubQuery . return . SubQuery.fromTable
 
+-- | Infered 'Relation'.
+derivedRelation :: TableDerivable r => Relation () r
+derivedRelation =  table derivedTable
+
 placeHoldersFromRelation :: Relation p r -> PlaceHolders p
 placeHoldersFromRelation =  const unsafePlaceHolders
 

relational-query/src/Database/Relational/Query/TH.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ExplicitForAll #-}
 
 -- |
 -- Module      : Database.Relational.Query.TH
@@ -79,18 +80,18 @@ import Database.Record.Instances ()
 
 import Database.Relational.Query
   (Table, Pi, Relation, Config, ProductConstructor (..),
-   relationalQuerySQL, Query, relationalQuery, KeyUpdate, Insert,
-   HasConstraintKey(constraintKey), projectionKey, Primary, NotNull)
+   relationalQuerySQL, Query, relationalQuery, KeyUpdate,
+   Insert, derivedInsert, InsertQuery, derivedInsertQuery,
+   HasConstraintKey(constraintKey), projectionKey, Primary, NotNull, primary, primaryUpdate)
 
 import Database.Relational.Query.Scalar (defineScalarDegree)
 import Database.Relational.Query.Constraint (Key, unsafeDefineConstraintKey)
+import Database.Relational.Query.Table (TableDerivable (..))
 import qualified Database.Relational.Query.Table as Table
+import Database.Relational.Query.Relation (derivedRelation)
 import Database.Relational.Query.SQL (QuerySuffix)
 import Database.Relational.Query.Type (unsafeTypedQuery)
 import qualified Database.Relational.Query.Pi.Unsafe as UnsafePi
-import Database.Relational.Query.Derives
-  (primary, primaryUpdate, TableDerivable (..), TableDerivation, DerivedInsertQuery,
-   specifyTableDerivation, derivedTable, derivedRelation, derivedInsert, derivedInsertQuery)
 
 
 -- | Rule template to infer constraint key.
@@ -186,22 +187,17 @@ defineColumnDefault mayConstraint recType name =
 defineTableDerivableInstance :: TypeQ -> String -> [String] -> Q [Dec]
 defineTableDerivableInstance recordType table columns =
   [d| instance TableDerivable $recordType where
-        tableDerivation = specifyTableDerivation
-                          (Table.table $(stringE table) $(listE $ map stringE columns))
+        derivedTable = Table.table $(stringE table) $(listE $ map stringE columns)
     |]
 
 -- | Template to define infered entries from table type.
-defineTableDerivations :: VarName -- ^ TableDerivation declaration variable name
-                       -> VarName -- ^ Table declaration variable name
+defineTableDerivations :: 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' insQVar' recordType = do
-  let derivationVar = varName derivationVar'
-  derivationDs <- simpleValD derivationVar [t| TableDerivation $recordType |]
-                  [| tableDerivation |]
+defineTableDerivations tableVar' relVar' insVar' insQVar' recordType = do
   let tableVar = varName tableVar'
   tableDs <- simpleValD tableVar [t| Table $recordType |]
              [| derivedTable |]
@@ -212,13 +208,12 @@ defineTableDerivations derivationVar' tableVar' relVar' insVar' insQVar' recordT
   insDs   <- simpleValD insVar   [t| Insert $recordType |]
              [| derivedInsert |]
   let insQVar  = varName insQVar'
-  insQDs  <- simpleValD insQVar  [t| DerivedInsertQuery $recordType |]
+  insQDs  <- simpleValD insQVar  [t| forall p . Relation p $recordType -> InsertQuery p |]
              [| derivedInsertQuery |]
-  return $ concat [derivationDs, tableDs, relDs, insDs, insQDs]
+  return $ concat [tableDs, relDs, insDs, insQDs]
 
 -- | 'Table' and 'Relation' templates.
-defineTableTypes :: VarName  -- ^ TableDerivation declaration variable name
-                 -> VarName  -- ^ Table declaration variable name
+defineTableTypes :: VarName  -- ^ Table declaration variable name
                  -> VarName  -- ^ Relation declaration variable name
                  -> VarName  -- ^ Insert statement declaration variable name
                  -> VarName  -- ^ InsertQuery statement declaration variable name
@@ -226,9 +221,9 @@ defineTableTypes :: VarName  -- ^ TableDerivation declaration variable name
                  -> String   -- ^ Table name in SQL ex. FOO_SCHEMA.table0
                  -> [String] -- ^ Column names
                  -> Q [Dec]  -- ^ Table and Relation declaration
-defineTableTypes derivationVar' tableVar' relVar' insVar' insQVar' recordType table columns = do
+defineTableTypes tableVar' relVar' insVar' insQVar' recordType table columns = do
   iDs <- defineTableDerivableInstance recordType table columns
-  dDs <- defineTableDerivations derivationVar' tableVar' relVar' insVar' insQVar' recordType
+  dDs <- defineTableDerivations tableVar' relVar' insVar' insQVar' recordType
   return $ iDs ++ dDs
 
 tableSQL :: String -> String -> String
@@ -282,7 +277,6 @@ defineTableTypesDefault :: String                           -- ^ Schema name
 defineTableTypesDefault schema table columns = do
   let recordType = recordTypeDefault table
   tableDs <- defineTableTypes
-             (derivationVarNameDefault table)
              (tableVarNameDefault table)
              (relationVarNameDefault table)
              (table `varNameWithPrefix` "insert")

relational-query/src/Database/Relational/Query/Table.hs

@@ -14,6 +14,9 @@ module Database.Relational.Query.Table (
 
   -- * Phantom typed table type
   Table, unType, name, shortName, width, columns, index, table, toMaybe,
+
+  -- * Table existence inference
+  TableDerivable (..)
   ) where
 
 import Data.Array (Array, listArray, elems)
@@ -86,3 +89,7 @@ table :: String -> [String] -> Table r
 table n f = Table $ Untyped n w fa  where
   w  = length f
   fa = listArray (0, w - 1) $ map columnSQL f
+
+-- | Inference rule of 'Table' existence.
+class TableDerivable r where
+  derivedTable :: Table r

relational-query/src/Database/Relational/Query/Type.hs

@@ -24,8 +24,8 @@ module Database.Relational.Query.Type (
   updateSQL,
 
   -- * Typed insert statement
-  Insert (..), unsafeTypedInsert, typedInsert,
-  InsertQuery (..), unsafeTypedInsertQuery, typedInsertQuery,
+  Insert (..), unsafeTypedInsert, typedInsert, derivedInsert,
+  InsertQuery (..), unsafeTypedInsertQuery, typedInsertQuery, derivedInsertQuery,
 
   insertQuerySQL,
 
@@ -50,7 +50,7 @@ import Database.Relational.Query.Restriction
    sqlWhereFromRestriction, sqlFromUpdateTarget)
 import Database.Relational.Query.Pi (Pi)
 import Database.Relational.Query.Component (Config, defaultConfig)
-import Database.Relational.Query.Table (Table)
+import Database.Relational.Query.Table (Table, TableDerivable, derivedTable)
 import Database.Relational.Query.SQL
   (QuerySuffix, showsQuerySuffix,
    updateOtherThanKeySQL, insertPrefixSQL, insertSQL, updatePrefixSQL, deletePrefixSQL)
@@ -154,6 +154,10 @@ unsafeTypedInsert =  Insert
 typedInsert :: Table r -> Insert r
 typedInsert =  unsafeTypedInsert . insertSQL
 
+-- | Infered 'Insert'.
+derivedInsert :: TableDerivable r => Insert r
+derivedInsert =  typedInsert derivedTable
+
 -- | Show insert SQL string.
 instance Show (Insert a) where
   show = untypeInsert
@@ -173,6 +177,10 @@ insertQuerySQL config tbl rel = showStringSQL $ insertPrefixSQL tbl <> sqlFromRe
 typedInsertQuery :: Table r -> Relation p r -> InsertQuery p
 typedInsertQuery tbl rel = unsafeTypedInsertQuery $ insertQuerySQL defaultConfig tbl rel
 
+-- | Infered 'InsertQuery'.
+derivedInsertQuery :: TableDerivable r => Relation p r -> InsertQuery p
+derivedInsertQuery =  typedInsertQuery derivedTable
+
 -- | Show insert SQL string.
 instance Show (InsertQuery p) where
   show = untypeInsertQuery