wip #37

src/Opaleye/Internal/Table.hs

@@ -113,11 +113,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,12 @@ import           Control.Applicative (Applicative, pure, (<*>))
 
 import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ
 
+data TableColumn column = TableColumn ColumnDescription
+
+data ColumnDescription = ColumnDescription {
+  name :: String ,
+  type_ :: String ,
+  options :: String }
 
 -- If we switch to a more lens-like approach to PackMap this should be
 -- the equivalent of a Setter
@@ -40,15 +46,15 @@ tableColumn = ViewColumnMaker
               (PM.PackMap (\f s -> fmap (const (mkColumn s)) (f ())))
   where mkColumn = IC.Column . HPQ.BaseTableAttrExpr
 
-column :: ColumnMaker (C.Column a) (C.Column a)
+column :: ColumnMaker (TableColumn a) (C.Column a)
 column = ColumnMaker
-         (PM.PackMap (\f (IC.Column s)
-                      -> fmap IC.Column (f s)))
+         (PM.PackMap (\f (TableColumn s)
+                      -> fmap IC.Column ((f . HPQ.BaseTableAttrExpr . name) s)))
 
 instance Default ViewColumnMaker String (C.Column a) where
   def = tableColumn
 
-instance Default ColumnMaker (C.Column a) (C.Column a) where
+instance Default ColumnMaker (TableColumn a) (C.Column a) where
   def = column
 
 -- {

src/Opaleye/Schema.hs

@@ -0,0 +1,116 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE Arrows #-}
+
+module Opaleye.Schema where
+
+import Data.Profunctor.Product.Default as D
+import Data.Profunctor.Product as PP
+import Data.Profunctor
+import Control.Applicative
+import Opaleye.Internal.Table as IT
+import qualified Opaleye.Internal.TableMaker as TM
+import Opaleye.Internal.PackMap as PM
+import Opaleye.Internal.Column as IC
+import Opaleye.Table as T
+import Opaleye.PGTypes as PG
+import Opaleye as O
+import Control.Arrow
+
+data TableSchema = TableSchema String [TM.ColumnDescription]
+
+tableSchema :: forall read write. 
+  (D.Default SchemaMaker read write) =>
+  IT.Table write read -> TableSchema
+tableSchema (IT.Table tableName (IT.TableProperties _ (View tableColumns))) = 
+  TableSchema tableName columns
+  where
+  s :: SchemaMaker read write
+  s = 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 (TM.ColumnDescription name _ _) = ([name], ())
+  (Table _ (TableProperties _ (View tableColsFrom))) = tableFrom
+  (Table _ (TableProperties _ (View tableColsTo))) = tableTo
+  keyFrom = selectSubsetFrom tableColsFrom
+  keyTo = selectSubsetTo tableColsTo
+  s1 :: SchemaMaker fk fk
+  s1 = def
+  (SchemaMaker (PM.PackMap pm)) = s1
+  (columnsFrom, ()) = pm extractor keyFrom
+  (columnsTo, ()) = pm extractor keyTo
+  in ForeignKey columnsFrom columnsTo
+
+columnSchemaMaker :: SchemaMaker (TM.TableColumn a) b
+columnSchemaMaker = SchemaMaker (PM.PackMap (\f (TM.TableColumn c) -> f c))
+
+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 TM.ColumnDescription () 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
+
+
+
+type T1 = (Maybe (Column PGInt8), Column PGInt8)
+type T1' = (TM.TableColumn PGInt8, TM.TableColumn PGInt8)
+type T1'' = (Column PGInt8, Column PGInt8)
+
+t1 :: Table T1 T1'
+t1 = Table "t1" $ p2 (T.optional "col0" Autogenerated, T.required "col1" NoIntOptions)
+
+t1ForeignKey :: ForeignKey
+t1ForeignKey = foreignKey t1 fst t1 snd
+
+t1Schema :: TableSchema
+t1Schema = tableSchema t1
+
+{-
+query :: O.Query T1
+query = proc () -> do
+  (col1, col2) <- T.queryTable t1 -< ()
+  returnA -< col1
+-}
+
+t1Query :: O.Query T1''
+t1Query = T.queryTable t1
+
+query' :: O.Query (Column PGInt8)
+query' = proc () -> do
+  (col1, _) <- t1Query -< ()
+  returnA -< col1
+
+

src/Opaleye/Table.hs

@@ -1,23 +1,24 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module Opaleye.Table (module Opaleye.Table,
                       View,
                       Writer,
                       Table(Table),
                       TableProperties) where
 
-import           Opaleye.Internal.Column (Column(Column))
+import           Opaleye.Internal.Column (Column)
 import qualified Opaleye.Internal.QueryArr as Q
 import qualified Opaleye.Internal.Table as T
 import           Opaleye.Internal.Table (View(View), Table, Writer,
                                          TableProperties)
 import qualified Opaleye.Internal.TableMaker as TM
 import qualified Opaleye.Internal.Tag as Tag
+import qualified Opaleye.PGTypes as PG
 
 import qualified Data.Profunctor.Product.Default as D
 
-import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ
-
 -- | Example type specialization:
 --
 -- @
@@ -30,22 +31,47 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ
 -- @
 -- queryTable :: Table w (Foo (Column a) (Column b) (Column c)) -> Query (Foo (Column a) (Column b) (Column c))
 -- @
-queryTable :: D.Default TM.ColumnMaker columns columns =>
-              Table a columns -> Q.Query columns
+queryTable :: D.Default TM.ColumnMaker read read' =>
+              Table write read -> Q.Query read'
 queryTable = queryTableExplicit D.def
 
-queryTableExplicit :: TM.ColumnMaker tablecolumns columns ->
-                     Table a tablecolumns -> Q.Query columns
+queryTableExplicit :: TM.ColumnMaker read read' ->
+                     Table write read -> Q.Query read'
 queryTableExplicit cm table = Q.simpleQueryArr f where
   f ((), t0) = (retwires, primQ, Tag.next t0) where
     (retwires, primQ) = T.queryTable cm table t0
 
-required :: String -> TableProperties (Column a) (Column a)
-required columnName = T.TableProperties
+required :: forall a. (PGType a) => String -> Options a -> TableProperties (Column a) (TM.TableColumn a)
+required columnName options = T.TableProperties
   (T.required columnName)
-  (View (Column (HPQ.BaseTableAttrExpr columnName)))
+  (View (TM.TableColumn (TM.ColumnDescription columnName type_ options')))
+  where
+  type_ = pgTypeName (undefined :: a)
+  options' = pgTypeOptions options
 
-optional :: String -> TableProperties (Maybe (Column a)) (Column a)
-optional columnName = T.TableProperties
+optional :: forall a. (PGType a) => String -> Options a -> TableProperties (Maybe (Column a)) (TM.TableColumn a)
+optional columnName options = T.TableProperties
   (T.optional columnName)
-  (View (Column (HPQ.BaseTableAttrExpr columnName)))
+  (View (TM.TableColumn (TM.ColumnDescription columnName type_ options')))
+  where
+  type_ = pgTypeName (undefined :: a)
+  options' = pgTypeOptions options
+
+class PGType a where
+  data Options a
+  pgTypeName :: a -> String
+  pgTypeOptions :: Options a -> String
+instance PGType PG.PGInt8 where
+  data Options PG.PGInt8 = NoIntOptions | Autogenerated
+  pgTypeName _ = "int"
+  pgTypeOptions _ = ""
+instance PGType PG.PGText where
+  data Options PG.PGText = NoTextOptions
+  pgTypeName _ = "text"
+  pgTypeOptions _ = ""
+instance PGType PG.PGNumeric where
+  data Options PG.PGNumeric = NumericOptions {
+    precision :: Int ,
+    scale :: Int }
+  pgTypeName _ = "numeric"
+  pgTypeOptions (NumericOptions precision' scale') = "(" ++ show precision' ++ "," ++ show scale' ++ ")"