diff --git a/src/Opaleye/Internal/Table.hs b/src/Opaleye/Internal/Table.hs index 9551f3b46..318fa86c4 100644 --- a/src/Opaleye/Internal/Table.hs +++ b/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 diff --git a/src/Opaleye/Internal/TableMaker.hs b/src/Opaleye/Internal/TableMaker.hs index a49fe99e2..7d2e57d1f 100644 --- a/src/Opaleye/Internal/TableMaker.hs +++ b/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 -- { diff --git a/src/Opaleye/Schema.hs b/src/Opaleye/Schema.hs new file mode 100644 index 000000000..22da54c0a --- /dev/null +++ b/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 + + diff --git a/src/Opaleye/Table.hs b/src/Opaleye/Table.hs index 15a9302b9..fb50a33ae 100644 --- a/src/Opaleye/Table.hs +++ b/src/Opaleye/Table.hs @@ -1,4 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} module Opaleye.Table (module Opaleye.Table, View, @@ -6,18 +8,17 @@ module Opaleye.Table (module Opaleye.Table, 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' ++ ")"