Derive schema from table definition

Test/QuickCheck.hs

@@ -21,11 +21,11 @@ import qualified Control.Arrow as Arrow
 
 twoIntTable :: String
             -> O.Table (O.Column O.PGInt4, O.Column O.PGInt4)
-                       (O.Column O.PGInt4, O.Column O.PGInt4)
+                       (O.TableColumn O.PGInt4, O.TableColumn O.PGInt4)
 twoIntTable n = O.Table n (PP.p2 (O.required "column1", O.required "column2"))
 
 table1 :: O.Table (O.Column O.PGInt4, O.Column O.PGInt4)
-                  (O.Column O.PGInt4, O.Column O.PGInt4)
+                  (O.TableColumn O.PGInt4, O.TableColumn O.PGInt4)
 table1 = twoIntTable "table1"
 
 data QueryDenotation a =

Test/Test.hs

@@ -123,43 +123,43 @@ ways.
 -}
 
 twoIntTable :: String
-            -> O.Table (Column O.PGInt4, Column O.PGInt4) (Column O.PGInt4, Column O.PGInt4)
+            -> O.Table (Column O.PGInt4, Column O.PGInt4) (O.TableColumn O.PGInt4, O.TableColumn O.PGInt4)
 twoIntTable n = O.Table n (PP.p2 (O.required "column1", O.required "column2"))
 
-table1 :: O.Table (Column O.PGInt4, Column O.PGInt4) (Column O.PGInt4, Column O.PGInt4)
+table1 :: O.Table (Column O.PGInt4, Column O.PGInt4) (O.TableColumn O.PGInt4, O.TableColumn O.PGInt4)
 table1 = twoIntTable "table1"
 
-table1F :: O.Table (Column O.PGInt4, Column O.PGInt4) (Column O.PGInt4, Column O.PGInt4)
+table1F :: O.Table (Column O.PGInt4, Column O.PGInt4) (O.TableColumn O.PGInt4, O.TableColumn O.PGInt4)
 table1F = fmap (\(col1, col2) -> (col1 + col2, col1 - col2)) table1
 
 -- This is implicitly testing our ability to handle upper case letters in table names.
-table2 :: O.Table (Column O.PGInt4, Column O.PGInt4) (Column O.PGInt4, Column O.PGInt4)
+table2 :: O.Table (Column O.PGInt4, Column O.PGInt4) (O.TableColumn O.PGInt4, O.TableColumn O.PGInt4)
 table2 = twoIntTable "TABLE2"
 
-table3 :: O.Table (Column O.PGInt4, Column O.PGInt4) (Column O.PGInt4, Column O.PGInt4)
+table3 :: O.Table (Column O.PGInt4, Column O.PGInt4) (O.TableColumn O.PGInt4, O.TableColumn O.PGInt4)
 table3 = twoIntTable "table3"
 
-table4 :: O.Table (Column O.PGInt4, Column O.PGInt4) (Column O.PGInt4, Column O.PGInt4)
+table4 :: O.Table (Column O.PGInt4, Column O.PGInt4) (O.TableColumn O.PGInt4, O.TableColumn O.PGInt4)
 table4 = twoIntTable "table4"
 
 table5 :: O.Table (Maybe (Column O.PGInt4), Maybe (Column  O.PGInt4))
-                  (Column O.PGInt4, Column O.PGInt4)
+                  (O.TableColumn O.PGInt4, O.TableColumn O.PGInt4)
 table5 = O.TableWithSchema "public" "table5" (PP.p2 (O.optional "column1", O.optional "column2"))
 
-table6 :: O.Table (Column O.PGText, Column O.PGText) (Column O.PGText, Column O.PGText)
+table6 :: O.Table (Column O.PGText, Column O.PGText) (O.TableColumn O.PGText, O.TableColumn O.PGText)
 table6 = O.Table "table6" (PP.p2 (O.required "column1", O.required "column2"))
 
-table7 :: O.Table (Column O.PGText, Column O.PGText) (Column O.PGText, Column O.PGText)
+table7 :: O.Table (Column O.PGText, Column O.PGText) (O.TableColumn O.PGText, O.TableColumn O.PGText)
 table7 = O.Table "table7" (PP.p2 (O.required "column1", O.required "column2"))
 
-table8 :: O.Table (Column O.PGJson) (Column O.PGJson)
+table8 :: O.Table (Column O.PGJson) (O.TableColumn O.PGJson)
 table8 = O.Table "table8" (O.required "column1")
 
-table9 :: O.Table (Column O.PGJsonb) (Column O.PGJsonb)
+table9 :: O.Table (Column O.PGJsonb) (O.TableColumn O.PGJsonb)
 table9 = O.Table "table9" (O.required "column1")
 
 tableKeywordColNames :: O.Table (Column O.PGInt4, Column O.PGInt4)
-                                (Column O.PGInt4, Column O.PGInt4)
+                                (O.TableColumn O.PGInt4, O.TableColumn O.PGInt4)
 tableKeywordColNames = O.Table "keywordtable" (PP.p2 (O.required "column", O.required "where"))
 
 table1Q :: Query (Column O.PGInt4, Column O.PGInt4)

opaleye.cabal

@@ -80,6 +80,7 @@ library
                    Opaleye.Internal.Print,
                    Opaleye.Internal.QueryArr,
                    Opaleye.Internal.RunQuery,
+                   Opaleye.Internal.Schema ,
                    Opaleye.Internal.Sql,
                    Opaleye.Internal.Table,
                    Opaleye.Internal.TableMaker,

src/Opaleye/Internal/Schema.hs

@@ -0,0 +1,122 @@
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Opaleye.Internal.Schema where
+
+import           Opaleye.Internal.Column
+import           Opaleye.Internal.Table as IT
+import           Opaleye.Internal.TableMaker as TM
+import           Opaleye.Internal.PackMap as PM
+import           Opaleye.PGTypes
+
+import           Data.Profunctor (Profunctor, dimap, lmap)
+import           Data.Profunctor.Product as PP
+
+import Data.Monoid
+
+import qualified Data.Profunctor.Product.Default as D
+
+class PGType a where
+  data SchemaOptions a
+  pgColumnDefinition :: SchemaOptions a -> String
+  defaultOptions :: SchemaOptions a
+
+instance PGType PGInt4 where
+  data SchemaOptions PGInt4 = NoIntOptions2
+  pgColumnDefinition _ = "SERIAL"
+  defaultOptions = NoIntOptions2
+
+instance PGType PGJson where
+  data SchemaOptions PGJson = NoJsonOpts
+  pgColumnDefinition _ = "json"
+  defaultOptions = NoJsonOpts
+
+instance PGType PGJsonb where
+  data SchemaOptions PGJsonb = NoJsonbOpts
+  pgColumnDefinition _ = "json"
+  defaultOptions = NoJsonbOpts
+
+instance PGType PGInt8 where
+  data SchemaOptions PGInt8 = NoIntOptions
+  pgColumnDefinition _ = "SERIAL"
+  defaultOptions = NoIntOptions
+
+instance PGType PGText where
+  data SchemaOptions PGText = Length Int | Unspecified
+  pgColumnDefinition (Length x) = "varchar (" <> show x <> ")"
+  pgColumnDefinition _ = "text"
+  defaultOptions = Unspecified
+
+data TableSchema = TableSchema String [UntypedColumn]
+
+newtype UntypedColumn = UntypedColumn { unUntypedColumn :: forall a. TM.TableColumn a }
+
+discardSchema :: IT.Table a b -> (String, IT.TableProperties a b)
+discardSchema (IT.TableWithSchema _ s p) = (s, p)
+discardSchema (IT.Table s p) = (s, p)
+
+tableSchema :: forall read write.
+  (D.Default SchemaMaker read write) =>
+  IT.Table write read -> TableSchema
+tableSchema (discardSchema -> (tableName, (IT.TableProperties _ (View tableColumns)))) =
+  TableSchema tableName columns
+  where
+  s :: SchemaMaker read write
+  s = D.def
+  SchemaMaker (PM.PackMap pm) = s
+  extractor d = ([d], ())
+  (columns, ()) = pm extractor tableColumns
+
+data ForeignKey = ForeignKey [String] [String]
+
+foreignKey ::
+  forall from from' to to' fk.
+  (D.Default SchemaMaker fk fk) =>
+  IT.Table from' from -> (from -> fk) -> IT.Table to' to -> (to -> fk) -> ForeignKey
+foreignKey tableFrom selectSubsetFrom tableTo selectSubsetTo = let
+  extractor (unUntypedColumn -> TM.TableColumn name' _) = ([name'], ())
+  (snd . discardSchema -> (IT.TableProperties _ (View tableColsFrom))) = tableFrom
+  (snd . discardSchema -> (IT.TableProperties _ (View tableColsTo))) = tableTo
+  keyFrom = selectSubsetFrom tableColsFrom
+  keyTo = selectSubsetTo tableColsTo
+  s1 :: SchemaMaker fk fk
+  s1 = D.def
+  (SchemaMaker (PM.PackMap pm)) = s1
+  (columnsFrom, ()) = pm extractor keyFrom
+  (columnsTo, ()) = pm extractor keyTo
+  in ForeignKey columnsFrom columnsTo
+
+columnSchemaMaker :: SchemaMaker (TM.TableColumn any) b
+columnSchemaMaker = SchemaMaker (PM.PackMap (\f (TM.TableColumn x y) -> f (UntypedColumn (TM.TableColumn x y))))
+
+instance D.Default SchemaMaker (TM.TableColumn a) (Column a) where
+  def = columnSchemaMaker
+
+instance D.Default SchemaMaker (TM.TableColumn a) (TM.TableColumn a) where
+  def = columnSchemaMaker
+
+instance D.Default SchemaMaker (TM.TableColumn a) (Maybe (Column a)) where
+  def = columnSchemaMaker
+
+newtype SchemaMaker read dummy =
+  SchemaMaker (PM.PackMap UntypedColumn () read ())
+
+instance Functor (SchemaMaker a) where
+  fmap _ (SchemaMaker g) = SchemaMaker (g)
+
+instance Applicative (SchemaMaker a) where
+  pure x = SchemaMaker (fmap (const ()) (pure x))
+  SchemaMaker fx <*> SchemaMaker x = SchemaMaker $
+    pure (const id) <*> fx <*> x
+
+instance Profunctor SchemaMaker where
+  dimap f _ (SchemaMaker q) = SchemaMaker (lmap f q)
+
+instance ProductProfunctor SchemaMaker where
+  empty = PP.defaultEmpty
+  (***!) = PP.defaultProfunctorProduct

src/Opaleye/Internal/Table.hs

@@ -79,16 +79,21 @@ newtype Writer columns dummy =
   Writer (forall f. Functor f =>
           PM.PackMap (f HPQ.PrimExpr, String) () (f columns) ())
 
-queryTable :: TM.ColumnMaker viewColumns columns
-            -> Table writerColumns viewColumns
+queryTable :: TM.ColumnMaker columns columns
+            -> TM.TableProjector tableColumns columns
+            -> Table writerColumns tableColumns
             -> Tag.Tag
             -> (columns, PQ.PrimQuery)
-queryTable cm table tag = (primExprs, primQ) where
+queryTable cm tp table tag = (primExprs, primQ) where
   View tableCols = tablePropertiesView (tableProperties table)
-  (primExprs, projcols) = runColumnMaker cm tag tableCols
+  viewCols = runTableProjector tp tableCols
+  (primExprs, projcols) = runColumnMaker cm tag viewCols
   primQ :: PQ.PrimQuery
   primQ = PQ.BaseTable (tableIdentifier table) projcols
 
+runTableProjector :: TM.TableProjector tableColumns columns -> tableColumns -> columns
+runTableProjector (TM.TableProjector f) tc = (I.runIdentity . f) tc
+
 runColumnMaker :: TM.ColumnMaker tablecolumns columns
                   -> Tag.Tag
                   -> tablecolumns
@@ -127,11 +132,11 @@ instance Monoid (Zip a) where
     where mempty' = [] `NEL.cons` mempty'
   Zip xs `mappend` Zip ys = Zip (NEL.zipWith (++) xs ys)
 
-required :: String -> Writer (Column a) (Column a)
+required :: String -> Writer (Column a) (TM.TableColumn a)
 required columnName =
   Writer (PM.PackMap (\f columns -> f (fmap unColumn columns, columnName)))
 
-optional :: String -> Writer (Maybe (Column a)) (Column a)
+optional :: String -> Writer (Maybe (Column a)) (TM.TableColumn a)
 optional columnName =
   Writer (PM.PackMap (\f columns -> f (fmap maybeUnColumn columns, columnName)))
   where maybeUnColumn Nothing = HPQ.DefaultInsertExpr

src/Opaleye/Internal/TableMaker.hs

@@ -15,6 +15,8 @@ import           Control.Applicative (Applicative, pure, (<*>))
 
 import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ
 
+import qualified Data.Functor.Identity as I
+
 
 -- If we switch to a more lens-like approach to PackMap this should be
 -- the equivalent of a Setter
@@ -24,6 +26,12 @@ newtype ViewColumnMaker strings columns =
 newtype ColumnMaker columns columns' =
   ColumnMaker (PM.PackMap HPQ.PrimExpr HPQ.PrimExpr columns columns')
 
+data TableColumn a = TableColumn {
+  name :: String ,
+  columnDefinition :: String }
+
+newtype TableProjector columns columns' = TableProjector (columns -> I.Identity columns')
+
 runViewColumnMaker :: ViewColumnMaker strings tablecolumns ->
                        strings -> tablecolumns
 runViewColumnMaker (ViewColumnMaker f) = PM.overPM f id
@@ -45,12 +53,18 @@ column = ColumnMaker
          (PM.PackMap (\f (IC.Column s)
                       -> fmap IC.Column (f s)))
 
+tableProjector :: TableProjector (TableColumn a) (IC.Column a)
+tableProjector = TableProjector (\(TableColumn name' _) -> (I.Identity . IC.Column . HPQ.BaseTableAttrExpr) name')
+
 instance Default ViewColumnMaker String (C.Column a) where
   def = tableColumn
 
 instance Default ColumnMaker (C.Column a) (C.Column a) where
   def = column
 
+instance Default TableProjector (TableColumn a) (IC.Column a) where
+  def = tableProjector
+
 -- {
 
 -- Boilerplate instance definitions.  Theoretically, these are derivable.
@@ -83,4 +97,18 @@ instance ProductProfunctor ColumnMaker where
   empty = PP.defaultEmpty
   (***!) = PP.defaultProfunctorProduct
 
+instance Functor (TableProjector a) where
+  fmap f (TableProjector g) = TableProjector ((fmap . fmap) f g)
+
+instance Applicative (TableProjector a) where
+  pure b = TableProjector ((const . I.Identity) b)
+  TableProjector b <*> TableProjector c = TableProjector (\a -> b a <*> c a)
+
+instance Profunctor TableProjector where
+  dimap f g (TableProjector q) = TableProjector (dimap f (fmap g) q)
+
+instance ProductProfunctor TableProjector where
+  empty = PP.defaultEmpty
+  (***!) = PP.defaultProfunctorProduct
+
 --}