derive foreign key from the table #37

Author: ryskajakub

src/Opaleye/Internal/Schema.hs

@@ -17,22 +17,25 @@ 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
-  pgTypeName :: a -> String
-  pgTypeOptions :: SchemaOptions a -> String
+  pgColumnDefinition :: SchemaOptions a -> String
+  defaultOptions :: SchemaOptions a
 
 instance PGType PGInt8 where
-  data SchemaOptions PGInt8 = NoIntOptions | Autogenerated
-  pgTypeName = const "numeric"
-  pgTypeOptions _ = "SERIAL"
+  data SchemaOptions PGInt8 = NoIntOptions
+  pgColumnDefinition _ = "SERIAL"
+  defaultOptions = NoIntOptions
 
 instance PGType PGText where
-  data SchemaOptions PGText = NoOptions
-  pgTypeName = const "varchar"
-  pgTypeOptions _ = "(256)"
+  data SchemaOptions PGText = Length Int | Unspecified
+  pgColumnDefinition (Length x) = "varchar (" <> show x <> ")"
+  pgColumnDefinition _ = "text"
+  defaultOptions = Unspecified
 
 data TableSchema = TableSchema String [UntypedColumn]
 
@@ -54,8 +57,27 @@ tableSchema (discardSchema -> (tableName, (IT.TableProperties _ (View tableColum
   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 z) -> f (UntypedColumn (TM.TableColumn x y z))))
+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

src/Opaleye/Internal/TableMaker.hs

@@ -28,8 +28,7 @@ newtype ColumnMaker columns columns' =
 
 data TableColumn a = TableColumn {
   name :: String ,
-  pgType :: String ,
-  options :: String }
+  columnDefinition :: String }
 
 newtype TableProjector columns columns' = TableProjector (columns -> I.Identity columns')
 
@@ -55,7 +54,7 @@ column = ColumnMaker
                       -> fmap IC.Column (f s)))
 
 tableProjector :: TableProjector (TableColumn a) (IC.Column a)
-tableProjector = TableProjector (\(TableColumn name' _ _) -> (I.Identity . IC.Column . HPQ.BaseTableAttrExpr) name')
+tableProjector = TableProjector (\(TableColumn name' _) -> (I.Identity . IC.Column . HPQ.BaseTableAttrExpr) name')
 
 instance Default ViewColumnMaker String (C.Column a) where
   def = tableColumn

src/Opaleye/Table.hs

@@ -43,19 +43,22 @@ queryTable :: (D.Default TM.ColumnMaker columns columns, D.Default TM.TableProje
               Table a tableColumns -> Q.Query columns
 queryTable = queryTableExplicit D.def D.def
 
+required' :: S.PGType a => S.SchemaOptions a -> String -> TableProperties (Column a) (TM.TableColumn a)
+required' schemaOptions columnName = T.TableProperties
+  (T.required columnName)
+  (View (TM.TableColumn columnName (S.pgColumnDefinition schemaOptions) ))
+
 -- | 'required' is for columns which are not 'optional'.  You must
 -- provide them on writes.
 required :: S.PGType a => String -> TableProperties (Column a) (TM.TableColumn a)
-required columnName = T.TableProperties
-  (T.required columnName)
-  (View (TM.TableColumn columnName "" ""))
+required = required' S.defaultOptions
 
 -- | 'optional' is for columns that you can omit on writes, such as
 --  columns which have defaults or which are SERIAL.
 optional :: S.PGType a => String -> TableProperties (Maybe (Column a)) (TM.TableColumn a)
 optional columnName = T.TableProperties
   (T.optional columnName)
-  (View (TM.TableColumn columnName "" ""))
+  (View (TM.TableColumn columnName ""))
 
 -- * Explicit versions