diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,41 @@ +## 0.6.0.0 + +* Added `runUpdateEasy` + +* Deprecated + + * `Show` instance of `Column a` + * `Manipulation.arrange...` + * `showPGType` + * `literalColumn` + * `unsafePgFormatTime` + * `prepareQuery` + * `formatAndShowSQL` + +* Removed + + * `unsafeCoerce` + +* Added `TableColumn` and `tableColumn` which selects `optional` or + `required` based on write type. + +* Added `TableColumns` as synonym for `TableProperties`. + `TableProperties` will be deprecated in version 0.7. + +* Added `table` as synonym for `Table`. `Table` will be deprecated in + version 0.7. + +* Added `tableWithSchema` as synonym for `TableWithSchema`. `Table` + will be deprecated in version 0.7. + +* Replaced `ColumnMaker` with `Unpackspec`, which is identical to it. + +* Added `Profunctor` instance for `Table` + +* Added `restrictExists` and `restrictNotExists` as synonyms for + `exists` and `notExists`. The latter will be deprecated in version + 0.7. + ## 0.5.4.0 * Added cursor interface (`Cursor` and friends) diff --git a/Doc/Tutorial/TutorialAdvanced.lhs b/Doc/Tutorial/TutorialAdvanced.lhs --- a/Doc/Tutorial/TutorialAdvanced.lhs +++ b/Doc/Tutorial/TutorialAdvanced.lhs @@ -6,7 +6,7 @@ > > import Opaleye.QueryArr (Query) > import Opaleye.Column (Column) -> import Opaleye.Table (Table(Table), required, queryTable) +> import Opaleye.Table (Table, table, tableColumn, queryTable) > import Opaleye.PGTypes (PGText, PGInt4) > import qualified Opaleye.Aggregate as A > import Opaleye.Aggregate (Aggregator, aggregate) @@ -40,8 +40,8 @@ > personTable :: Table (Column PGText, Column PGInt4) > (Column PGText, Column PGInt4) -> personTable = Table "personTable" (p2 ( required "name" -> , required "child_age" )) +> personTable = table "personTable" (p2 ( tableColumn "name" +> , tableColumn "child_age" )) > rangeOfChildrensAges :: Query (Column PGText, Column PGInt4) > rangeOfChildrensAges = aggregate (p2 (A.groupBy, range)) (queryTable personTable) diff --git a/Doc/Tutorial/TutorialBasic.lhs b/Doc/Tutorial/TutorialBasic.lhs --- a/Doc/Tutorial/TutorialBasic.lhs +++ b/Doc/Tutorial/TutorialBasic.lhs @@ -9,7 +9,7 @@ > import Prelude hiding (sum) > > import Opaleye (Column, Nullable, matchNullable, isNull, -> Table(Table), required, queryTable, +> Table, table, tableColumn, queryTable, > Query, QueryArr, restrict, (.==), (.<=), (.&&), (.<), > (.===), > (.++), ifThenElse, pgString, aggregate, groupBy, @@ -61,13 +61,13 @@ > personTable :: Table (Column PGText, Column PGInt4, Column PGText) > (Column PGText, Column PGInt4, Column PGText) -> personTable = Table "personTable" (p3 ( required "name" -> , required "age" -> , required "address" )) +> personTable = table "personTable" (p3 ( tableColumn "name" +> , tableColumn "age" +> , tableColumn "address" )) By default, the table `"personTable"` is looked up in PostgreSQL's default `"public"` schema. If we wanted to specify a different schema we -could have used the `TableWithSchema` constructor instead of `Table`. +could have used the `tableWithSchema` function instead of `table`. To query a table we use `queryTable`. @@ -138,13 +138,13 @@ things out by hand here. If you want to avoid Template Haskell see [Data.Profunctor.Product.TH](https://hackage.haskell.org/package/product-profunctors-0.6.3.1/docs/Data-Profunctor-Product-TH.html). -Then we can use 'Table' to make a table on our record type in exactly +Then we can use 'table' to make a table on our record type in exactly the same way as before. > birthdayTable :: Table BirthdayColumn BirthdayColumn -> birthdayTable = Table "birthdayTable" -> (pBirthday Birthday { bdName = required "name" -> , bdDay = required "birthday" }) +> birthdayTable = table "birthdayTable" +> (pBirthday Birthday { bdName = tableColumn "name" +> , bdDay = tableColumn "birthday" }) > > birthdayQuery :: Query BirthdayColumn > birthdayQuery = queryTable birthdayTable @@ -382,8 +382,8 @@ > employeeTable :: Table (Column PGText, Column (Nullable PGText)) > (Column PGText, Column (Nullable PGText)) -> employeeTable = Table "employeeTable" (p2 ( required "name" -> , required "boss" )) +> employeeTable = table "employeeTable" (p2 ( tableColumn "name" +> , tableColumn "boss" )) We can write a query that returns as string indicating for each employee whether they have a boss. @@ -584,12 +584,12 @@ > (Column PGInt4) (Column PGFloat8)) > (Widget (Column PGText) (Column PGText) (Column PGText) > (Column PGInt4) (Column PGFloat8)) -> widgetTable = Table "widgetTable" -> (pWidget Widget { style = required "style" -> , color = required "color" -> , location = required "location" -> , quantity = required "quantity" -> , radius = required "radius" }) +> widgetTable = table "widgetTable" +> (pWidget Widget { style = tableColumn "style" +> , color = tableColumn "color" +> , location = tableColumn "location" +> , quantity = tableColumn "quantity" +> , radius = tableColumn "radius" }) Say we want to group by the style and color of widgets, calculating @@ -752,10 +752,10 @@ > (Column PGInt4) > > badWarehouseTable :: Table BadWarehouseColumn BadWarehouseColumn -> badWarehouseTable = Table "warehouse_table" -> (pWarehouse Warehouse { wId = required "id" -> , wLocation = required "location" -> , wNumGoods = required "num_goods" }) +> badWarehouseTable = table "warehouse_table" +> (pWarehouse Warehouse { wId = tableColumn "id" +> , wLocation = tableColumn "location" +> , wNumGoods = tableColumn "num_goods" }) but that would expose us to the following sorts of errors, where we can meaninglessly relate the warehouse ID with the quantity of goods @@ -776,10 +776,10 @@ > (Column PGInt4) > > goodWarehouseTable :: Table GoodWarehouseColumn GoodWarehouseColumn -> goodWarehouseTable = Table "warehouse_table" -> (pWarehouse Warehouse { wId = pWarehouseId (WarehouseId (required "id")) -> , wLocation = required "location" -> , wNumGoods = required "num_goods" }) +> goodWarehouseTable = table "warehouse_table" +> (pWarehouse Warehouse { wId = pWarehouseId (WarehouseId (tableColumn "id")) +> , wLocation = tableColumn "location" +> , wNumGoods = tableColumn "num_goods" }) Now the comparison will not pass the type checker diff --git a/Doc/Tutorial/TutorialBasicMonomorphic.lhs b/Doc/Tutorial/TutorialBasicMonomorphic.lhs --- a/Doc/Tutorial/TutorialBasicMonomorphic.lhs +++ b/Doc/Tutorial/TutorialBasicMonomorphic.lhs @@ -1,14 +1,14 @@ > {-# LANGUAGE FlexibleContexts #-} > {-# LANGUAGE FlexibleInstances #-} > {-# LANGUAGE MultiParamTypeClasses #-} -> {-# LANGUAGE UndecidableInstances #-} > > module TutorialBasicMonomorphic where > > import Prelude hiding (sum) > > import Opaleye (Column, Nullable, -> Table(Table), required, queryTable, +> Table, table, queryTable, +> tableColumn, > Query, (.==), > aggregate, groupBy, > count, avg, sum, leftJoin, runQuery, @@ -17,14 +17,13 @@ > > import qualified Opaleye as O > -> import Control.Applicative ((<$>), (<*>)) +> import Control.Applicative (Applicative, (<$>), (<*>)) > > import qualified Data.Profunctor as P > import Data.Profunctor.Product (p3) > import Data.Profunctor.Product.Default (Default) > import qualified Data.Profunctor.Product.Default as D > import Data.Time.Calendar (Day) -> import qualified Opaleye.Internal.TableMaker > import qualified Opaleye.Internal.Join > > import qualified Database.PostgreSQL.Simple as PGS @@ -64,13 +63,19 @@ > personTable :: Table (Column PGText, Column PGInt4, Column PGText) > (Column PGText, Column PGInt4, Column PGText) -> personTable = Table "personTable" (p3 ( required "name" -> , required "age" -> , required "address" )) +> personTable = table "personTable" (p3 ( tableColumn "name" +> , tableColumn "age" +> , tableColumn "address" )) +> personTable' :: Table (Column PGText, Column PGInt4, Column PGText) +> (Column PGText, Column PGInt4, Column PGText) +> personTable' = table "personTable" (p3 ( tableColumn "name" +> , tableColumn "age" +> , tableColumn "address" )) + By default, the table `"personTable"` is looked up in PostgreSQL's default `"public"` schema. If we wanted to specify a different schema we -could have used the `TableWithSchema` constructor instead of `Table`. +could have used the `tableWithSchema` constructor instead of `table`. To query a table we use `queryTable`. @@ -132,21 +137,29 @@ > > data Birthday = Birthday { bdName :: String, bdDay :: Day } > -> instance Default Unpackspec BirthdayColumn BirthdayColumn where -> def = BirthdayColumn <$> P.lmap bdNameColumn D.def -> <*> P.lmap bdDayColumn D.def +> birthdayColumnDef :: +> (Applicative (p BirthdayColumn), +> P.Profunctor p, +> Default p (Column PGText) (Column PGText), +> Default p (Column PGDate) (Column PGDate)) => +> p BirthdayColumn BirthdayColumn +> birthdayColumnDef = BirthdayColumn <$> P.lmap bdNameColumn D.def +> <*> P.lmap bdDayColumn D.def > -> instance Default Opaleye.Internal.TableMaker.ColumnMaker BirthdayColumn BirthdayColumn where -> def = BirthdayColumn <$> P.lmap bdNameColumn D.def -> <*> P.lmap bdDayColumn D.def +> instance Default Unpackspec BirthdayColumn BirthdayColumn where +> def = birthdayColumnDef -Then we can use 'Table' to make a table on our record type in exactly +Naturally this is all derivable using `Generic` or Template Haskell, +but no one's bothered to implement that yet. Would you like to? + +Then we can use 'table' to make a table on our record type in exactly the same way as before. > birthdayTable :: Table BirthdayColumn BirthdayColumn -> birthdayTable = Table "birthdayTable" -> (BirthdayColumn <$> P.lmap bdNameColumn (required "name") -> <*> P.lmap bdDayColumn (required "birthday")) +> birthdayTable = +> table "birthdayTable" +> (BirthdayColumn <$> P.lmap bdNameColumn (tableColumn "name") +> <*> P.lmap bdDayColumn (tableColumn "birthday")) > > birthdayQuery :: Query BirthdayColumn > birthdayQuery = queryTable birthdayTable @@ -186,7 +199,7 @@ > , radius :: Column PGFloat8 > } > -> instance Default Opaleye.Internal.TableMaker.ColumnMaker WidgetColumn WidgetColumn where +> instance Default Unpackspec WidgetColumn WidgetColumn where > def = WidgetColumn <$> P.lmap style D.def > <*> P.lmap color D.def > <*> P.lmap location D.def @@ -197,12 +210,12 @@ strings, but in practice they might have been a different data type. > widgetTable :: Table WidgetColumn WidgetColumn -> widgetTable = Table "widgetTable" -> (WidgetColumn <$> P.lmap style (required "style") -> <*> P.lmap color (required "color") -> <*> P.lmap location (required "location") -> <*> P.lmap quantity (required "quantity") -> <*> P.lmap radius (required "radius")) +> widgetTable = table "widgetTable" +> (WidgetColumn <$> P.lmap style (tableColumn "style") +> <*> P.lmap color (tableColumn "color") +> <*> P.lmap location (tableColumn "location") +> <*> P.lmap quantity (tableColumn "quantity") +> <*> P.lmap radius (tableColumn "radius")) Say we want to group by the style and color of widgets, calculating @@ -284,13 +297,17 @@ > def = BirthdayColumnNullable <$> P.lmap bdNameColumn D.def > <*> P.lmap bdDayColumn D.def +Again, this is all derivable using `Generic` or Template Haskell, if +someone would take the time to implement it. + A left join is expressed by specifying the two tables to join and the join condition. > personBirthdayLeftJoin :: Query ((Column PGText, Column PGInt4, Column PGText), > BirthdayColumnNullable) > personBirthdayLeftJoin = leftJoin personQuery birthdayQuery eqName -> where eqName ((name, _, _), birthdayRow) = name .== bdNameColumn birthdayRow +> where eqName ((name, _, _), birthdayRow) = +> name .== bdNameColumn birthdayRow The generated SQL is @@ -373,6 +390,9 @@ > -> Query BirthdayColumn > -> IO [Birthday] > runBirthdayQuery = runQuery + +Again, this is derivable using `Generic` or Template Haskell, if +someone would take the time to implement it. Conclusion ========== diff --git a/Doc/Tutorial/TutorialBasicTypeFamilies.lhs b/Doc/Tutorial/TutorialBasicTypeFamilies.lhs --- a/Doc/Tutorial/TutorialBasicTypeFamilies.lhs +++ b/Doc/Tutorial/TutorialBasicTypeFamilies.lhs @@ -12,12 +12,11 @@ > import Prelude hiding (sum) > > import Opaleye (Column, Nullable, -> Table(Table), required, queryTable, +> Table, table, tableColumn, queryTable, > Query, (.==), aggregate, groupBy, > count, avg, sum, leftJoin, runQuery, > showSqlForPostgres, Unpackspec, > PGInt4, PGInt8, PGText, PGDate, PGFloat8) -> import qualified Opaleye as O > > import Control.Applicative ((<$>), (<*>), Applicative) > @@ -64,13 +63,13 @@ > personTable :: Table (Column PGText, Column PGInt4, Column PGText) > (Column PGText, Column PGInt4, Column PGText) -> personTable = Table "personTable" (p3 ( required "name" -> , required "age" -> , required "address" )) +> personTable = table "personTable" (p3 ( tableColumn "name" +> , tableColumn "age" +> , tableColumn "address" )) By default, the table `"personTable"` is looked up in PostgreSQL's default `"public"` schema. If we wanted to specify a different schema we -could have used the `TableWithSchema` constructor instead of `Table`. +could have used the `tableWithSchema` constructor instead of `table`. To query a table we use `queryTable`. @@ -156,20 +155,6 @@ > -- could even have a symbol field containing the table name and use > -- https://hackage.haskell.org/package/base-4.8.2.0/docs/GHC-TypeLits.html#v:symbolVal > -> -> -- { If you use Tableable you don't even have to specify required or optional -> -> class Tableable a b | a -> b where -> tableField :: String -> O.TableProperties a b -> -> instance Tableable (Column a) (Column a) where -> tableField = required -> -> instance Tableable (Maybe (Column a)) (Column a) where -> tableField = O.optional -> -> -- } -> > data Birthday f = Birthday { bdName :: TableField f String PGText NN Req > , bdDay :: TableField f Day PGDate NN Req > } @@ -182,13 +167,13 @@ > def = Birthday <$> P.lmap bdName D.def > <*> P.lmap bdDay D.def -Then we can use 'Table' to make a table on our record type in exactly +Then we can use 'table' to make a table on our record type in exactly the same way as before. > birthdayTable :: Table (Birthday W) (Birthday O) -> birthdayTable = Table "birthdayTable" -> (Birthday <$> P.lmap bdName (required "name") -> <*> P.lmap bdDay (required "birthday")) +> birthdayTable = table "birthdayTable" +> (Birthday <$> P.lmap bdName (tableColumn "name") +> <*> P.lmap bdDay (tableColumn "birthday")) > > birthdayQuery :: Query (Birthday O) > birthdayQuery = queryTable birthdayTable @@ -245,12 +230,12 @@ strings, but in practice they might have been a different data type. > widgetTable :: Table (Widget O) (Widget O) -> widgetTable = Table "widgetTable" -> (Widget <$> P.lmap style (required "style") -> <*> P.lmap color (required "color") -> <*> P.lmap location (required "location") -> <*> P.lmap quantity (required "quantity") -> <*> P.lmap radius (required "radius")) +> widgetTable = table "widgetTable" +> (Widget <$> P.lmap style (tableColumn "style") +> <*> P.lmap color (tableColumn "color") +> <*> P.lmap location (tableColumn "location") +> <*> P.lmap quantity (tableColumn "quantity") +> <*> P.lmap radius (tableColumn "radius")) Say we want to group by the style and color of widgets, calculating diff --git a/Doc/Tutorial/TutorialManipulation.lhs b/Doc/Tutorial/TutorialManipulation.lhs --- a/Doc/Tutorial/TutorialManipulation.lhs +++ b/Doc/Tutorial/TutorialManipulation.lhs @@ -2,8 +2,8 @@ > > import Prelude hiding (sum) > -> import Opaleye (Column, Table(Table), -> required, optional, (.==), (.<), +> import Opaleye (Column, Table, table, +> tableColumn, (.==), (.<), > arrangeDeleteSql, arrangeInsertManySql, > arrangeUpdateSql, arrangeInsertManyReturningSql, > PGInt4, PGFloat8) @@ -25,25 +25,25 @@ "id" column (assumed to be an auto-incrementing field) and two double-valued required fields. The `Table` type constructor has two type arguments. The first one is the type of writes to the table, and -the second is the type of reads from the table. Notice that the "id" -column was defined as optional (for writes) so in the type of writes -it is wrapped in a Maybe. That means we don't necessarily need to +the second is the type of reads from the table. The "id" +column is defined as optional (for writes) because its write type is +`Maybe (Column PGInt4)`. That means we don't necessarily need to specify it when writing to the table. The database will automatically fill in a value for us. -> table :: Table +> myTable :: Table > (Maybe (Column PGInt4), Column PGFloat8, Column PGFloat8, Column P.PGText) > (Column PGInt4, Column PGFloat8, Column PGFloat8, Column P.PGText) -> table = Table "tablename" (p4 ( optional "id" -> , required "x" -> , required "y" -> , required "s" )) +> myTable = table "tablename" (p4 ( tableColumn "id" +> , tableColumn "x" +> , tableColumn "y" +> , tableColumn "s" )) To perform a delete we provide an expression from our read type to `Column Bool`. All rows for which the expression is true are deleted. > delete :: String -> delete = arrangeDeleteSql table (\(_, x, y, _) -> x .< y) +> delete = arrangeDeleteSql myTable (\(_, x, y, _) -> x .< y) ghci> putStrLn delete DELETE FROM tablename @@ -58,7 +58,7 @@ P.PGText` from a `String`. > insertNothing :: String -> insertNothing = arrangeInsertManySql table (return (Nothing, 2, 3, P.pgString "Hello")) +> insertNothing = arrangeInsertManySql myTable (return (Nothing, 2, 3, P.pgString "Hello")) ghci> putStrLn insertNothing INSERT INTO "tablename" ("id", @@ -76,7 +76,7 @@ > insertNonLiteral :: Double -> String > insertNonLiteral i = -> arrangeInsertManySql table (return (Nothing, 2, C.constant i, P.pgString "Hello")) +> arrangeInsertManySql myTable (return (Nothing, 2, C.constant i, P.pgString "Hello")) ghci> putStrLn $ insertNonLiteral 12.0 INSERT INTO "tablename" ("id", @@ -92,7 +92,7 @@ If we really want to specify an optional column we can use `Just`. > insertJust :: String -> insertJust = arrangeInsertManySql table (return (Just 1, 2, 3, P.pgString "Hello")) +> insertJust = arrangeInsertManySql myTable (return (Just 1, 2, 3, P.pgString "Hello")) ghci> putStrLn insertJust INSERT INTO "tablename" ("id", @@ -111,8 +111,8 @@ according to the update function. > update :: String -> update = arrangeUpdateSql table (\(_, x, y, s) -> (Nothing, x + y, x - y, s)) -> (\(id_, _, _, _) -> id_ .== 5) +> update = arrangeUpdateSql myTable (\(_, x, y, s) -> (Nothing, x + y, x - y, s)) +> (\(id_, _, _, _) -> id_ .== 5) ghci> putStrLn update SET "id" = DEFAULT, @@ -129,8 +129,8 @@ > insertReturning :: String > insertReturning = -> arrangeInsertManyReturningSql def' table (return (Nothing, 4, 5, P.pgString "Bye")) -> (\(id_, _, _, _) -> id_) +> arrangeInsertManyReturningSql def' myTable (return (Nothing, 4, 5, P.pgString "Bye")) +> (\(id_, _, _, _) -> id_) > -- TODO: vv This is too messy > where def' :: U.Unpackspec (Column a) (Column a) > def' = def diff --git a/opaleye.cabal b/opaleye.cabal --- a/opaleye.cabal +++ b/opaleye.cabal @@ -1,6 +1,6 @@ name: opaleye copyright: Copyright (c) 2014-2017 Purely Agile Limited -version: 0.5.4.0 +version: 0.6.0.0 synopsis: An SQL-generating DSL targeting PostgreSQL description: An SQL-generating DSL targeting PostgreSQL. Allows Postgres queries to be written within Haskell in a @@ -28,10 +28,7 @@ default-language: Haskell2010 hs-source-dirs: src build-depends: - -- attoparsec can be removed once postgresql-simple patch in - -- Internal.RunQuery is merged upstream aeson >= 0.6 && < 1.3 - , attoparsec >= 0.10.3 && < 0.14 , base >= 4.6 && < 5 , base16-bytestring >= 0.1.1.6 && < 0.2 , case-insensitive >= 1.2 && < 1.3 @@ -73,6 +70,7 @@ Opaleye.Internal.Helpers, Opaleye.Internal.Join, Opaleye.Internal.Label, + Opaleye.Internal.Manipulation, Opaleye.Internal.Order, Opaleye.Internal.Operators, Opaleye.Internal.Optimize, diff --git a/src/Opaleye/Column.hs b/src/Opaleye/Column.hs --- a/src/Opaleye/Column.hs +++ b/src/Opaleye/Column.hs @@ -16,13 +16,12 @@ maybeToNullable, -- * Unsafe operations unsafeCast, - unsafeCoerce, unsafeCoerceColumn, unsafeCompositeField, -- * Entire module module Opaleye.Column) where -import Opaleye.Internal.Column (Column, Nullable, unsafeCoerce, unsafeCoerceColumn, +import Opaleye.Internal.Column (Column, Nullable, unsafeCoerceColumn, unsafeCast, unsafeCompositeField) import qualified Opaleye.Internal.Column as C import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ diff --git a/src/Opaleye/Internal/Binary.hs b/src/Opaleye/Internal/Binary.hs --- a/src/Opaleye/Internal/Binary.hs +++ b/src/Opaleye/Internal/Binary.hs @@ -2,7 +2,7 @@ module Opaleye.Internal.Binary where -import Opaleye.Internal.Column (Column(Column)) +import Opaleye.Internal.Column (Column(Column), unColumn) import qualified Opaleye.Internal.Tag as T import qualified Opaleye.Internal.PackMap as PM import qualified Opaleye.Internal.QueryArr as Q @@ -33,8 +33,8 @@ runBinaryspec (Binaryspec b) = PM.traversePM b binaryspecColumn :: Binaryspec (Column a) (Column a) -binaryspecColumn = Binaryspec (PM.PackMap (\f (Column e, Column e') - -> fmap Column (f (e, e')))) +binaryspecColumn = Binaryspec (PM.iso (mapBoth unColumn) Column) + where mapBoth f (s, t) = (f s, f t) sameTypeBinOpHelper :: PQ.BinOp -> Binaryspec columns columns' -> Q.Query columns -> Q.Query columns -> Q.Query columns' diff --git a/src/Opaleye/Internal/Column.hs b/src/Opaleye/Internal/Column.hs --- a/src/Opaleye/Internal/Column.hs +++ b/src/Opaleye/Internal/Column.hs @@ -8,8 +8,8 @@ -- @PGInt4@ is an @int4@ column and a 'Column' @PGText@ is a @text@ -- column. -- --- Do not use the 'Show' instance of 'Column'. It will be deprecated --- in version 0.6. +-- Do not use the 'Show' instance of 'Column'. It is considered +-- deprecated and will be removed in version 0.7. newtype Column pgType = Column HPQ.PrimExpr deriving Show -- | Only used within a 'Column', to indicate that it can be @NULL@. @@ -19,10 +19,6 @@ unColumn :: Column a -> HPQ.PrimExpr unColumn (Column e) = e - -{-# DEPRECATED unsafeCoerce "Will be removed in version 0.6. Use unsafeCoerceColumn instead." #-} -unsafeCoerce :: Column a -> Column b -unsafeCoerce = unsafeCoerceColumn -- | Treat a 'Column' as though it were of a different type. If such -- a treatment is not valid then Postgres may fail with an error at diff --git a/src/Opaleye/Internal/Manipulation.hs b/src/Opaleye/Internal/Manipulation.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Internal/Manipulation.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Opaleye.Internal.Manipulation where + +import qualified Control.Applicative as A + +import Opaleye.Internal.Column (Column) +import Data.Profunctor (Profunctor, dimap) +import qualified Data.Profunctor.Product as PP +import qualified Data.Profunctor.Product.Default as D + +newtype Updater a b = Updater (a -> b) + +-- { Boilerplate instances + +instance Functor (Updater a) where + fmap f (Updater g) = Updater (fmap f g) + +instance A.Applicative (Updater a) where + pure = Updater . A.pure + Updater f <*> Updater x = Updater (f A.<*> x) + +instance Profunctor Updater where + dimap f g (Updater h) = Updater (dimap f g h) + +instance PP.ProductProfunctor Updater where + empty = PP.defaultEmpty + (***!) = PP.defaultProfunctorProduct + +-- + +instance D.Default Updater (Column a) (Column a) where + def = Updater id + +instance D.Default Updater (Column a) (Maybe (Column a)) where + def = Updater Just + diff --git a/src/Opaleye/Internal/Operators.hs b/src/Opaleye/Internal/Operators.hs --- a/src/Opaleye/Internal/Operators.hs +++ b/src/Opaleye/Internal/Operators.hs @@ -9,9 +9,10 @@ import qualified Opaleye.Internal.PrimQuery as PQ import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ import qualified Opaleye.Internal.QueryArr as QA -import qualified Opaleye.Internal.TableMaker as TM import qualified Opaleye.Internal.Table as Table +import qualified Opaleye.Internal.TableMaker as TM import qualified Opaleye.Internal.Tag as Tag +import qualified Opaleye.Internal.Unpackspec as U import qualified Opaleye.PGTypes as T import Data.Profunctor (Profunctor, dimap, lmap, rmap) @@ -29,8 +30,7 @@ (.&&) :: Column T.PGBool -> Column T.PGBool -> Column T.PGBool (.&&) = C.binOp HPQ.OpAnd --- Probably should be newtype -data EqPP a b = EqPP (a -> a -> Column T.PGBool) +newtype EqPP a b = EqPP (a -> a -> Column T.PGBool) eqExplicit :: EqPP columns a -> columns -> columns -> Column T.PGBool eqExplicit (EqPP f) = f @@ -56,11 +56,11 @@ data RelExprMaker a b = forall c. RelExprMaker { relExprVCM :: TM.ViewColumnMaker a c - , relExprCM :: TM.ColumnMaker c b + , relExprCM :: U.Unpackspec c b } relExprColumn :: RelExprMaker String (Column a) -relExprColumn = RelExprMaker TM.tableColumn TM.column +relExprColumn = RelExprMaker TM.tableColumn U.unpackspecColumn instance D.Default RelExprMaker String (Column a) where def = relExprColumn diff --git a/src/Opaleye/Internal/PackMap.hs b/src/Opaleye/Internal/PackMap.hs --- a/src/Opaleye/Internal/PackMap.hs +++ b/src/Opaleye/Internal/PackMap.hs @@ -40,7 +40,7 @@ -- 'ProductProfunctor') in @s@ and @t@. It is unclear at this point -- whether we want the same @Traversal@ laws to hold or not. Our use -- cases may be much more general. -data PackMap a b s t = PackMap (forall f. Applicative f => (a -> f b) -> s -> f t) +newtype PackMap a b s t = PackMap (forall f. Applicative f => (a -> f b) -> s -> f t) -- | Replaces the targeted occurences of @a@ in @s@ with @b@ (changing -- the @s@ to a @t@ in the process). This can be done via an @@ -114,6 +114,11 @@ -> f (Either b b') eitherFunction f g = fmap (either (fmap Left) (fmap Right)) (f PP.+++! g) +-- | Like 'Control.Lens.Iso.iso'. In practice it won't actually be +-- used as an isomorphism, but it seems to be appropriate anyway. +iso :: (s -> a) -> (b -> t) -> PackMap a b s t +iso h g = PackMap (dimap h (fmap g)) + -- { -- Boilerplate instance definitions. There's no choice here apart @@ -134,13 +139,6 @@ (***!) = PP.defaultProfunctorProduct instance PP.SumProfunctor (PackMap a b) where - f +++! g = - PackMap (\x -> - case f of - PackMap f' -> - case g of - PackMap g' -> - eitherFunction (f' x) - (g' x)) + PackMap f +++! PackMap g = PackMap (\x -> eitherFunction (f x) (g x)) -- } diff --git a/src/Opaleye/Internal/RunQuery.hs b/src/Opaleye/Internal/RunQuery.hs --- a/src/Opaleye/Internal/RunQuery.hs +++ b/src/Opaleye/Internal/RunQuery.hs @@ -36,7 +36,7 @@ import Data.UUID (UUID) import GHC.Int (Int32, Int64) --- { Only needed for annoying postgresql-simple patch below +-- { Only needed for postgresql-simple FieldParsers import Control.Applicative ((<$>)) import Database.PostgreSQL.Simple.FromField @@ -52,6 +52,9 @@ -- @haskellType@. For example a value of type 'QueryRunnerColumn' -- 'T.PGText' 'String' encodes how to turn a 'T.PGText' result from the -- database into a Haskell 'String'. +-- +-- \"'QueryRunnerColumn' @pgType@ @haskellType@\" corresponds to +-- postgresql-simple's \"'FieldParser' @haskellType@\". -- This is *not* a Product Profunctor because it is the only way I -- know of to get the instance generation to work for non-Nullable and @@ -71,6 +74,11 @@ -- into Haskell values (@haskells@). Most likely you will never need -- to create on of these or handle one directly. It will be provided -- for you by the 'D.Default' 'QueryRunner' instance. +-- +-- \"'QueryRunner' @columns@ @haskells@\" corresponds to +-- postgresql-simple's \"'RowParser' @haskells@\". \"'Default' +-- 'QueryRunner' @columns@ @haskells@\" corresponds to +-- postgresql-simple's \"@FromRow@ @haskells@\". data QueryRunner columns haskells = QueryRunner (U.Unpackspec columns ()) (columns -> RowParser haskells) @@ -128,6 +136,9 @@ -- the default way to turn a @pgType@ result from the database into a -- Haskell value of type @haskellType@. -- +-- \"'QueryRunnerColumnDefault' @pgType@ @haskellType@\" corresponds +-- to postgresql-simple's \"'FromField' @haskellType@\". +-- -- Creating an instance of 'QueryRunnerColumnDefault' for your own types is -- necessary for retrieving those types from the database. -- @@ -265,6 +276,10 @@ -- typenames, not type Oids are used in order to avoid creating -- a dependency on 'Database.PostgreSQL.LibPQ' +-- +-- Eventually we want to move this to postgresql-simple +-- +-- https://github.com/tomjaguarpaw/haskell-opaleye/issues/329 jsonFieldTypeParser :: SBS.ByteString -> FieldParser String jsonFieldTypeParser jsonTypeName field mData = do ti <- typeInfo field diff --git a/src/Opaleye/Internal/Table.hs b/src/Opaleye/Internal/Table.hs --- a/src/Opaleye/Internal/Table.hs +++ b/src/Opaleye/Internal/Table.hs @@ -1,11 +1,13 @@ +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE Rank2Types #-} module Opaleye.Internal.Table where -import Opaleye.Internal.Column (Column, unColumn) -import qualified Opaleye.Internal.TableMaker as TM +import Opaleye.Internal.Column (Column(Column), unColumn) import qualified Opaleye.Internal.Tag as Tag +import qualified Opaleye.Internal.Unpackspec as U import qualified Opaleye.Internal.PrimQuery as PQ import qualified Opaleye.Internal.PackMap as PM @@ -38,34 +40,61 @@ -- (Column PGInt4) (Column PGFloat8)) -- (Widget (Column PGText) (Column PGText) (Column PGText) -- (Column PGInt4) (Column PGFloat8)) --- widgetTable = Table \"widgetTable\" --- (pWidget Widget { wid = optional \"id\" --- , color = required \"color\" --- , location = required \"location\" --- , quantity = required \"quantity\" --- , radius = required \"radius\" }) +-- widgetTable = table \"widgetTable\" +-- (pWidget Widget { wid = tableColumn \"id\" +-- , color = tableColumn \"color\" +-- , location = tableColumn \"location\" +-- , quantity = tableColumn \"quantity\" +-- , radius = tableColumn \"radius\" }) -- @ +-- +-- The constructors of Table are internal only and will be +-- deprecated in version 0.7. data Table writerColumns viewColumns - = Table String (TableProperties writerColumns viewColumns) - -- ^ Uses the default schema name (@\"public\"@). - | TableWithSchema String String (TableProperties writerColumns viewColumns) - -- ^ Schema name (@\"public\"@ by default in PostgreSQL), table name, - -- table properties. + = Table String (TableColumns writerColumns viewColumns) + -- ^ For unqualified table names. Do not use the constructor. It + -- is internal and will be deprecated in version 0.7. + | TableWithSchema String String (TableColumns writerColumns viewColumns) + -- ^ Schema name, table name, table properties. Do not use the + -- constructor. It is internal and will be deprecated in version 0.7. -tableIdentifier :: Table writerColumns viewColumns -> PQ.TableIdentifier +tableIdentifier :: Table writeColumns viewColumns -> PQ.TableIdentifier tableIdentifier (Table t _) = PQ.TableIdentifier Nothing t tableIdentifier (TableWithSchema s t _) = PQ.TableIdentifier (Just s) t -tableProperties :: Table writerColumns viewColumns -> TableProperties writerColumns viewColumns -tableProperties (Table _ p) = p -tableProperties (TableWithSchema _ _ p) = p +tableColumns :: Table writeColumns viewColumns -> TableColumns writeColumns viewColumns +tableColumns (Table _ p) = p +tableColumns (TableWithSchema _ _ p) = p -data TableProperties writerColumns viewColumns = TableProperties - { tablePropertiesWriter :: Writer writerColumns viewColumns +-- | Use 'tableColumns' instead. Will be deprecated soon. +tableProperties :: Table writeColumns viewColumns -> TableColumns writeColumns viewColumns +tableProperties = tableColumns + +-- | Use 'TableColumns' instead. 'TableProperties' will be deprecated +-- in version 0.7. +data TableProperties writeColumns viewColumns = TableProperties + { tablePropertiesWriter :: Writer writeColumns viewColumns , tablePropertiesView :: View viewColumns } +-- | The new name for 'TableColumns' which will replace +-- 'TableColumn' in version 0.7. +type TableColumns = TableProperties + +tableColumnsWriter :: TableColumns writeColumns viewColumns + -> Writer writeColumns viewColumns +tableColumnsWriter = tablePropertiesWriter + +tableColumnsView :: TableColumns writeColumns viewColumns + -> View viewColumns +tableColumnsView = tablePropertiesView + +-- | Internal only. Do not use. 'View' will be deprecated in version +-- 0.7. data View columns = View columns +-- | Internal only. Do not use. 'Writer' will be deprecated in +-- version 0.7. + -- There's no reason the second parameter should exist except that we -- use ProductProfunctors more than ProductContravariants so it makes -- things easier if we make it one of the former. @@ -79,21 +108,47 @@ Writer (forall f. Functor f => PM.PackMap (f HPQ.PrimExpr, String) () (f columns) ()) -queryTable :: TM.ColumnMaker viewColumns columns - -> Table writerColumns viewColumns +-- | 'required' is for columns which are not 'optional'. You must +-- provide them on writes. +required :: String -> TableColumns (Column a) (Column a) +required columnName = TableProperties + (requiredW columnName) + (View (Column (HPQ.BaseTableAttrExpr columnName))) + +-- | 'optional' is for columns that you can omit on writes, such as +-- columns which have defaults or which are SERIAL. +optional :: String -> TableColumns (Maybe (Column a)) (Column a) +optional columnName = TableProperties + (optionalW columnName) + (View (Column (HPQ.BaseTableAttrExpr columnName))) + +class TableColumn a b | a -> b where + -- | Create either a 'required' or 'optional' column depending on + -- the write type. It's generally more convenient to use this + -- than 'required' or 'optional'. + tableColumn :: String -> TableColumns a (Column b) + +instance TableColumn (Column a) a where + tableColumn = required + +instance TableColumn (Maybe (Column a)) a where + tableColumn = optional + +queryTable :: U.Unpackspec viewColumns columns + -> Table writeColumns viewColumns -> Tag.Tag -> (columns, PQ.PrimQuery) queryTable cm table tag = (primExprs, primQ) where - View tableCols = tablePropertiesView (tableProperties table) + View tableCols = tableColumnsView (tableColumns table) (primExprs, projcols) = runColumnMaker cm tag tableCols primQ :: PQ.PrimQuery primQ = PQ.BaseTable (tableIdentifier table) projcols -runColumnMaker :: TM.ColumnMaker tablecolumns columns +runColumnMaker :: U.Unpackspec tablecolumns columns -> Tag.Tag -> tablecolumns -> (columns, [(HPQ.Symbol, HPQ.PrimExpr)]) -runColumnMaker cm tag tableCols = PM.run (TM.runColumnMaker cm f tableCols) where +runColumnMaker cm tag tableCols = PM.run (U.runUnpackspec cm f tableCols) where f = PM.extractAttrPE mkName tag -- The non-AttrExpr PrimExprs are not created by 'makeView' or a -- 'ViewColumnMaker' so could only arise from an fmap (if we @@ -127,15 +182,14 @@ where mempty' = [] `NEL.cons` mempty' Zip xs `mappend` Zip ys = Zip (NEL.zipWith (++) xs ys) -required :: String -> Writer (Column a) (Column a) -required columnName = - Writer (PM.PackMap (\f columns -> f (fmap unColumn columns, columnName))) +requiredW :: String -> Writer (Column a) (Column a) +requiredW columnName = + Writer (PM.iso (flip (,) columnName . fmap unColumn) id) -optional :: String -> Writer (Maybe (Column a)) (Column a) -optional columnName = - Writer (PM.PackMap (\f columns -> f (fmap maybeUnColumn columns, columnName))) - where maybeUnColumn Nothing = HPQ.DefaultInsertExpr - maybeUnColumn (Just column) = unColumn column +optionalW :: String -> Writer (Maybe (Column a)) (Column a) +optionalW columnName = + Writer (PM.iso (flip (,) columnName . fmap maybeUnColumn) id) + where maybeUnColumn = maybe HPQ.DefaultInsertExpr unColumn -- { @@ -173,5 +227,9 @@ instance Functor (Table a) where fmap f (Table t tp) = Table t (fmap f tp) fmap f (TableWithSchema s t tp) = TableWithSchema s t (fmap f tp) + +instance Profunctor Table where + dimap f g (Table t tp) = Table t (dimap f g tp) + dimap f g (TableWithSchema s t tp) = TableWithSchema s t (dimap f g tp) -- } diff --git a/src/Opaleye/Internal/TableMaker.hs b/src/Opaleye/Internal/TableMaker.hs --- a/src/Opaleye/Internal/TableMaker.hs +++ b/src/Opaleye/Internal/TableMaker.hs @@ -5,6 +5,7 @@ import qualified Opaleye.Column as C import qualified Opaleye.Internal.Column as IC import qualified Opaleye.Internal.PackMap as PM +import qualified Opaleye.Internal.Unpackspec as U import Data.Profunctor (Profunctor, dimap) import Data.Profunctor.Product (ProductProfunctor, empty, (***!)) @@ -21,18 +22,19 @@ newtype ViewColumnMaker strings columns = ViewColumnMaker (PM.PackMap () () strings columns) -newtype ColumnMaker columns columns' = - ColumnMaker (PM.PackMap HPQ.PrimExpr HPQ.PrimExpr columns columns') - runViewColumnMaker :: ViewColumnMaker strings tablecolumns -> strings -> tablecolumns runViewColumnMaker (ViewColumnMaker f) = PM.overPM f id +{-# DEPRECATED ColumnMaker "Use Unpackspec instead" #-} +type ColumnMaker = U.Unpackspec + +{-# DEPRECATED runColumnMaker "Use runUnpackspec instead" #-} runColumnMaker :: Applicative f => ColumnMaker tablecolumns columns -> (HPQ.PrimExpr -> f HPQ.PrimExpr) -> tablecolumns -> f columns -runColumnMaker (ColumnMaker f) = PM.traversePM f +runColumnMaker = U.runUnpackspec -- There's surely a way of simplifying this implementation tableColumn :: ViewColumnMaker String (C.Column a) @@ -40,16 +42,12 @@ (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 - (PM.PackMap (\f (IC.Column s) - -> fmap IC.Column (f s))) - instance Default ViewColumnMaker String (C.Column a) where def = tableColumn -instance Default ColumnMaker (C.Column a) (C.Column a) where - def = column +{-# DEPRECATED column "Use unpackspecColumn instead" #-} +column :: ColumnMaker (C.Column a) (C.Column a) +column = U.unpackspecColumn -- { @@ -66,20 +64,6 @@ dimap f g (ViewColumnMaker q) = ViewColumnMaker (dimap f g q) instance ProductProfunctor ViewColumnMaker where - empty = PP.defaultEmpty - (***!) = PP.defaultProfunctorProduct - -instance Functor (ColumnMaker a) where - fmap f (ColumnMaker g) = ColumnMaker (fmap f g) - -instance Applicative (ColumnMaker a) where - pure = ColumnMaker . pure - ColumnMaker f <*> ColumnMaker x = ColumnMaker (f <*> x) - -instance Profunctor ColumnMaker where - dimap f g (ColumnMaker q) = ColumnMaker (dimap f g q) - -instance ProductProfunctor ColumnMaker where empty = PP.defaultEmpty (***!) = PP.defaultProfunctorProduct diff --git a/src/Opaleye/Internal/Unpackspec.hs b/src/Opaleye/Internal/Unpackspec.hs --- a/src/Opaleye/Internal/Unpackspec.hs +++ b/src/Opaleye/Internal/Unpackspec.hs @@ -28,17 +28,16 @@ -- the @makeAdaptorAndInstance@ splice from -- @Data.Profunctor.Product.TH@ has been run). -- - -- You can create 'Unpackspec's by hand using 'unpackspecColumn' and - -- the 'Profunctor', 'ProductProfunctor' and 'SumProfunctor' - -- operations. However, in practice users should almost never need - -- to create or manipulate them. Typically they will be created - -- automatically by the 'D.Default' instance. + -- Users should almost never need to create or manipulate + -- `Unpackspec`s. Typically they will be created automatically by + -- the 'D.Default' instance. If you really need to you can create + -- 'Unpackspec's by hand using 'unpackspecColumn' and the + -- 'Profunctor', 'ProductProfunctor' and 'SumProfunctor' operations. Unpackspec (PM.PackMap HPQ.PrimExpr HPQ.PrimExpr columns columns') -- | Target the single 'HPQ.PrimExpr' inside a 'C.Column' unpackspecColumn :: Unpackspec (C.Column a) (C.Column a) -unpackspecColumn = Unpackspec - (PM.PackMap (\f (IC.Column pe) -> fmap IC.Column (f pe))) +unpackspecColumn = Unpackspec (PM.iso IC.unColumn IC.Column) -- | Modify all the targeted 'HPQ.PrimExpr's runUnpackspec :: Applicative f diff --git a/src/Opaleye/Internal/Values.hs b/src/Opaleye/Internal/Values.hs --- a/src/Opaleye/Internal/Values.hs +++ b/src/Opaleye/Internal/Values.hs @@ -60,7 +60,7 @@ runValuesspec (Valuesspec v) f = PM.traversePM v f () instance Default Valuesspec (Column a) (Column a) where - def = Valuesspec (PM.PackMap (\f () -> fmap Column (f ()))) + def = Valuesspec (PM.iso id Column) -- { diff --git a/src/Opaleye/Manipulation.hs b/src/Opaleye/Manipulation.hs --- a/src/Opaleye/Manipulation.hs +++ b/src/Opaleye/Manipulation.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} -- | Inserts, updates and deletes -- @@ -30,6 +32,7 @@ import qualified Opaleye.Internal.Table as TI import Opaleye.Internal.Column (Column(Column)) import Opaleye.Internal.Helpers ((.:), (.:.), (.::), (.::.)) +import Opaleye.Internal.Manipulation (Updater(Updater)) import qualified Opaleye.Internal.PrimQuery as PQ import qualified Opaleye.Internal.Unpackspec as U import Opaleye.PGTypes (PGBool) @@ -84,6 +87,28 @@ -- | Update rows in a table. -- +-- (N.B. 'runUpdateEasy''s \"returning\" counterpart +-- \"@runUpdateEasyReturning@\" hasn't been implemented. File an +-- issue if you want it!) +runUpdateEasy :: D.Default Updater columnsR columnsW + => PGS.Connection + -> T.Table columnsW columnsR + -- ^ Table to update + -> (columnsR -> columnsR) + -- ^ Update function to apply to chosen rows + -> (columnsR -> Column PGBool) + -- ^ Predicate function @f@ to choose which rows to update. + -- 'runUpdate' will update rows for which @f@ returns @TRUE@ + -- and leave unchanged rows for which @f@ returns @FALSE@. + -> IO Int64 + -- ^ The number of rows updated +runUpdateEasy conn table u = runUpdate conn table (u' . u) + where Updater u' = D.def + +-- | Update rows in a table. You'll probably find it more convenient +-- to use 'runUpdateEasy' (although 'runUpdate' provides more +-- fine-grained control if you need it). +-- -- Be careful: providing 'Nothing' to a column created by @optional@ -- updates the column to its default value. Many users have been -- confused by this because they assume it means that the column is to @@ -177,7 +202,7 @@ (arrangeInsertManyReturningSql u t columns' r)) where IRQ.QueryRunner u _ _ = qr parser = IRQ.prepareRowParser qr (r v) - TI.Table _ (TI.TableProperties _ (TI.View v)) = t + TI.View v = TI.tableColumnsView (TI.tableColumns t) -- This method of getting hold of the return type feels a bit -- suspect. I haven't checked it for validity. @@ -197,14 +222,15 @@ (fromString (arrangeUpdateReturningSql u t update cond r)) where IRQ.QueryRunner u _ _ = qr parser = IRQ.prepareRowParser qr (r v) - TI.Table _ (TI.TableProperties _ (TI.View v)) = t + TI.View v = TI.tableColumnsView (TI.tableColumns t) -- * Deprecated versions -- | Returns the number of rows inserted --- --- This will be deprecated in version 0.6. Use 'runInsertMany' --- instead. + +{-# DEPRECATED runInsert + "'runInsert' will be removed in version 0.7. \ + \Use 'runInsertMany' instead." #-} runInsert :: PGS.Connection -> T.Table columns columns' -> columns -> IO Int64 runInsert conn = PGS.execute_ conn . fromString .: arrangeInsertSql @@ -212,9 +238,10 @@ -- compiler will have trouble inferring types. It is strongly -- recommended that you provide full type signatures when using -- @runInsertReturning@. --- --- This will be deprecated in version 0.6. Use --- 'runInsertManyReturning' instead. + +{-# DEPRECATED runInsertReturning + "'runInsertReturning' will be removed in version 0.7. \ + \Use 'runInsertManyReturning' instead." #-} runInsertReturning :: (D.Default RQ.QueryRunner columnsReturned haskells) => PGS.Connection -> T.Table columnsW columnsR @@ -223,33 +250,38 @@ -> IO [haskells] runInsertReturning = runInsertReturningExplicit D.def --- | For internal use only. Do not use. Will be deprecated in --- version 0.6. +{-# DEPRECATED arrangeInsert + "You probably want 'runInsertMany' instead. \ + \Will be removed in version 0.7." #-} arrangeInsert :: T.Table columns a -> columns -> HSql.SqlInsert arrangeInsert t c = arrangeInsertMany t (return c) --- | For internal use only. Do not use. Will be deprecated in --- version 0.6. +{-# DEPRECATED arrangeInsertSql + "You probably want 'runInsertMany' instead. \ + \Will be removed in version 0.7." #-} arrangeInsertSql :: T.Table columns a -> columns -> String arrangeInsertSql = show . HPrint.ppInsert .: arrangeInsert --- | For internal use only. Do not use. Will be deprecated in --- version 0.6. +{-# DEPRECATED arrangeInsertMany + "You probably want 'runInsertMany' instead. \ + \Will be removed in version 0.7." #-} arrangeInsertMany :: T.Table columns a -> NEL.NonEmpty columns -> HSql.SqlInsert arrangeInsertMany table columns = insert - where writer = TI.tablePropertiesWriter (TI.tableProperties table) + where writer = TI.tableColumnsWriter (TI.tableColumns table) (columnExprs, columnNames) = TI.runWriter' writer columns insert = SG.sqlInsert SD.defaultSqlGenerator (PQ.tiToSqlTable (TI.tableIdentifier table)) columnNames columnExprs --- | For internal use only. Do not use. Will be deprecated in --- version 0.6. +{-# DEPRECATED arrangeInsertManySql + "You probably want 'runInsertMany' instead. \ + \Will be removed in version 0.7." #-} arrangeInsertManySql :: T.Table columns a -> NEL.NonEmpty columns -> String arrangeInsertManySql = show . HPrint.ppInsert .: arrangeInsertMany --- | For internal use only. Do not use. Will be deprecated in --- version 0.6. +{-# DEPRECATED arrangeUpdate + "You probably want 'runUpdate' instead. \ + \Will be removed in version 0.7." #-} arrangeUpdate :: T.Table columnsW columnsR -> (columnsR -> columnsW) -> (columnsR -> Column PGBool) -> HSql.SqlUpdate @@ -257,32 +289,36 @@ SG.sqlUpdate SD.defaultSqlGenerator (PQ.tiToSqlTable (TI.tableIdentifier table)) [condExpr] (update' tableCols) - where TI.TableProperties writer (TI.View tableCols) = TI.tableProperties table + where TI.TableProperties writer (TI.View tableCols) = TI.tableColumns table update' = map (\(x, y) -> (y, x)) . TI.runWriter writer . update Column condExpr = cond tableCols --- | For internal use only. Do not use. Will be deprecated in --- version 0.6. +{-# DEPRECATED arrangeUpdateSql + "You probably want 'runUpdate' instead. \ + \Will be removed in version 0.7." #-} arrangeUpdateSql :: T.Table columnsW columnsR -> (columnsR -> columnsW) -> (columnsR -> Column PGBool) -> String arrangeUpdateSql = show . HPrint.ppUpdate .:. arrangeUpdate --- | For internal use only. Do not use. Will be deprecated in --- version 0.6. +{-# DEPRECATED arrangeDelete + "You probably want 'runDelete' instead. \ + \Will be removed in version 0.7." #-} arrangeDelete :: T.Table a columnsR -> (columnsR -> Column PGBool) -> HSql.SqlDelete arrangeDelete table cond = SG.sqlDelete SD.defaultSqlGenerator (PQ.tiToSqlTable (TI.tableIdentifier table)) [condExpr] where Column condExpr = cond tableCols - TI.View tableCols = TI.tablePropertiesView (TI.tableProperties table) + TI.View tableCols = TI.tableColumnsView (TI.tableColumns table) --- | For internal use only. Do not use. Will be deprecated in --- version 0.6. +{-# DEPRECATED arrangeDeleteSql + "You probably want 'runDelete' instead. \ + \Will be removed in version 0.7." #-} arrangeDeleteSql :: T.Table a columnsR -> (columnsR -> Column PGBool) -> String arrangeDeleteSql = show . HPrint.ppDelete .: arrangeDelete --- | For internal use only. Do not use. Will be deprecated in --- version 0.6. +{-# DEPRECATED arrangeInsertManyReturning + "You probably want 'runInsertMany' instead. \ + \Will be removed in version 0.7." #-} arrangeInsertManyReturning :: U.Unpackspec columnsReturned ignored -> T.Table columnsW columnsR -> NEL.NonEmpty columnsW @@ -291,12 +327,13 @@ arrangeInsertManyReturning unpackspec table columns returningf = Sql.Returning insert returningSEs where insert = arrangeInsertMany table columns - TI.View columnsR = TI.tablePropertiesView (TI.tableProperties table) + TI.View columnsR = TI.tableColumnsView (TI.tableColumns table) returningPEs = U.collectPEs unpackspec (returningf columnsR) returningSEs = Sql.ensureColumnsGen id (map Sql.sqlExpr returningPEs) --- | For internal use only. Do not use. Will be deprecated in --- version 0.6. +{-# DEPRECATED arrangeInsertManyReturningSql + "You probably want 'runInsertManyReturning' instead. \ + \Will be removed in version 0.7." #-} arrangeInsertManyReturningSql :: U.Unpackspec columnsReturned ignored -> T.Table columnsW columnsR -> NEL.NonEmpty columnsW @@ -305,8 +342,9 @@ arrangeInsertManyReturningSql = show . Print.ppInsertReturning .:: arrangeInsertManyReturning --- | For internal use only. Do not use. Will be deprecated in --- version 0.6. +{-# DEPRECATED arrangeUpdateReturning + "You probably want 'runUpdateReturning' instead. \ + \Will be removed in version 0.7." #-} arrangeUpdateReturning :: U.Unpackspec columnsReturned ignored -> T.Table columnsW columnsR -> (columnsR -> columnsW) @@ -316,12 +354,13 @@ arrangeUpdateReturning unpackspec table updatef cond returningf = Sql.Returning update returningSEs where update = arrangeUpdate table updatef cond - TI.View columnsR = TI.tablePropertiesView (TI.tableProperties table) + TI.View columnsR = TI.tableColumnsView (TI.tableColumns table) returningPEs = U.collectPEs unpackspec (returningf columnsR) returningSEs = Sql.ensureColumnsGen id (map Sql.sqlExpr returningPEs) --- | For internal use only. Do not use. Will be deprecated in --- version 0.6. +{-# DEPRECATED arrangeUpdateReturningSql + "You probably want 'runUpdateReturning' instead. \ + \Will be removed in version 0.7." #-} arrangeUpdateReturningSql :: U.Unpackspec columnsReturned ignored -> T.Table columnsW columnsR -> (columnsR -> columnsW) diff --git a/src/Opaleye/Operators.hs b/src/Opaleye/Operators.hs --- a/src/Opaleye/Operators.hs +++ b/src/Opaleye/Operators.hs @@ -37,15 +37,15 @@ restrict = QueryArr f where f (Column predicate, primQ, t0) = ((), PQ.restrict predicate primQ, t0) -{-| Add a @WHERE EXSITS@ clause to the current query. -} -exists :: QueryArr a b -> QueryArr a () -exists criteria = QueryArr f where +{-| Add a @WHERE EXISTS@ clause to the current query. -} +restrictExists :: QueryArr a b -> QueryArr a () +restrictExists criteria = QueryArr f where f (a, primQ, t0) = ((), PQ.exists primQ existsQ, t1) where (_, existsQ, t1) = runSimpleQueryArr criteria (a, t0) -{-| Add a @WHERE EXSITS@ clause to the current query. -} -notExists :: QueryArr a b -> QueryArr a () -notExists criteria = QueryArr f where +{-| Add a @WHERE NOT EXISTS@ clause to the current query. -} +restrictNotExists :: QueryArr a b -> QueryArr a () +restrictNotExists criteria = QueryArr f where f (a, primQ, t0) = ((), PQ.notExists primQ existsQ, t1) where (_, existsQ, t1) = runSimpleQueryArr criteria (a, t0) @@ -317,8 +317,9 @@ -> Column T.PGTimestamp timestamptzAtTimeZone = C.binOp HPQ.OpAtTimeZone --- | Do not use. Will be deprecated in version 0.6. Use --- 'C.unsafeCast' instead. +{-# DEPRECATED doubleOfInt + "Use 'C.unsafeCast' instead. \ + \Will be removed in version 0.7." #-} doubleOfInt :: Column T.PGInt4 -> Column T.PGFloat8 doubleOfInt (Column e) = Column (HPQ.CastExpr "float8" e) @@ -344,3 +345,13 @@ infix 4 .-|- (.-|-) :: Column (T.PGRange a) -> Column (T.PGRange a) -> Column T.PGBool (.-|-) = C.binOp (HPQ.:-|-) + +-- * Deprecated + +-- | Identical to 'restrictExists'. Will be deprecated in version 0.7. +exists :: QueryArr a b -> QueryArr a () +exists = restrictExists + +-- | Identical to 'restrictNoExists'. Will be deprecated in version 0.7. +notExists :: QueryArr a b -> QueryArr a () +notExists = restrictNotExists diff --git a/src/Opaleye/PGTypes.hs b/src/Opaleye/PGTypes.hs --- a/src/Opaleye/PGTypes.hs +++ b/src/Opaleye/PGTypes.hs @@ -149,9 +149,10 @@ oneEl R.NegInfinity = HPQ.NegInfinity oneEl R.PosInfinity = HPQ.PosInfinity +{-# DEPRECATED showPGType + "Use 'showSqlType' instead. 'showSqlType' will be deprecated \ + \in version 0.7." #-} class IsSqlType pgType where - -- | 'showSqlType' will be deprecated in version 0.6. Use - -- 'showSqlType' instead. showPGType :: proxy pgType -> String showPGType = showSqlType @@ -246,12 +247,12 @@ literalColumn :: HPQ.Literal -> Column a literalColumn = IPT.literalColumn -{-# WARNING literalColumn - "'literalColumn' has been moved to Opaleye.Internal.PGTypes and will be deprecated in version 0.6" +{-# DEPRECATED literalColumn + "'literalColumn' has been moved to Opaleye.Internal.PGTypes and will be removed in version 0.7." #-} unsafePgFormatTime :: Time.FormatTime t => HPQ.Name -> String -> t -> Column c unsafePgFormatTime = IPT.unsafePgFormatTime -{-# WARNING unsafePgFormatTime - "'unsafePgFormatTime' has been moved to Opaleye.Internal.PGTypes and will be deprecated in version 0.6" +{-# DEPRECATED unsafePgFormatTime + "'unsafePgFormatTime' has been moved to Opaleye.Internal.PGTypes and will be removed in version 0.7." #-} diff --git a/src/Opaleye/RunQuery.hs b/src/Opaleye/RunQuery.hs --- a/src/Opaleye/RunQuery.hs +++ b/src/Opaleye/RunQuery.hs @@ -6,7 +6,7 @@ QueryRunner, IRQ.QueryRunnerColumn, IRQ.QueryRunnerColumnDefault (..), - -- * Creating now 'QueryRunnerColumn's + -- * Creating new 'QueryRunnerColumn's IRQ.fieldQueryRunnerColumn, IRQ.fieldParserQueryRunnerColumn) where @@ -157,8 +157,7 @@ -- * Deprecated functions --- | For internal use only. Do not use. Will be deprecated in --- version 0.6. +{-# DEPRECATED prepareQuery "Will be removed in version 0.7" #-} prepareQuery :: QueryRunner columns haskells -> Query columns -> (Maybe PGS.Query, FR.RowParser haskells) prepareQuery qr@(QueryRunner u _ _) q = (sql, parser) where sql :: Maybe PGS.Query diff --git a/src/Opaleye/Sql.hs b/src/Opaleye/Sql.hs --- a/src/Opaleye/Sql.hs +++ b/src/Opaleye/Sql.hs @@ -77,8 +77,9 @@ showSqlForPostgresUnoptExplicit :: U.Unpackspec columns b -> Q.Query columns -> Maybe String showSqlForPostgresUnoptExplicit = showSqlUnoptExplicit --- | For internal use only. Do not use. Will be deprecated in --- version 0.6. +{-# DEPRECATED formatAndShowSQL + "You probably want 'showSqlExplicit' or 'showSqlUnoptExplicit' instead. \ + \Will be removed in version 0.7." #-} formatAndShowSQL :: ([HPQ.PrimExpr], PQ.PrimQuery' a, T.Tag) -> Maybe String formatAndShowSQL = fmap (show . Pr.ppSql . Sql.sql) . traverse2Of3 Op.removeEmpty where -- Just a lens diff --git a/src/Opaleye/Table.hs b/src/Opaleye/Table.hs --- a/src/Opaleye/Table.hs +++ b/src/Opaleye/Table.hs @@ -1,5 +1,8 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} + {- | Columns can be required or optional and, independently, nullable or @@ -9,7 +12,7 @@ 'required' and gives rise to a @ - TableProperties (Column PGInt4) (Column PGInt4) + TableColumns (Column PGInt4) (Column PGInt4) @ The leftmost argument is the type of writes. When you insert or @@ -20,7 +23,7 @@ to a @ - TableProperties (Column (Nullable PGInt4)) (Column (Nullable PGInt4)) + TableColumns (Column (Nullable PGInt4)) (Column (Nullable PGInt4)) @ When you insert or update into this column you must give it a @Column @@ -28,25 +31,29 @@ @toNullable :: Column a -> Column (Nullable a)@, or with @null :: Column (Nullable a)@. - An optional non-nullable @PGInt4@ is created with optional and gives + An optional non-nullable @PGInt4@ is created with 'optional' and gives rise to a @ - TableProperties (Maybe (Column PGInt4)) (Column PGInt4) + TableColumns (Maybe (Column PGInt4)) (Column PGInt4) @ + Optional columns are those that can be omitted on writes, such as + those that have @DEFAULT@s or those that are @SERIAL@. When you insert or update into this column you must give it a @Maybe (Column PGInt4)@. If you provide @Nothing@ then the column will be omitted from the query and the default value will be used. Otherwise you have to provide a @Just@ containing a @Column PGInt4@. - An optional non-nullable @PGInt4@ is created with optional and gives + An optional nullable @PGInt4@ is created with 'optional' and gives rise to a @ - TableProperties (Maybe (Column (Nullable PGInt4))) (Column PGInt4) + TableColumns (Maybe (Column (Nullable PGInt4))) (Column (Nullable PGInt4)) @ + Optional columns are those that can be omitted on writes, such as + those that have @DEFAULT@s or those that are @SERIAL@. When you insert or update into this column you must give it a @Maybe (Column (Nullable PGInt4))@. If you provide @Nothing@ then the default value will be used. Otherwise you have to provide a @Just@ containing @@ -54,59 +61,72 @@ -} -module Opaleye.Table (module Opaleye.Table, +module Opaleye.Table (-- * Creating tables + table, + tableWithSchema, + T.Table, + T.tableColumn, + T.optional, + T.required, + -- * Querying tables + queryTable, -- * Other + TableColumns, + -- * Deprecated View, Writer, T.Table(T.Table, T.TableWithSchema), - TableProperties) where + -- * Module reexport + module Opaleye.Table) where -import Opaleye.Internal.Column (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 Opaleye.Internal.Table (View, Table, Writer, + TableColumns) + import qualified Opaleye.Internal.Tag as Tag +import qualified Opaleye.Internal.Unpackspec as U import qualified Data.Profunctor.Product.Default as D -import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ - -- | Example type specialization: -- -- @ --- queryTable :: Table w (Column a, Column b) -> Query (Column a, Column b) +-- queryTable :: Table w (Column a, Column b) +-- -> Query (Column a, Column b) -- @ -- -- Assuming the @makeAdaptorAndInstance@ splice has been run for the -- product type @Foo@: -- -- @ --- queryTable :: Table w (Foo (Column a) (Column b) (Column c)) -> Query (Foo (Column a) (Column b) (Column c)) +-- 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 => +queryTable :: D.Default U.Unpackspec columns columns => Table a columns -> Q.Query columns queryTable = queryTableExplicit D.def --- | 'required' is for columns which are not 'optional'. You must --- provide them on writes. -required :: String -> TableProperties (Column a) (Column a) -required columnName = T.TableProperties - (T.required columnName) - (View (Column (HPQ.BaseTableAttrExpr columnName))) +-- | Create a table with unqualified names. +table :: String + -- ^ Table name + -> TableColumns writeColumns viewColumns + -> Table writeColumns viewColumns +table = T.Table --- | 'optional' is for columns that you can omit on writes, such as --- columns which have defaults or which are SERIAL. -optional :: String -> TableProperties (Maybe (Column a)) (Column a) -optional columnName = T.TableProperties - (T.optional columnName) - (View (Column (HPQ.BaseTableAttrExpr columnName))) +-- | Create a table. +tableWithSchema :: String + -- ^ Schema name + -> String + -- ^ Table name + -> TableColumns writeColumns viewColumns + -> Table writeColumns viewColumns +tableWithSchema = T.TableWithSchema -- * Explicit versions -queryTableExplicit :: TM.ColumnMaker tablecolumns columns -> +queryTableExplicit :: U.Unpackspec tablecolumns columns -> Table a tablecolumns -> Q.Query columns -queryTableExplicit cm table = Q.simpleQueryArr f where +queryTableExplicit cm table' = Q.simpleQueryArr f where f ((), t0) = (retwires, primQ, Tag.next t0) where - (retwires, primQ) = T.queryTable cm table t0 + (retwires, primQ) = T.queryTable cm table' t0