add TableProjector constraint to all updates tomjaguarpaw#37

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)

src/Opaleye/Internal/Schema.hs

@@ -26,6 +26,11 @@ class PGType a where
   pgColumnDefinition :: SchemaOptions a -> String
   defaultOptions :: SchemaOptions a
 
+instance PGType PGInt4 where
+  data SchemaOptions PGInt4 = NoIntOptions2
+  pgColumnDefinition _ = "SERIAL"
+  defaultOptions = NoIntOptions2
+
 instance PGType PGInt8 where
   data SchemaOptions PGInt8 = NoIntOptions
   pgColumnDefinition _ = "SERIAL"

src/Opaleye/Manipulation.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
 
 -- | Inserts, updates and deletes
 --
@@ -32,6 +33,7 @@ import           Opaleye.Internal.Column (Column(Column))
 import           Opaleye.Internal.Helpers ((.:), (.:.), (.::), (.::.))
 import qualified Opaleye.Internal.PrimQuery as PQ
 import qualified Opaleye.Internal.Unpackspec as U
+import qualified Opaleye.Internal.TableMaker as TM
 import           Opaleye.PGTypes (PGBool)
 
 import qualified Opaleye.Internal.HaskellDB.Sql as HSql
@@ -83,8 +85,9 @@ runInsertManyReturning :: (D.Default RQ.QueryRunner columnsReturned haskells)
 runInsertManyReturning = runInsertManyReturningExplicit D.def
 
 -- | Update rows in a table
-runUpdate :: PGS.Connection
-          -> T.Table columnsW columnsR
+runUpdate :: (D.Default TM.TableProjector tableColumns columnsR, T.ColumnFromTableColumn tableColumns ~ columnsR)
+          => PGS.Connection
+          -> T.Table columnsW tableColumns
           -- ^ Table to update
           -> (columnsR -> columnsW)
           -- ^ Update function to apply to chosen rows
@@ -103,10 +106,11 @@ runUpdate conn = PGS.execute_ conn . fromString .:. arrangeUpdateSql
 -- that the compiler will have trouble inferring types.  It is
 -- strongly recommended that you provide full type signatures when
 -- using @runInsertReturning@.
-runUpdateReturning :: (D.Default RQ.QueryRunner columnsReturned haskells)
+runUpdateReturning :: (D.Default RQ.QueryRunner columnsReturned haskells,
+                       D.Default TM.TableProjector tableColumns columnsR, T.ColumnFromTableColumn tableColumns ~ columnsR)
                    => PGS.Connection
                    -- ^
-                   -> T.Table columnsW columnsR
+                   -> T.Table columnsW tableColumns
                    -- ^ Table to update
                    -> (columnsR -> columnsW)
                    -- ^ Update function to apply to chosen rows
@@ -175,9 +179,10 @@ runInsertManyReturningExplicit qr conn t columns r =
 -- 'runUpdateReturning' instead.  You only need it if you want to run
 -- an UPDATE RETURNING statement but need to be explicit about the
 -- 'QueryRunner'.
-runUpdateReturningExplicit :: RQ.QueryRunner columnsReturned haskells
+runUpdateReturningExplicit :: (D.Default TM.TableProjector tableColumns columnsR, T.ColumnFromTableColumn tableColumns ~ columnsR)
+                           => RQ.QueryRunner columnsReturned haskells
                            -> PGS.Connection
-                           -> T.Table columnsW columnsR
+                           -> T.Table columnsW tableColumns
                            -> (columnsR -> columnsW)
                            -> (columnsR -> Column PGBool)
                            -> (columnsR -> columnsReturned)
@@ -186,7 +191,7 @@ runUpdateReturningExplicit qr conn t update cond r =
   PGS.queryWith_ parser conn
                  (fromString (arrangeUpdateReturningSql u t update cond r))
   where IRQ.QueryRunner u _ _ = qr
-        parser = IRQ.prepareRowParser qr (r v)
+        parser = IRQ.prepareRowParser qr (r . TI.runTableProjector D.def $ v)
         TI.Table _ (TI.TableProperties _ (TI.View v)) = t
 
 -- * Deprecated versions
@@ -240,20 +245,25 @@ arrangeInsertManySql = show . HPrint.ppInsert .: arrangeInsertMany
 
 -- | For internal use only.  Do not use.  Will be deprecated in
 -- version 0.6.
-arrangeUpdate :: T.Table columnsW columnsR
+arrangeUpdate :: (D.Default TM.TableProjector tableColumns columnsR, T.ColumnFromTableColumn tableColumns ~ columnsR)
+              => T.Table columnsW tableColumns
               -> (columnsR -> columnsW) -> (columnsR -> Column PGBool)
               -> HSql.SqlUpdate
 arrangeUpdate table update cond =
   SG.sqlUpdate SD.defaultSqlGenerator
                (PQ.tiToSqlTable (TI.tableIdentifier table))
                [condExpr] (update' tableCols)
   where TI.TableProperties writer (TI.View tableCols) = TI.tableProperties table
-        update' = map (\(x, y) -> (y, x)) . TI.runWriter writer . update
-        Column condExpr = cond tableCols
+        update' = map (\(x, y) -> (y, x)) . TI.runWriter writer . update . TI.runTableProjector tableProjector
+        Column condExpr = cond . TI.runTableProjector tableProjector $ tableCols
+        tableProjector = D.def
 
 -- | For internal use only.  Do not use.  Will be deprecated in
 -- version 0.6.
-arrangeUpdateSql :: T.Table columnsW columnsR
+
+arrangeUpdateSql ::
+              (D.Default TM.TableProjector tableColumns columnsR, T.ColumnFromTableColumn tableColumns ~ columnsR)
+              => T.Table columnsW tableColumns
               -> (columnsR -> columnsW) -> (columnsR -> Column PGBool)
               -> String
 arrangeUpdateSql = show . HPrint.ppUpdate .:. arrangeUpdate
@@ -297,8 +307,9 @@ arrangeInsertManyReturningSql =
 
 -- | For internal use only.  Do not use.  Will be deprecated in
 -- version 0.6.
-arrangeUpdateReturning :: U.Unpackspec columnsReturned ignored
-                       -> T.Table columnsW columnsR
+arrangeUpdateReturning :: (D.Default TM.TableProjector tableColumns columnsR, T.ColumnFromTableColumn tableColumns ~ columnsR)
+                       => U.Unpackspec columnsReturned ignored
+                       -> T.Table columnsW tableColumns
                        -> (columnsR -> columnsW)
                        -> (columnsR -> Column PGBool)
                        -> (columnsR -> columnsReturned)
@@ -307,13 +318,14 @@ arrangeUpdateReturning unpackspec table updatef cond returningf =
   Sql.Returning update returningSEs
   where update = arrangeUpdate table updatef cond
         TI.View columnsR = TI.tablePropertiesView (TI.tableProperties table)
-        returningPEs = U.collectPEs unpackspec (returningf columnsR)
+        returningPEs = U.collectPEs unpackspec (returningf . TI.runTableProjector D.def $ columnsR)
         returningSEs = Sql.ensureColumnsGen id (map Sql.sqlExpr returningPEs)
 
 -- | For internal use only.  Do not use.  Will be deprecated in
 -- version 0.6.
-arrangeUpdateReturningSql :: U.Unpackspec columnsReturned ignored
-                          -> T.Table columnsW columnsR
+arrangeUpdateReturningSql :: (D.Default TM.TableProjector tableColumns columnsR, T.ColumnFromTableColumn tableColumns ~ columnsR)
+                          => U.Unpackspec columnsReturned ignored
+                          -> T.Table columnsW tableColumns
                           -> (columnsR -> columnsW)
                           -> (columnsR -> Column PGBool)
                           -> (columnsR -> columnsReturned)

src/Opaleye/Table.hs

@@ -7,7 +7,8 @@ module Opaleye.Table (module Opaleye.Table,
                       Writer,
                       TM.TableColumn,
                       Table(Table, TableWithSchema),
-                      TableProperties) where
+                      TableProperties,
+                      ColumnFromTableColumn) where
 
 import           Opaleye.Internal.Column (Column(Column))
 import qualified Opaleye.Internal.QueryArr as Q