diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,51 @@ +## 0.6.7000.0 + +This is a pre-release of version 0.7.0.0. GHC >= 8.0 is required. It +contains the following new important features + +* A new API for manipulation, including `ON CONFLICT DO NOTHING` + support for `UPDATE` + +* Initial support for product types written in "Higher kinded data" + style (but deriving of related functionality using TH or Generics is + not yet provided). + +* Type inference for outer joins + +* Many renamings. In particular, `Column` will become `Field` in + 0.7.0.0. You should be able to almost completely port your code to + the 0.7.0.0 names whilst remaining compatible with 0.6.7000.0. + +### Details + +* Added `Opaleye.RunSelect` + +* Added `Opaleye.Field` + +* `queryTable` is renamed `selectTable` + +* `Query`/`QueryArr` are renamed `Select`/`SelectArr` + +* `QueryRunner` is renamed `FromFields` + +* `QueryRunnerColumn` is renamed `FromField` + +* `Constant` is renamed `ToFields` + +* `constant` is renamed `toFields` + +* Added `Opaleye.SqlTypes` and `sql`/`Sql...` names instead of + `pg`/`PG...` names + +* Added `runInsert_`, `runUpdate_`, `runDelete_` and supporting + functionality + +* Add `PGNumeric` type + +* Added `leftJoinA` + +* Added `liesWithin` + ## 0.6.1.0 * Added `ZonedTime` to `PGTimestamptz` mappings diff --git a/Doc/Tutorial/DefaultExplanation.lhs b/Doc/Tutorial/DefaultExplanation.lhs --- a/Doc/Tutorial/DefaultExplanation.lhs +++ b/Doc/Tutorial/DefaultExplanation.lhs @@ -2,7 +2,7 @@ > module DefaultExplanation where > > import Opaleye (Column, Nullable, QueryRunner, Query, -> PGInt4, PGBool, PGText, PGFloat4) +> SqlInt4, SqlBool, SqlText, SqlFloat4) > import qualified Opaleye as O > import qualified Opaleye.Internal.Binary as Internal.Binary > import Opaleye.Internal.Binary (Binaryspec) @@ -33,31 +33,31 @@ > unionAllExplicit = O.unionAllExplicit What is the `Binaryspec` used for here? Let's take a simple case -where we want to union two queries of type `Query (Column PGInt4, -Column PGText)` +where we want to union two queries of type `Query (Column SqlInt4, +Column SqlText)` -> myQuery1 :: Query (Column PGInt4, Column PGText) +> myQuery1 :: Query (Column SqlInt4, Column SqlText) > myQuery1 = undefined -- We won't actually need specific implementations here > -> myQuery2 :: Query (Column PGInt4, Column PGText) +> myQuery2 :: Query (Column SqlInt4, Column SqlText) > myQuery2 = undefined That means we will be using unionAll at the type -> unionAllExplicit' :: Binaryspec (Column PGInt4, Column PGText) (Column PGInt4, Column PGText) -> -> Query (Column PGInt4, Column PGText) -> -> Query (Column PGInt4, Column PGText) -> -> Query (Column PGInt4, Column PGText) +> unionAllExplicit' :: Binaryspec (Column SqlInt4, Column SqlText) (Column SqlInt4, Column SqlText) +> -> Query (Column SqlInt4, Column SqlText) +> -> Query (Column SqlInt4, Column SqlText) +> -> Query (Column SqlInt4, Column SqlText) > unionAllExplicit' = unionAllExplicit Since every `Column` is actually just a string containing an SQL -expression, `(Column PGInt4, Column PGText)` is a pair of expressions. +expression, `(Column SqlInt4, Column SqlText)` is a pair of expressions. When we generate the SQL we need to take the two pairs of expressions, generate new unique names that refer to them and produce these new -unique names in another value of type `(Column PGInt4, Column -PGText)`. This is exactly what a value of type +unique names in another value of type `(Column SqlInt4, Column +SqlText)`. This is exactly what a value of type - Binaryspec (Column PGInt4, Column PGText) (Column PGInt4, Column PGText) + Binaryspec (Column SqlInt4, Column SqlText) (Column SqlInt4, Column SqlText) allows us to do. @@ -76,7 +76,7 @@ Then we can use `binaryspecColumn2` in `unionAllExplicit`. -> theUnionAll :: Query (Column PGInt4, Column PGText) +> theUnionAll :: Query (Column SqlInt4, Column SqlText) > theUnionAll = unionAllExplicit binaryspecColumn2 myQuery1 myQuery2 Now suppose that we wanted to take a union of two queries with columns @@ -132,7 +132,7 @@ > => Query a -> Query a -> Query b > unionAll = O.unionAllExplicit def > -> theUnionAll' :: Query (Column PGInt4, Column PGText) +> theUnionAll' :: Query (Column SqlInt4, Column SqlText) > theUnionAll' = unionAll myQuery1 myQuery2 In the long run this prevents writing a huge amount of boilerplate code. @@ -150,28 +150,28 @@ Basic values of `QueryRunner` will have the following types -> intRunner :: QueryRunner (Column PGInt4) Int +> intRunner :: QueryRunner (Column SqlInt4) Int > intRunner = undefined -- The implementation is not important here > -> doubleRunner :: QueryRunner (Column PGFloat4) Double +> doubleRunner :: QueryRunner (Column SqlFloat4) Double > doubleRunner = undefined > -> stringRunner :: QueryRunner (Column PGText) String +> stringRunner :: QueryRunner (Column SqlText) String > stringRunner = undefined > -> boolRunner :: QueryRunner (Column PGBool) Bool +> boolRunner :: QueryRunner (Column SqlBool) Bool > boolRunner = undefined Furthermore we will have basic ways of running queries which return `Nullable` values, for example -> nullableIntRunner :: QueryRunner (Column (Nullable PGInt4)) (Maybe Int) +> nullableIntRunner :: QueryRunner (Column (Nullable SqlInt4)) (Maybe Int) > nullableIntRunner = undefined -If I have a very simple query with a single column of `PGInt4` then I can +If I have a very simple query with a single column of `SqlInt4` then I can run it using the `intRunner`. -> myQuery3 :: Query (Column PGInt4) +> myQuery3 :: Query (Column SqlInt4) > myQuery3 = undefined -- The implementation is not important > > runTheQuery :: SQL.Connection -> IO [Int] @@ -180,11 +180,11 @@ If my query has several columns of different types I need to build up a larger `QueryRunner`. -> myQuery4 :: Query (Column PGInt4, Column PGText, Column PGBool, Column (Nullable PGInt4)) +> myQuery4 :: Query (Column SqlInt4, Column SqlText, Column SqlBool, Column (Nullable SqlInt4)) > myQuery4 = undefined > > largerQueryRunner :: QueryRunner -> (Column PGInt4, Column PGText, Column PGBool, Column (Nullable PGInt4)) +> (Column SqlInt4, Column SqlText, Column SqlBool, Column (Nullable SqlInt4)) > (Int, String, Bool, Maybe Int) > largerQueryRunner = p4 (intRunner, stringRunner, boolRunner, nullableIntRunner) > @@ -196,8 +196,8 @@ `Karamaan.Opaleye.RunQuery` already gives us `Default` instances for the following types (plus many others, of course!). -* `QueryRunner (Column PGInt4) Int` -* `QueryRunner (Column PGText) String` +* `QueryRunner (Column SqlInt4) Int` +* `QueryRunner (Column SqlText) String` * `QueryRunner (Column Bool) Bool` * `QueryRunner (Column (Nullable Int)) (Maybe Int)` @@ -205,7 +205,7 @@ correct value of the type we want. > largerQueryRunner' :: QueryRunner -> (Column PGInt4, Column PGText, Column PGBool, Column (Nullable PGInt4)) +> (Column SqlInt4, Column SqlText, Column SqlBool, Column (Nullable SqlInt4)) > (Int, String, Bool, Maybe Int) > largerQueryRunner' = def diff --git a/Doc/Tutorial/TutorialAdvanced.lhs b/Doc/Tutorial/TutorialAdvanced.lhs --- a/Doc/Tutorial/TutorialAdvanced.lhs +++ b/Doc/Tutorial/TutorialAdvanced.lhs @@ -7,7 +7,7 @@ > import Opaleye.QueryArr (Query) > import Opaleye.Column (Column) > import Opaleye.Table (Table, table, tableColumn, queryTable) -> import Opaleye.PGTypes (PGText, PGInt4) +> import Opaleye.SqlTypes (SqlText, SqlInt4) > import qualified Opaleye.Aggregate as A > import Opaleye.Aggregate (Aggregator, aggregate) > @@ -32,18 +32,18 @@ advantage of treating `range` as a first-class value able to be passed around between functions and manipulated at will. -> range :: Aggregator (Column PGInt4) (Column PGInt4) +> range :: Aggregator (Column SqlInt4) (Column SqlInt4) > range = dimap (\x -> (x, x)) (uncurry (-)) (A.max ***! A.min) We can test it on a person table which contains rows containing people's names along with the age of their children. -> personTable :: Table (Column PGText, Column PGInt4) -> (Column PGText, Column PGInt4) +> personTable :: Table (Column SqlText, Column SqlInt4) +> (Column SqlText, Column SqlInt4) > personTable = table "personTable" (p2 ( tableColumn "name" > , tableColumn "child_age" )) -> rangeOfChildrensAges :: Query (Column PGText, Column PGInt4) +> rangeOfChildrensAges :: Query (Column SqlText, Column SqlInt4) > 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 @@ -12,10 +12,10 @@ > Table, table, tableColumn, queryTable, > Query, QueryArr, restrict, (.==), (.<=), (.&&), (.<), > (.===), -> (.++), ifThenElse, pgString, aggregate, groupBy, +> (.++), ifThenElse, sqlString, aggregate, groupBy, > count, avg, sum, leftJoin, runQuery, > showSqlForPostgres, Unpackspec, -> PGInt4, PGInt8, PGText, PGDate, PGFloat8, PGBool) +> SqlInt4, SqlInt8, SqlText, SqlDate, SqlFloat8, SqlBool) > > import Data.Profunctor.Product (p2, p3) > import Data.Profunctor.Product.Default (Default) @@ -42,7 +42,7 @@ there is no support for creating databases or tables, though these features may be added later according to demand. -A table is defined with the `Table` constructor. The syntax is +A table is defined with the `table` function. The syntax is simple. You specify the types of the columns, the name of the table and the names of the columns in the underlying database, and whether the columns are required or optional. @@ -59,8 +59,8 @@ `Table` types will have the same type argument repeated twice. In the manipulation tutorial you can see an example of when they might differ. -> personTable :: Table (Column PGText, Column PGInt4, Column PGText) -> (Column PGText, Column PGInt4, Column PGText) +> personTable :: Table (Column SqlText, Column SqlInt4, Column SqlText) +> (Column SqlText, Column SqlInt4, Column SqlText) > personTable = table "personTable" (p3 ( tableColumn "name" > , tableColumn "age" > , tableColumn "address" )) @@ -79,7 +79,7 @@ because they are simpler to read and the typeclass magic is essentially invisible.) -> personQuery :: Query (Column PGText, Column PGInt4, Column PGText) +> personQuery :: Query (Column SqlText, Column SqlInt4, Column SqlText) > personQuery = queryTable personTable A `Query` corresponds to an SQL SELECT that we can run. Here is the @@ -126,7 +126,7 @@ > data Birthday' a b = Birthday { bdName :: a, bdDay :: b } > type Birthday = Birthday' String Day -> type BirthdayColumn = Birthday' (Column PGText) (Column PGDate) +> type BirthdayColumn = Birthday' (Column SqlText) (Column SqlDate) To get user defined types to work with the typeclass magic they must have instances defined for them. The instances are derivable with @@ -181,7 +181,7 @@ arguments". We pattern match on the results and return only the columns we are interested in. -> nameAge :: Query (Column PGText, Column PGInt4) +> nameAge :: Query (Column SqlText, Column SqlInt4) > nameAge = proc () -> do > (name, age, _) <- personQuery -< () > returnA -< (name, age) @@ -209,7 +209,7 @@ and `birthdayQuery`. > personBirthdayProduct :: -> Query ((Column PGText, Column PGInt4, Column PGText), BirthdayColumn) +> Query ((Column SqlText, Column SqlInt4, Column SqlText), BirthdayColumn) > personBirthdayProduct = proc () -> do > personRow <- personQuery -< () > birthdayRow <- birthdayQuery -< () @@ -256,7 +256,7 @@ We can restrict `personQuery` to the rows where the person is up to 18 years old. -> youngPeople :: Query (Column PGText, Column PGInt4, Column PGText) +> youngPeople :: Query (Column SqlText, Column SqlInt4, Column SqlText) > youngPeople = proc () -> do > row@(_, age, _) <- personQuery -< () > restrict -< age .<= 18 @@ -286,12 +286,12 @@ We can use a variety of operators to form more complex restriction conditions. -> twentiesAtAddress :: Query (Column PGText, Column PGInt4, Column PGText) +> twentiesAtAddress :: Query (Column SqlText, Column SqlInt4, Column SqlText) > twentiesAtAddress = proc () -> do > row@(_, age, address) <- personQuery -< () > > restrict -< (20 .<= age) .&& (age .< 30) -> restrict -< address .== pgString "1 My Street, My Town" +> restrict -< address .== sqlString "1 My Street, My Town" > > returnA -< row @@ -327,7 +327,7 @@ such. > personAndBirthday :: -> Query (Column PGText, Column PGInt4, Column PGText, Column PGDate) +> Query (Column SqlText, Column SqlInt4, Column SqlText, Column SqlDate) > personAndBirthday = proc () -> do > (name, age, address) <- personQuery -< () > birthday <- birthdayQuery -< () @@ -380,21 +380,21 @@ of each employee and the name of their boss. If their boss is recorded as NULL then that means they have no boss! -> employeeTable :: Table (Column PGText, Column (Nullable PGText)) -> (Column PGText, Column (Nullable PGText)) +> employeeTable :: Table (Column SqlText, Column (Nullable SqlText)) +> (Column SqlText, Column (Nullable SqlText)) > 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. -> hasBoss :: Query (Column PGText) +> hasBoss :: Query (Column SqlText) > hasBoss = proc () -> do > (name, nullableBoss) <- queryTable employeeTable -< () > -> let aOrNo = ifThenElse (isNull nullableBoss) (pgString "no") (pgString "a") +> let aOrNo = ifThenElse (isNull nullableBoss) (sqlString "no") (sqlString "a") > -> returnA -< name .++ pgString " has " .++ aOrNo .++ pgString " boss" +> returnA -< name .++ sqlString " has " .++ aOrNo .++ sqlString " boss" ghci> printSql hasBoss @@ -419,11 +419,11 @@ returns its first argument. If not it passes the non-NULL value to the function that is the second argument. -> bossQuery :: QueryArr (Column PGText, Column (Nullable PGText)) (Column PGText) +> bossQuery :: QueryArr (Column SqlText, Column (Nullable SqlText)) (Column SqlText) > bossQuery = proc (name, nullableBoss) -> do -> returnA -< matchNullable (name .++ pgString " has no boss") -> (\boss -> pgString "The boss of " .++ name -> .++ pgString " is " .++ boss) +> returnA -< matchNullable (name .++ sqlString " has no boss") +> (\boss -> sqlString "The boss of " .++ name +> .++ sqlString " is " .++ boss) > nullableBoss Note that `matchNullable` corresponds to Haskell's @@ -474,13 +474,13 @@ just a synonym for `QueryArr ()` which means that it is a `QueryArr` that does not read any columns.) -> restrictIsTwenties :: QueryArr (Column PGInt4) () +> restrictIsTwenties :: QueryArr (Column SqlInt4) () > restrictIsTwenties = proc age -> do > restrict -< (20 .<= age) .&& (age .< 30) > -> restrictAddressIs1MyStreet :: QueryArr (Column PGText) () +> restrictAddressIs1MyStreet :: QueryArr (Column SqlText) () > restrictAddressIs1MyStreet = proc address -> do -> restrict -< address .== pgString "1 My Street, My Town" +> restrict -< address .== sqlString "1 My Street, My Town" We can't generate "the SQL of" these combinators. They are not `Query`s so they don't have any SQL! (This corresponds to the @@ -488,7 +488,7 @@ functions cannot be "shown".) Instead we use them to reimplement `twentiesAtAddress` in a more neatly-factored way. -> twentiesAtAddress' :: Query (Column PGText, Column PGInt4, Column PGText) +> twentiesAtAddress' :: Query (Column SqlText, Column SqlInt4, Column SqlText) > twentiesAtAddress' = proc () -> do > row@(_, age, address) <- personQuery -< () > @@ -519,7 +519,7 @@ pulling out a `QueryArr` which perform the mapping of a person's name to their date of birth by looking up in `birthdayQuery`. -> birthdayOfPerson :: QueryArr (Column PGText) (Column PGDate) +> birthdayOfPerson :: QueryArr (Column SqlText) (Column SqlDate) > birthdayOfPerson = proc name -> do > birthday <- birthdayQuery -< () > @@ -530,7 +530,7 @@ We can then reimplement `personAndBirthday` as follows > personAndBirthday' :: -> Query (Column PGText, Column PGInt4, Column PGText, Column PGDate) +> Query (Column SqlText, Column SqlInt4, Column SqlText, Column SqlDate) > personAndBirthday' = proc () -> do > (name, age, address) <- personQuery -< () > birthday <- birthdayOfPerson -< name @@ -580,10 +580,10 @@ For the purposes of this example the style, color and location will be strings, but in practice they might have been a different data type. -> widgetTable :: Table (Widget (Column PGText) (Column PGText) (Column PGText) -> (Column PGInt4) (Column PGFloat8)) -> (Widget (Column PGText) (Column PGText) (Column PGText) -> (Column PGInt4) (Column PGFloat8)) +> widgetTable :: Table (Widget (Column SqlText) (Column SqlText) (Column SqlText) +> (Column SqlInt4) (Column SqlFloat8)) +> (Widget (Column SqlText) (Column SqlText) (Column SqlText) +> (Column SqlInt4) (Column SqlFloat8)) > widgetTable = table "widgetTable" > (pWidget Widget { style = tableColumn "style" > , color = tableColumn "color" @@ -597,8 +597,8 @@ of such widgets and their average radius. `aggregateWidgets` shows us how to do this. -> aggregateWidgets :: Query (Widget (Column PGText) (Column PGText) (Column PGInt8) -> (Column PGInt4) (Column PGFloat8)) +> aggregateWidgets :: Query (Widget (Column SqlText) (Column SqlText) (Column SqlInt8) +> (Column SqlInt4) (Column SqlFloat8)) > aggregateWidgets = aggregate (pWidget Widget { style = groupBy > , color = groupBy > , location = count @@ -659,13 +659,13 @@ nullability. We introduce the following type synonym for this purpose, which is just a notational convenience. -> type ColumnNullableBirthday = Birthday' (Column (Nullable PGText)) -> (Column (Nullable PGDate)) +> type ColumnNullableBirthday = Birthday' (Column (Nullable SqlText)) +> (Column (Nullable SqlDate)) A left join is expressed by specifying the two tables to join and the join condition. -> personBirthdayLeftJoin :: Query ((Column PGText, Column PGInt4, Column PGText), +> personBirthdayLeftJoin :: Query ((Column SqlText, Column SqlInt4, Column SqlText), > ColumnNullableBirthday) > personBirthdayLeftJoin = leftJoin personQuery birthdayQuery eqName > where eqName ((name, _, _), birthdayRow) = name .== bdName birthdayRow @@ -745,11 +745,11 @@ > > $(makeAdaptorAndInstance "pWarehouse" ''Warehouse') -We could represent the integer ID in Opaleye as a `PGInt4` +We could represent the integer ID in Opaleye as a `SqlInt4` -> type BadWarehouseColumn = Warehouse' (Column PGInt4) -> (Column PGText) -> (Column PGInt4) +> type BadWarehouseColumn = Warehouse' (Column SqlInt4) +> (Column SqlText) +> (Column SqlInt4) > > badWarehouseTable :: Table BadWarehouseColumn BadWarehouseColumn > badWarehouseTable = table "warehouse_table" @@ -761,7 +761,7 @@ can meaninglessly relate the warehouse ID with the quantity of goods it holds. -> badComparison :: BadWarehouseColumn -> Column PGBool +> badComparison :: BadWarehouseColumn -> Column SqlBool > badComparison w = wId w .== wNumGoods w On the other hand we can make a newtype for the warehouse ID @@ -769,11 +769,11 @@ > newtype WarehouseId' a = WarehouseId a > $(makeAdaptorAndInstance "pWarehouseId" ''WarehouseId') > -> type WarehouseIdColumn = WarehouseId' (Column PGInt4) +> type WarehouseIdColumn = WarehouseId' (Column SqlInt4) > > type GoodWarehouseColumn = Warehouse' WarehouseIdColumn -> (Column PGText) -> (Column PGInt4) +> (Column SqlText) +> (Column SqlInt4) > > goodWarehouseTable :: Table GoodWarehouseColumn GoodWarehouseColumn > goodWarehouseTable = table "warehouse_table" @@ -783,16 +783,16 @@ Now the comparison will not pass the type checker -> -- forbiddenComparison :: GoodWarehouseColumn -> Column PGBool +> -- forbiddenComparison :: GoodWarehouseColumn -> Column SqlBool > -- forbiddenComparison w = wId w .== wNumGoods w > -- -> -- => Couldn't match type `WarehouseId' (Column PGInt4)' with `Column PGInt4' +> -- => Couldn't match type `WarehouseId' (Column SqlInt4)' with `Column SqlInt4' but we can compare two `WarehouseIdColumn`s. > permittedComparison :: GoodWarehouseColumn > -> GoodWarehouseColumn -> -> Column PGBool +> -> Column SqlBool > permittedComparison w1 w2 = wId w1 .=== wId w2 (Currently we use `.===`, a more polymorphic version of `.==`, but @@ -818,7 +818,7 @@ the following type: > runTwentiesQuery :: PGS.Connection -> -> Query (Column PGText, Column PGInt4, Column PGText) +> -> Query (Column SqlText, Column SqlInt4, Column SqlText) > -> IO [(String, Int, String)] > runTwentiesQuery = runQuery @@ -828,13 +828,13 @@ Maybes. We could run the query `queryTable employeeTable` like this. > runEmployeesQuery :: PGS.Connection -> -> Query (Column PGText, Column (Nullable PGText)) +> -> Query (Column SqlText, Column (Nullable SqlText)) > -> IO [(String, Maybe String)] > runEmployeesQuery = runQuery Newtypes are taken care of automatically by the typeclass instance that was generated by `makeAdaptorAndInstance`. A `WarehouseId' -(Column PGInt4)` becomes a `WarehouseId' Int` when the query is run. +(Column SqlInt4)` becomes a `WarehouseId' Int` when the query is run. We could run the query `queryTable goodWarehouseTable` like this. > type WarehouseId = WarehouseId' Int diff --git a/Doc/Tutorial/TutorialBasicMonomorphic.lhs b/Doc/Tutorial/TutorialBasicMonomorphic.lhs --- a/Doc/Tutorial/TutorialBasicMonomorphic.lhs +++ b/Doc/Tutorial/TutorialBasicMonomorphic.lhs @@ -13,7 +13,7 @@ > aggregate, groupBy, > count, avg, sum, leftJoin, runQuery, > showSqlForPostgres, Unpackspec, -> PGInt4, PGInt8, PGText, PGDate, PGFloat8) +> SqlInt4, SqlInt8, SqlText, SqlDate, SqlFloat8) > > import qualified Opaleye as O > @@ -44,7 +44,7 @@ there is no support for creating databases or tables, though these features may be added later according to demand. -A table is defined with the `Table` constructor. The syntax is +A table is defined with the `table` function. The syntax is simple. You specify the types of the columns, the name of the table and the names of the columns in the underlying database, and whether the columns are required or optional. @@ -61,14 +61,14 @@ `Table` types will have the same type argument repeated twice. In the manipulation tutorial you can see an example of when they might differ. -> personTable :: Table (Column PGText, Column PGInt4, Column PGText) -> (Column PGText, Column PGInt4, Column PGText) +> personTable :: Table (Column SqlText, Column SqlInt4, Column SqlText) +> (Column SqlText, Column SqlInt4, Column SqlText) > 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 (Column SqlText, Column SqlInt4, Column SqlText) +> (Column SqlText, Column SqlInt4, Column SqlText) > personTable' = table "personTable" (p3 ( tableColumn "name" > , tableColumn "age" > , tableColumn "address" )) @@ -87,7 +87,7 @@ because they are simpler to read and the typeclass magic is essentially invisible.) -> personQuery :: Query (Column PGText, Column PGInt4, Column PGText) +> personQuery :: Query (Column SqlText, Column SqlInt4, Column SqlText) > personQuery = queryTable personTable A `Query` corresponds to an SQL SELECT that we can run. Here is the @@ -132,16 +132,16 @@ mean that you have to define more datatypes and more instances for them. -> data BirthdayColumn = BirthdayColumn { bdNameColumn :: Column PGText -> , bdDayColumn :: Column PGDate } +> data BirthdayColumn = BirthdayColumn { bdNameColumn :: Column SqlText +> , bdDayColumn :: Column SqlDate } > > data Birthday = Birthday { bdName :: String, bdDay :: Day } > > birthdayColumnDef :: > (Applicative (p BirthdayColumn), > P.Profunctor p, -> Default p (Column PGText) (Column PGText), -> Default p (Column PGDate) (Column PGDate)) => +> Default p (Column SqlText) (Column SqlText), +> Default p (Column SqlDate) (Column SqlDate)) => > p BirthdayColumn BirthdayColumn > birthdayColumnDef = BirthdayColumn <$> P.lmap bdNameColumn D.def > <*> P.lmap bdDayColumn D.def @@ -192,11 +192,11 @@ style, color, location, quantity and radius of widgets. We can model this information with the following datatype. -> data WidgetColumn = WidgetColumn { style :: Column PGText -> , color :: Column PGText -> , location :: Column PGText -> , quantity :: Column PGInt4 -> , radius :: Column PGFloat8 +> data WidgetColumn = WidgetColumn { style :: Column SqlText +> , color :: Column SqlText +> , location :: Column SqlText +> , quantity :: Column SqlInt4 +> , radius :: Column SqlFloat8 > } > > instance Default Unpackspec WidgetColumn WidgetColumn where @@ -223,8 +223,8 @@ of such widgets and their average radius. `aggregateWidgets` shows us how to do this. -> aggregateWidgets :: Query (Column PGText, Column PGText, Column PGInt8, -> Column PGInt4, Column PGFloat8) +> aggregateWidgets :: Query (Column SqlText, Column SqlText, Column SqlInt8, +> Column SqlInt4, Column SqlFloat8) > aggregateWidgets = aggregate ((,,,,) <$> P.lmap style groupBy > <*> P.lmap color groupBy > <*> P.lmap location count @@ -270,8 +270,8 @@ uses of our Template Haskell derived code. We use the 'pWidget' "adaptor" to specify how columns are aggregated. Note that this is yet another example of avoiding a headache by keeping your datatype -fully polymorphic, because the 'count' aggregator changes a 'Wire -String' into a 'Wire Int64'. +fully polymorphic, because the 'count' aggregator changes a 'Column +String' into a 'Column Int64'. Outer join ========== @@ -286,8 +286,8 @@ purpose, which is just a notational convenience. > data BirthdayColumnNullable = -> BirthdayColumnNullable { bdNameColumnNullable :: Column (Nullable PGText) -> , bdDayColumnNullable :: Column (Nullable PGDate) } +> BirthdayColumnNullable { bdNameColumnNullable :: Column (Nullable SqlText) +> , bdDayColumnNullable :: Column (Nullable SqlDate) } > > instance Default O.Unpackspec BirthdayColumnNullable BirthdayColumnNullable where > def = BirthdayColumnNullable <$> P.lmap bdNameColumnNullable D.def @@ -303,7 +303,7 @@ A left join is expressed by specifying the two tables to join and the join condition. -> personBirthdayLeftJoin :: Query ((Column PGText, Column PGInt4, Column PGText), +> personBirthdayLeftJoin :: Query ((Column SqlText, Column SqlInt4, Column SqlText), > BirthdayColumnNullable) > personBirthdayLeftJoin = leftJoin personQuery birthdayQuery eqName > where eqName ((name, _, _), birthdayRow) = diff --git a/Doc/Tutorial/TutorialBasicTypeFamilies.lhs b/Doc/Tutorial/TutorialBasicTypeFamilies.lhs --- a/Doc/Tutorial/TutorialBasicTypeFamilies.lhs +++ b/Doc/Tutorial/TutorialBasicTypeFamilies.lhs @@ -6,24 +6,33 @@ > {-# LANGUAGE TypeFamilies #-} > {-# LANGUAGE EmptyDataDecls #-} > {-# LANGUAGE FunctionalDependencies #-} +> {-# LANGUAGE NoMonomorphismRestriction #-} +> {-# LANGUAGE DataKinds #-} +> {-# LANGUAGE TypeOperators #-} > > module TutorialBasicTypeFamilies where > > import Prelude hiding (sum) > -> import Opaleye (Column, Nullable, +> import Opaleye (Column, > Table, table, tableColumn, queryTable, > Query, (.==), aggregate, groupBy, > count, avg, sum, leftJoin, runQuery, > showSqlForPostgres, Unpackspec, -> PGInt4, PGInt8, PGText, PGDate, PGFloat8) +> SqlInt4, SqlInt8, SqlText, SqlDate, SqlFloat8) > -> import Control.Applicative ((<$>), (<*>), Applicative) +> import qualified Opaleye as O +> import qualified Opaleye.Map as M +> import Opaleye.TypeFamilies (O, H, NN, Req, Nulls, W, +> TableField, IMap, F, +> (:<$>), (:<*>)) > > import qualified Data.Profunctor as P +> import qualified Data.Profunctor.Product as PP > 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 Database.PostgreSQL.Simple as PGS @@ -44,10 +53,9 @@ there is no support for creating databases or tables, though these features may be added later according to demand. -A table is defined with the `Table` constructor. The syntax is +A table is defined with the `table` function. The syntax is simple. You specify the types of the columns, the name of the table -and the names of the columns in the underlying database, and whether -the columns are required or optional. +and the names of the columns in the underlying database. (Note: This simple syntax is supported by an extra combinator that describes the shape of the container that you are storing the columns @@ -56,20 +64,18 @@ The `Table` type constructor has two arguments. The first one tells us what columns we can write to the table and the second what columns -we can read from the table. In this document we will always make all -columns required, so the write and read types will be the same. All -`Table` types will have the same type argument repeated twice. In the -manipulation tutorial you can see an example of when they might differ. +we can read from the table. In this case all columns are required, so +the write and read types will be the same. -> personTable :: Table (Column PGText, Column PGInt4, Column PGText) -> (Column PGText, Column PGInt4, Column PGText) +> personTable :: Table (Column SqlText, Column SqlInt4, Column SqlText) +> (Column SqlText, Column SqlInt4, Column SqlText) > 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`. @@ -81,21 +87,23 @@ because they are simpler to read and the typeclass magic is essentially invisible.) -> personQuery :: Query (Column PGText, Column PGInt4, Column PGText) +> personQuery :: Query (Column SqlText, Column SqlInt4, Column SqlText) > personQuery = queryTable personTable A `Query` corresponds to an SQL SELECT that we can run. Here is the -SQL generated for `personQuery`. +SQL generated for `personQuery`. (`printSQL` is just a convenient +utility function for the purposes of this example file. See below for +its definition.) -ghci> printSql personQuery -SELECT name0_1 as result1, - age1_1 as result2, - address2_1 as result3 -FROM (SELECT * - FROM (SELECT name as name0_1, - age as age1_1, - address as address2_1 - FROM personTable as T1) as T1) as T1 + ghci> printSql personQuery + SELECT name0_1 as result1, + age1_1 as result2, + address2_1 as result3 + FROM (SELECT * + FROM (SELECT name as name0_1, + age as age1_1, + address as address2_1 + FROM personTable as T1) as T1) as T1 This SQL is functionally equivalent to the following "idealized" SQL. In this document every example of SQL generated by Opaleye will be @@ -107,13 +115,10 @@ between Opaleye's version and the ideal. Please submit any differences encountered in practice as an Opaleye bug. -SELECT name, - age - address -FROM personTable - -(`printSQL` is just a convenient utility function for the purposes of -this example file. See below for its definition.) + SELECT name, + age + address + FROM personTable Record types @@ -126,71 +131,59 @@ using type families that reduces boiler plate and has always been compatible with Opaleye! -> type family Field f a b n -> type family TableField f a b n req -> -> data H -> data O -> data Nulls -> data W -> -> data NN -> data N -> -> data Req -> data Opt -> -> type instance Field H h o NN = h -> type instance Field H h o N = Maybe h -> type instance Field O h o NN = Column o -> type instance Field O h o N = Column (Nullable o) -> -> type instance TableField H h o n b = Field H h o n -> type instance TableField O h o n b = Field O h o n -> type instance TableField W h o n Req = Field O h o n -> type instance TableField W h o n Opt = Maybe (Field O h o n) -> type instance TableField Nulls h o n b = Column (Nullable o) -> > -- Cryptic remark: If we were willing to only support 7.8 and up we > -- 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 > -> data Birthday f = Birthday { bdName :: TableField f String PGText NN Req -> , bdDay :: TableField f Day PGDate NN Req +> data Birthday f = Birthday { bdName :: TableField f String SqlText NN Req +> , bdDay :: TableField f Day SqlDate NN Req > } -> -> instance ( Applicative (p (Birthday a)) -> , P.Profunctor p -> , Default p (TableField a String PGText NN Req) (TableField b String PGText NN Req) -> , Default p (TableField a Day PGDate NN Req) (TableField b Day PGDate NN Req)) => + +This instance, adaptor and type family are fully derivable by Template +Haskell or generics but I haven't got round to writing that yet. +Please volunteer to do that if you can. + +> instance ( PP.ProductProfunctor p +> , Default p (TableField a String SqlText NN Req) +> (TableField b String SqlText NN Req) +> , Default p (TableField a Day SqlDate NN Req) +> (TableField b Day SqlDate NN Req)) => > Default p (Birthday a) (Birthday b) where -> def = Birthday <$> P.lmap bdName D.def -> <*> P.lmap bdDay D.def +> def = pBirthday (Birthday D.def D.def) +> +> pBirthday :: PP.ProductProfunctor p +> => Birthday (p :<$> a :<*> b) +> -> p (Birthday a) (Birthday b) +> pBirthday (Birthday a b) = Birthday PP.***$ P.lmap bdName a +> PP.**** P.lmap bdDay b +> +> type instance M.Map g (Birthday (F f)) = Birthday (F (IMap g f)) 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 (tableColumn "name") -> <*> P.lmap bdDay (tableColumn "birthday")) +> birthdayTable = table "birthdayTable" $ pBirthday $ Birthday { +> bdName = tableColumn "name" +> , bdDay = tableColumn "birthday" +> } > > birthdayQuery :: Query (Birthday O) > birthdayQuery = queryTable birthdayTable -ghci> printSql birthdayQuery -SELECT name0_1 as result1, - birthday1_1 as result2 -FROM (SELECT * - FROM (SELECT name as name0_1, - birthday as birthday1_1 - FROM birthdayTable as T1) as T1) as T1 + ghci> printSql birthdayQuery + SELECT name0_1 as result1, + birthday1_1 as result2 + FROM (SELECT * + FROM (SELECT name as name0_1, + birthday as birthday1_1 + FROM birthdayTable as T1) as T1) as T1 Idealized SQL: -SELECT name, - birthday -FROM birthdayTable + SELECT name, + birthday + FROM birthdayTable Aggregation @@ -206,45 +199,56 @@ style, color, location, quantity and radius of widgets. We can model this information with the following datatype. -> data Widget f = Widget { style :: Field f String PGText NN -> , color :: Field f String PGText NN -> , location :: Field f String PGText NN -> , quantity :: Field f Int PGInt4 NN -> , radius :: Field f Double PGFloat8 NN +> data Widget f = Widget { style :: TableField f String SqlText NN Req +> , color :: TableField f String SqlText NN Req +> , location :: TableField f String SqlText NN Req +> , quantity :: TableField f Int SqlInt4 NN Req +> , radius :: TableField f Double SqlFloat8 NN Req > } -> -> instance ( Applicative (p (Widget a)) -> , P.Profunctor p -> , Default p (Field a String PGText NN) (Field b String PGText NN) -> , Default p (Field a Int PGInt4 NN) (Field b Int PGInt4 NN) -> , Default p (Field a Double PGFloat8 NN) (Field b Double PGFloat8 NN) -> , Default p (Field a Day PGDate NN) (Field b Day PGDate NN)) => + +This instance, adaptor and type family are fully derivable but no +one's implemented the Template Haskell or generics to do that yet. + +> instance ( PP.ProductProfunctor p +> , Default p (TableField a String SqlText NN Req) +> (TableField b String SqlText NN Req) +> , Default p (TableField a Int SqlInt4 NN Req) +> (TableField b Int SqlInt4 NN Req) +> , Default p (TableField a Double SqlFloat8 NN Req) +> (TableField b Double SqlFloat8 NN Req)) => > Default p (Widget a) (Widget b) where -> def = Widget <$> P.lmap style D.def -> <*> P.lmap color D.def -> <*> P.lmap location D.def -> <*> P.lmap quantity D.def -> <*> P.lmap radius D.def +> def = pWidget (Widget D.def D.def D.def D.def D.def) +> +> pWidget :: PP.ProductProfunctor p +> => Widget (p :<$> a :<*> b) +> -> p (Widget a) (Widget b) +> pWidget (Widget a b c d e) = Widget PP.***$ P.lmap style a +> PP.**** P.lmap color b +> PP.**** P.lmap location c +> PP.**** P.lmap quantity d +> PP.**** P.lmap radius e +> +> type instance M.Map g (Widget (F f)) = Widget (F (IMap g f)) For the purposes of this example the style, color and location will be 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 (tableColumn "style") -> <*> P.lmap color (tableColumn "color") -> <*> P.lmap location (tableColumn "location") -> <*> P.lmap quantity (tableColumn "quantity") -> <*> P.lmap radius (tableColumn "radius")) - +> widgetTable :: Table (Widget W) (Widget O) +> 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 how many (possibly duplicated) locations there are, the total number of such widgets and their average radius. `aggregateWidgets` shows us how to do this. -> aggregateWidgets :: Query (Column PGText, Column PGText, Column PGInt8, -> Column PGInt4, Column PGFloat8) +> aggregateWidgets :: Query (Column SqlText, Column SqlText, Column SqlInt8, +> Column SqlInt4, Column SqlFloat8) > aggregateWidgets = aggregate ((,,,,) <$> P.lmap style groupBy > <*> P.lmap color groupBy > <*> P.lmap location count @@ -254,121 +258,109 @@ The generated SQL is -ghci> printSql aggregateWidgets -SELECT result0_2 as result1, - result1_2 as result2, - result2_2 as result3, - result3_2 as result4, - result4_2 as result5 -FROM (SELECT * - FROM (SELECT style0_1 as result0_2, - color1_1 as result1_2, - COUNT(location2_1) as result2_2, - SUM(quantity3_1) as result3_2, - AVG(radius4_1) as result4_2 - FROM (SELECT * - FROM (SELECT style as style0_1, - color as color1_1, - location as location2_1, - quantity as quantity3_1, - radius as radius4_1 - FROM widgetTable as T1) as T1) as T1 - GROUP BY style0_1, - color1_1) as T1) as T1 + ghci> printSql aggregateWidgets + SELECT result0_2 as result1, + result1_2 as result2, + result2_2 as result3, + result3_2 as result4, + result4_2 as result5 + FROM (SELECT * + FROM (SELECT style0_1 as result0_2, + color1_1 as result1_2, + COUNT(location2_1) as result2_2, + SUM(quantity3_1) as result3_2, + AVG(radius4_1) as result4_2 + FROM (SELECT * + FROM (SELECT style as style0_1, + color as color1_1, + location as location2_1, + quantity as quantity3_1, + radius as radius4_1 + FROM widgetTable as T1) as T1) as T1 + GROUP BY style0_1, + color1_1) as T1) as T1 Idealized SQL: -SELECT style, - color, - COUNT(location), - SUM(quantity), - AVG(radius) -FROM widgetTable -GROUP BY style, color + SELECT style, + color, + COUNT(location), + SUM(quantity), + AVG(radius) + FROM widgetTable + GROUP BY style, color Note: In `widgetTable` and `aggregateWidgets` we see more explicit uses of our Template Haskell derived code. We use the 'pWidget' -"adaptor" to specify how columns are aggregated. Note that this is -yet another example of avoiding a headache by keeping your datatype -fully polymorphic, because the 'count' aggregator changes a 'Wire -String' into a 'Wire Int64'. +"adaptor" to specify how columns are aggregated. Outer join ========== -Opaleye supports left joins. (Full outer joins and right joins are -left to be added as a simple starter project for a new Opaleye -contributer!) - -Because left joins can change non-nullable columns into nullable -columns we have to make sure the type of the output supports -nullability. We introduce the following type synonym for this -purpose, which is just a notational convenience. - -A left join is expressed by specifying the two tables to join and the -join condition. +Opaleye supports outer joins (i.e. left joins, right joins and full +outer joins). An outer join is expressed by specifying the two tables +to join and the join condition. -> personBirthdayLeftJoin :: Query ((Column PGText, Column PGInt4, Column PGText), +> personBirthdayLeftJoin :: Query ((Column SqlText, Column SqlInt4, Column SqlText), > Birthday Nulls) > personBirthdayLeftJoin = leftJoin personQuery birthdayQuery eqName > where eqName ((name, _, _), birthdayRow) = name .== bdName birthdayRow The generated SQL is -ghci> printSql personBirthdayLeftJoin -SELECT result1_0_3 as result1, - result1_1_3 as result2, - result1_2_3 as result3, - result2_0_3 as result4, - result2_1_3 as result5 -FROM (SELECT * - FROM (SELECT name0_1 as result1_0_3, - age1_1 as result1_1_3, - address2_1 as result1_2_3, - name0_2 as result2_0_3, - birthday1_2 as result2_1_3 - FROM - (SELECT * - FROM (SELECT name as name0_1, - age as age1_1, - address as address2_1 - FROM personTable as T1) as T1) as T1 - LEFT OUTER JOIN - (SELECT * - FROM (SELECT name as name0_2, - birthday as birthday1_2 - FROM birthdayTable as T1) as T1) as T2 - ON - (name0_1) = (name0_2)) as T1) as T1 + ghci> printSql personBirthdayLeftJoin + SELECT result1_0_3 as result1, + result1_1_3 as result2, + result1_2_3 as result3, + result2_0_3 as result4, + result2_1_3 as result5 + FROM (SELECT * + FROM (SELECT name0_1 as result1_0_3, + age1_1 as result1_1_3, + address2_1 as result1_2_3, + name0_2 as result2_0_3, + birthday1_2 as result2_1_3 + FROM + (SELECT * + FROM (SELECT name as name0_1, + age as age1_1, + address as address2_1 + FROM personTable as T1) as T1) as T1 + LEFT OUTER JOIN + (SELECT * + FROM (SELECT name as name0_2, + birthday as birthday1_2 + FROM birthdayTable as T1) as T1) as T2 + ON + (name0_1) = (name0_2)) as T1) as T1 Idealized SQL: -SELECT name0, - age0, - address0, - name1, - birthday1 -FROM (SELECT name as name0, - age as age0, - address as address0 - FROM personTable) as T1 - LEFT OUTER JOIN - (SELECT name as name1, - birthday as birthday1 - FROM birthdayTable) as T1 -ON name0 = name1 - - -A comment about type signatures -------------------------------- + SELECT name0, + age0, + address0, + name1, + birthday1 + FROM (SELECT name as name0, + age as age0, + address as address0 + FROM personTable) as T1 + LEFT OUTER JOIN + (SELECT name as name1, + birthday as birthday1 + FROM birthdayTable) as T1 + ON name0 = name1 -We mentioned that Opaleye uses typeclass magic behind the scenes to -avoid boilerplate. One consequence of this is that the compiler -cannot infer types in some cases. Use of `leftJoin` is one of those -cases. You will generally need to provide a type signature yourself. -If you see the compiler complain that it cannot determine a `Default` -instance then specify more types. +Types of joins are inferrable in new versions of Opaleye. Here is a +(rather silly) example. +> typeInferred = +> O.fullJoinInferrable (O.fullJoinInferrable +> birthdayQuery +> (queryTable widgetTable) +> (const (O.pgBool True))) +> birthdayQuery +> (const (O.pgBool True)) Running queries on Postgres =========================== diff --git a/Doc/Tutorial/TutorialManipulation.lhs b/Doc/Tutorial/TutorialManipulation.lhs --- a/Doc/Tutorial/TutorialManipulation.lhs +++ b/Doc/Tutorial/TutorialManipulation.lhs @@ -4,15 +4,20 @@ > > import Opaleye (Column, Table, table, > tableColumn, (.==), (.<), -> arrangeDeleteSql, arrangeInsertManySql, -> arrangeUpdateSql, arrangeInsertManyReturningSql, -> PGInt4, PGFloat8) +> Insert(..), +> Update(..), +> Delete(..), +> rCount, +> rReturning, +> updateEasy, +> SqlInt4, SqlFloat8, SqlText, +> sqlString +> ) > > import Data.Profunctor.Product (p4) -> import Data.Profunctor.Product.Default (def) -> import qualified Opaleye.Internal.Unpackspec as U -> import qualified Opaleye.PGTypes as P > import qualified Opaleye.Constant as C +> +> import GHC.Int (Int64) Manipulation ============ @@ -21,19 +26,19 @@ DELETE, INSERT and UPDATE. To demonstrate manipulation in Opaleye we will need a table to perform -our manipulation on. It will have three columns: an integer-valued -"id" column (assumed to be an auto-incrementing field) and two -double-valued required fields. The `Table` type constructor has two +our manipulation on. It will have four columns: an int4-valued "id" +column (assumed to be an auto-incrementing field) and three +float8-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. 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. +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 SqlInt4)`. 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. > myTable :: Table -> (Maybe (Column PGInt4), Column PGFloat8, Column PGFloat8, Column P.PGText) -> (Column PGInt4, Column PGFloat8, Column PGFloat8, Column P.PGText) +> (Maybe (Column SqlInt4), Column SqlFloat8, Column SqlFloat8, Column SqlText) +> (Column SqlInt4, Column SqlFloat8, Column SqlFloat8, Column SqlText) > myTable = table "tablename" (p4 ( tableColumn "id" > , tableColumn "x" > , tableColumn "y" @@ -42,25 +47,32 @@ 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 myTable (\(_, x, y, _) -> x .< y) +> delete :: Delete Int64 +> delete = Delete +> { dTable = myTable +> , dWhere = (\(_, x, y, _) -> x .< y) +> , dReturning = rCount +> } -ghci> putStrLn delete DELETE FROM tablename WHERE ((x) < (y)) -To insert we provide a row with the write type. Optional columns can +To insert we provide rows with the write type. Optional columns can be omitted by providing `Nothing` instead. Numeric SQL types have a Haskell `Num` instance so we can write them using numeric literals. Values of other types should be created using the functions in the -`Opaleye.PGTypes` module, for example `pgString` to create a `Column -P.PGText` from a `String`. +`Opaleye.SqlTypes` module, for example `sqlString` to create a `SqlText` +from a `String`. -> insertNothing :: String -> insertNothing = arrangeInsertManySql myTable (return (Nothing, 2, 3, P.pgString "Hello")) +> insertNothing :: Insert Int64 +> insertNothing = Insert +> { iTable = myTable +> , iRows = [(Nothing, 2, 3, sqlString "Hello")] +> , iReturning = rCount +> , iOnConflict = Nothing +> } -ghci> putStrLn insertNothing INSERT INTO "tablename" ("id", "x", "y", @@ -71,14 +83,17 @@ E'Hello') -If we'd like to pass a value into the insertion function, we can't -rely on the Num instance and must use constant: +If we'd like to pass a variable into the insertion function, we can't +rely on the `Num` instance and must use `constant`: -> insertNonLiteral :: Double -> String -> insertNonLiteral i = -> arrangeInsertManySql myTable (return (Nothing, 2, C.constant i, P.pgString "Hello")) +> insertNonLiteral :: Double -> Insert Int64 +> insertNonLiteral i = Insert +> { iTable = myTable +> , iRows = [(Nothing, 2, C.constant i, sqlString "Hello")] +> , iReturning = rCount +> , iOnConflict = Nothing +> } -ghci> putStrLn $ insertNonLiteral 12.0 INSERT INTO "tablename" ("id", "x", "y", @@ -91,10 +106,14 @@ If we really want to specify an optional column we can use `Just`. -> insertJust :: String -> insertJust = arrangeInsertManySql myTable (return (Just 1, 2, 3, P.pgString "Hello")) +> insertJust :: Insert Int64 +> insertJust = Insert +> { iTable = myTable +> , iRows = [(Just 1, 2, 3, sqlString "Hello")] +> , iReturning = rCount +> , iOnConflict = Nothing +> } -ghci> putStrLn insertJust INSERT INTO "tablename" ("id", "x", "y", @@ -110,11 +129,14 @@ `Column Bool`. All rows that satisfy the condition are updated according to the update function. -> update :: String -> update = arrangeUpdateSql myTable (\(_, x, y, s) -> (Nothing, x + y, x - y, s)) -> (\(id_, _, _, _) -> id_ .== 5) +> update :: Update Int64 +> update = Update +> { uTable = myTable +> , uUpdateWith = updateEasy (\(id_, x, y, s) -> (id_, x + y, x - y, s)) +> , uWhere = (\(id_, _, _, _) -> id_ .== 5) +> , uReturning = rCount +> } -ghci> putStrLn update SET "id" = DEFAULT, "x" = ("x") + ("y"), "y" = ("x") - ("y"), @@ -124,18 +146,17 @@ Sometimes when we insert a row with an automatically generated field we want the database to return the new field value to us so we can use -it in future queries. SQL supports that via INSERT RETURNING and +it in future queries. SQL supports that via `INSERT RETURNING` and Opaleye supports it also. -> insertReturning :: String -> insertReturning = -> 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 +> insertReturning :: Insert [Int] +> insertReturning = Insert +> { iTable = myTable +> , iRows = [(Nothing, 4, 5, sqlString "Bye")] +> , iReturning = rReturning (\(id_, _, _, _) -> id_) +> , iOnConflict = Nothing +> } -ghci> putStrLn insertReturning INSERT INTO "tablename" ("id", "x", "y", @@ -145,15 +166,6 @@ 5.0, E'Bye') RETURNING "id" - - -Running the queries -=================== - -This tutorial has only shown you how to generate the SQL string for -manipulation queries. In practice you actually want to run them! To -run them you should use `runInsertMany` instead of `arrangeInsertManySql`, -`runDelete` instead of `arrangeDeleteSql`, etc.. Comments diff --git a/Test/QuickCheck.hs b/Test/QuickCheck.hs --- a/Test/QuickCheck.hs +++ b/Test/QuickCheck.hs @@ -20,12 +20,12 @@ 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.Table (O.Column O.SqlInt4, O.Column O.SqlInt4) + (O.Column O.SqlInt4, O.Column O.SqlInt4) 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) +table1 :: O.Table (O.Column O.SqlInt4, O.Column O.SqlInt4) + (O.Column O.SqlInt4, O.Column O.SqlInt4) table1 = twoIntTable "table1" data QueryDenotation a = @@ -34,7 +34,7 @@ onList :: ([a] -> [b]) -> QueryDenotation a -> QueryDenotation b onList f = QueryDenotation . (fmap . fmap) f . unQueryDenotation -type Columns = [Either (O.Column O.PGInt4) (O.Column O.PGBool)] +type Columns = [Either (O.Column O.SqlInt4) (O.Column O.SqlBool)] type Haskells = [Either Int Bool] columnsOfHaskells :: Haskells -> Columns diff --git a/Test/Test.hs b/Test/Test.hs --- a/Test/Test.hs +++ b/Test/Test.hs @@ -1,10 +1,12 @@ {-# LANGUAGE Arrows #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Main where import qualified QuickCheck +import qualified TypeFamilies () import Opaleye (Column, Nullable, Query, QueryArr, (.==), (.>)) import qualified Opaleye as O @@ -105,64 +107,67 @@ -} twoIntTable :: String - -> O.Table (Column O.PGInt4, Column O.PGInt4) (Column O.PGInt4, Column O.PGInt4) + -> O.Table (Column O.SqlInt4, Column O.SqlInt4) (Column O.SqlInt4, Column O.SqlInt4) 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.SqlInt4, Column O.SqlInt4) (Column O.SqlInt4, Column O.SqlInt4) table1 = twoIntTable "table1" -table1F :: O.Table (Column O.PGInt4, Column O.PGInt4) (Column O.PGInt4, Column O.PGInt4) +table1F :: O.Table (Column O.SqlInt4, Column O.SqlInt4) (Column O.SqlInt4, Column O.SqlInt4) 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.SqlInt4, Column O.SqlInt4) (Column O.SqlInt4, Column O.SqlInt4) table2 = twoIntTable "TABLE2" -table3 :: O.Table (Column O.PGInt4, Column O.PGInt4) (Column O.PGInt4, Column O.PGInt4) +table3 :: O.Table (Column O.SqlInt4, Column O.SqlInt4) (Column O.SqlInt4, Column O.SqlInt4) table3 = twoIntTable "table3" -table4 :: O.Table (Column O.PGInt4, Column O.PGInt4) (Column O.PGInt4, Column O.PGInt4) +table4 :: O.Table (Column O.SqlInt4, Column O.SqlInt4) (Column O.SqlInt4, Column O.SqlInt4) table4 = twoIntTable "table4" -table5 :: O.Table (Maybe (Column O.PGInt4), Maybe (Column O.PGInt4)) - (Column O.PGInt4, Column O.PGInt4) +table5 :: O.Table (Maybe (Column O.SqlInt4), Maybe (Column O.SqlInt4)) + (Column O.SqlInt4, Column O.SqlInt4) 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.SqlText, Column O.SqlText) (Column O.SqlText, Column O.SqlText) 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.SqlText, Column O.SqlText) (Column O.SqlText, Column O.SqlText) 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.SqlJson) (Column O.SqlJson) table8 = O.Table "table8" (O.required "column1") -table9 :: O.Table (Column O.PGJsonb) (Column O.PGJsonb) +table9 :: O.Table (Column O.SqlJsonb) (Column O.SqlJsonb) table9 = O.Table "table9" (O.required "column1") -tableKeywordColNames :: O.Table (Column O.PGInt4, Column O.PGInt4) - (Column O.PGInt4, Column O.PGInt4) +table10 :: O.Table (Column O.SqlInt4) (Column O.SqlInt4) +table10 = O.Table "table10" (O.required "column1") + +tableKeywordColNames :: O.Table (Column O.SqlInt4, Column O.SqlInt4) + (Column O.SqlInt4, Column O.SqlInt4) tableKeywordColNames = O.Table "keywordtable" (PP.p2 (O.required "column", O.required "where")) -table1Q :: Query (Column O.PGInt4, Column O.PGInt4) +table1Q :: Query (Column O.SqlInt4, Column O.SqlInt4) table1Q = O.queryTable table1 -table2Q :: Query (Column O.PGInt4, Column O.PGInt4) +table2Q :: Query (Column O.SqlInt4, Column O.SqlInt4) table2Q = O.queryTable table2 -table3Q :: Query (Column O.PGInt4, Column O.PGInt4) +table3Q :: Query (Column O.SqlInt4, Column O.SqlInt4) table3Q = O.queryTable table3 -table6Q :: Query (Column O.PGText, Column O.PGText) +table6Q :: Query (Column O.SqlText, Column O.SqlText) table6Q = O.queryTable table6 -table7Q :: Query (Column O.PGText, Column O.PGText) +table7Q :: Query (Column O.SqlText, Column O.SqlText) table7Q = O.queryTable table7 -table8Q :: Query (Column O.PGJson) +table8Q :: Query (Column O.SqlJson) table8Q = O.queryTable table8 -table9Q :: Query (Column O.PGJsonb) +table9Q :: Query (Column O.SqlJsonb) table9Q = O.queryTable table9 table1dataG :: Num a => [(a, a)] @@ -174,7 +179,7 @@ table1data :: [(Int, Int)] table1data = table1dataG -table1columndata :: [(Column O.PGInt4, Column O.PGInt4)] +table1columndata :: [(Column O.SqlInt4, Column O.SqlInt4)] table1columndata = table1dataG table2dataG :: Num a => [(a, a)] @@ -184,7 +189,7 @@ table2data :: [(Int, Int)] table2data = table2dataG -table2columndata :: [(Column O.PGInt4, Column O.PGInt4)] +table2columndata :: [(Column O.SqlInt4, Column O.SqlInt4)] table2columndata = table2dataG table3dataG :: Num a => [(a, a)] @@ -193,7 +198,7 @@ table3data :: [(Int, Int)] table3data = table3dataG -table3columndata :: [(Column O.PGInt4, Column O.PGInt4)] +table3columndata :: [(Column O.SqlInt4, Column O.SqlInt4)] table3columndata = table3dataG table4dataG :: Num a => [(a, a)] @@ -203,19 +208,19 @@ table4data :: [(Int, Int)] table4data = table4dataG -table4columndata :: [(Column O.PGInt4, Column O.PGInt4)] +table4columndata :: [(Column O.SqlInt4, Column O.SqlInt4)] table4columndata = table4dataG table6data :: [(String, String)] table6data = [("xy", "a"), ("z", "a"), ("more text", "a")] -table6columndata :: [(Column O.PGText, Column O.PGText)] +table6columndata :: [(Column O.SqlText, Column O.SqlText)] table6columndata = map (\(column1, column2) -> (O.pgString column1, O.pgString column2)) table6data table7data :: [(String, String)] table7data = [("foo", "c"), ("bar", "a"), ("baz", "b")] -table7columndata :: [(Column O.PGText, Column O.PGText)] +table7columndata :: [(Column O.SqlText, Column O.SqlText)] table7columndata = map (O.pgString *** O.pgString) table7data table8data :: [Json.Value] @@ -226,10 +231,10 @@ ] ] -table8columndata :: [Column O.PGJson] +table8columndata :: [Column O.SqlJson] table8columndata = map O.pgValueJSON table8data -table9columndata :: [Column O.PGJsonb] +table9columndata :: [Column O.SqlJsonb] table9columndata = map O.pgValueJSONB table8data -- We have to quote the table names here because upper case letters in @@ -264,6 +269,16 @@ dropAndCreateTableJsonb :: (String, [String]) -> PGS.Query dropAndCreateTableJsonb = dropAndCreateTable "jsonb" +dropAndCreateTablePk :: (String, [String]) -> PGS.Query +dropAndCreateTablePk (t, cols) = String.fromString drop_ + where drop_ = "DROP TABLE IF EXISTS \"public\".\"" ++ t ++ "\";" + ++ "CREATE TABLE \"public\".\"" ++ t ++ "\"" + ++ " (" ++ allColumns ++ ");" + pk c = "\"" ++ c ++ "\"" ++ " integer primary key" + integer c = "\"" ++ c ++ "\"" ++ " integer" + commas = L.intercalate "," + allColumns = commas $ [pk $ head cols] ++ map integer (tail cols) + type Table_ = (String, [String]) -- This should ideally be derived from the table definition above @@ -287,18 +302,23 @@ jsonbTables :: [Table_] jsonbTables = [("table9", ["column1"])] +conflictTables :: [Table_] +conflictTables = [("table10", ["column1"])] + dropAndCreateDB :: PGS.Connection -> IO () dropAndCreateDB conn = do mapM_ execute tables mapM_ executeTextTable textTables mapM_ executeSerial serialTables mapM_ executeJson jsonTables + mapM_ executeConflict conflictTables -- Disabled until Travis supports Postgresql >= 9.4 -- mapM_ executeJsonb jsonbTables where execute = PGS.execute_ conn . dropAndCreateTableInt executeTextTable = PGS.execute_ conn . dropAndCreateTableText executeSerial = PGS.execute_ conn . dropAndCreateTableSerial executeJson = PGS.execute_ conn . dropAndCreateTableJson + executeConflict = PGS.execute_ conn . dropAndCreateTablePk -- executeJsonb = PGS.execute_ conn . dropAndCreateTableJsonb type Test = SpecWith PGS.Connection @@ -362,7 +382,7 @@ testNum :: Test testNum = it "" $ query `queryShouldReturnSorted` (map op table1data) - where query :: Query (Column O.PGInt4) + where query :: Query (Column O.SqlInt4) query = proc () -> do t <- table1Q -< () Arr.returnA -< op t @@ -371,7 +391,7 @@ testDiv :: Test testDiv = it "" $ query `queryShouldReturnSorted` (map (op . toDoubles) table1data) - where query :: Query (Column O.PGFloat8) + where query :: Query (Column O.SqlFloat8) query = proc () -> do t <- Arr.arr (O.doubleOfInt *** O.doubleOfInt) <<< table1Q -< () Arr.returnA -< op t @@ -385,7 +405,7 @@ -- TODO: need to implement and test case_ returning tuples testCase :: Test testCase = it "" $ q `queryShouldReturnSorted` expected - where q :: Query (Column O.PGInt4) + where q :: Query (Column O.SqlInt4) q = table1Q >>> proc (i, j) -> do Arr.returnA -< O.case_ [(j .== 100, 12), (i .== 1, 21)] 33 expected :: [Int] @@ -395,7 +415,7 @@ -- SQL. testCaseEmpty :: Test testCaseEmpty = it "" $ q `queryShouldReturnSorted` expected - where q :: Query (Column O.PGInt4) + where q :: Query (Column O.SqlInt4) q = table1Q >>> proc _ -> Arr.returnA -< O.case_ [] 33 expected :: [Int] @@ -407,10 +427,10 @@ -- FIXME: the unsafeCoerceColumn is currently needed because the type -- changes required for aggregation are not currently dealt with by -- Opaleye. -aggregateCoerceFIXME :: QueryArr (Column O.PGInt4) (Column O.PGInt8) +aggregateCoerceFIXME :: QueryArr (Column O.SqlInt4) (Column O.SqlInt8) aggregateCoerceFIXME = Arr.arr aggregateCoerceFIXME' -aggregateCoerceFIXME' :: Column a -> Column O.PGInt8 +aggregateCoerceFIXME' :: Column a -> Column O.SqlInt8 aggregateCoerceFIXME' = O.unsafeCoerceColumn testAggregate :: Test @@ -496,7 +516,7 @@ testCountRows3 = it "" $ q `queryShouldReturnSorted` [3 :: Int64] where q = O.countRows table7Q -queryShouldReturnSortBy :: O.Order (Column O.PGInt4, Column O.PGInt4) +queryShouldReturnSortBy :: O.Order (Column O.SqlInt4, Column O.SqlInt4) -> ((Int, Int) -> (Int, Int) -> Ordering) -> (PGS.Connection -> Expectation) queryShouldReturnSortBy orderQ order = testH (O.orderBy orderQ table1Q) @@ -523,7 +543,7 @@ , (1, 100) ] -limitOrderShouldMatch :: (Query (Column O.PGInt4, Column O.PGInt4) -> Query (Column O.PGInt4, Column O.PGInt4)) +limitOrderShouldMatch :: (Query (Column O.SqlInt4, Column O.SqlInt4) -> Query (Column O.SqlInt4, Column O.SqlInt4)) -> ([(Int, Int)] -> [(Int, Int)]) -> (PGS.Connection -> Expectation) limitOrderShouldMatch olQ ol = testH (olQ (orderQ table1Q)) (ol (order table1data) `shouldBe`) @@ -550,13 +570,13 @@ expectedResult = A.liftA2 (,) (L.nub table1data) [(1 :: Int, 400 :: Int64), (2, 300)] -one :: Query (Column O.PGInt4) -one = Arr.arr (const (1 :: Column O.PGInt4)) +one :: Query (Column O.SqlInt4) +one = Arr.arr (const (1 :: Column O.SqlInt4)) -- The point of the "double" tests is to ensure that we do not -- introduce name clashes in the operations which create new column names testDoubleH :: (Show haskells, Eq haskells, D.Default O.QueryRunner columns haskells) => - (QueryArr () (Column O.PGInt4) -> QueryArr () columns) -> [haskells] + (QueryArr () (Column O.SqlInt4) -> QueryArr () columns) -> [haskells] -> (PGS.Connection -> Expectation) testDoubleH q expected1 = testH (q one &&& q one) (`shouldBe` expected2) where expected2 = A.liftA2 (,) expected1 expected1 @@ -569,21 +589,21 @@ testDoubleLeftJoin :: Test testDoubleLeftJoin = it "" $ testDoubleH lj [(1 :: Int, Just (1 :: Int))] - where lj :: Query (Column O.PGInt4) - -> Query (Column O.PGInt4, Column (Nullable O.PGInt4)) + where lj :: Query (Column O.SqlInt4) + -> Query (Column O.SqlInt4, Column (Nullable O.SqlInt4)) lj q = O.leftJoin q q (uncurry (.==)) testDoubleValues :: Test testDoubleValues = it "" $ testDoubleH v [1 :: Int] - where v :: Query (Column O.PGInt4) -> Query (Column O.PGInt4) + where v :: Query (Column O.SqlInt4) -> Query (Column O.SqlInt4) v _ = O.values [1] testDoubleUnionAll :: Test testDoubleUnionAll = it "" $ testDoubleH u [1 :: Int, 1] where u q = q `O.unionAll` q -aLeftJoin :: Query ((Column O.PGInt4, Column O.PGInt4), - (Column (Nullable O.PGInt4), Column (Nullable O.PGInt4))) +aLeftJoin :: Query ((Column O.SqlInt4, Column O.SqlInt4), + (Column (Nullable O.SqlInt4), Column (Nullable O.SqlInt4))) aLeftJoin = O.leftJoin table1Q table3Q (\(l, r) -> fst l .== fst r) testLeftJoin :: Test @@ -596,10 +616,10 @@ testLeftJoinNullable :: Test testLeftJoinNullable = it "" $ testH q (`shouldBe` expected) - where q :: Query ((Column O.PGInt4, Column O.PGInt4), - ((Column (Nullable O.PGInt4), Column (Nullable O.PGInt4)), - (Column (Nullable O.PGInt4), - Column (Nullable O.PGInt4)))) + where q :: Query ((Column O.SqlInt4, Column O.SqlInt4), + ((Column (Nullable O.SqlInt4), Column (Nullable O.SqlInt4)), + (Column (Nullable O.SqlInt4), + Column (Nullable O.SqlInt4)))) q = O.leftJoin table3Q aLeftJoin cond cond (x, y) = fst x .== fst (fst y) @@ -630,7 +650,7 @@ testValues :: Test testValues = it "" $ testH (O.values values) (values' `shouldBe`) - where values :: [(Column O.PGInt4, Column O.PGInt4)] + where values :: [(Column O.SqlInt4, Column O.SqlInt4)] values = [ (1, 10) , (2, 100) ] values' :: [(Int, Int)] @@ -640,7 +660,7 @@ {- FIXME: does not yet work testValuesDouble :: Test testValuesDouble = testG (O.values values) (values' ==) - where values :: [(Column O.PGInt4, Column O.PGFloat8)] + where values :: [(Column O.SqlInt4, Column O.SqlFloat8)] values = [ (1, 10.0) , (2, 100.0) ] values' :: [(Int, Double)] @@ -650,7 +670,7 @@ testValuesEmpty :: Test testValuesEmpty = it "" $ testH (O.values values) (values' `shouldBe`) - where values :: [Column O.PGInt4] + where values :: [Column O.SqlInt4] values = [] values' :: [Int] values' = [] @@ -690,10 +710,10 @@ expectedD = [(1, 10)] runQueryTable4 conn = O.runQuery conn (O.queryTable table4) - insertT :: [(Column O.PGInt4, Column O.PGInt4)] + insertT :: [(Column O.SqlInt4, Column O.SqlInt4)] insertT = [(1, 2), (3, 5)] - insertTMany :: [(Column O.PGInt4, Column O.PGInt4)] + insertTMany :: [(Column O.SqlInt4, Column O.SqlInt4)] insertTMany = [(20, 30), (40, 50)] expectedI :: [(Int, Int)] @@ -702,6 +722,40 @@ expectedR :: [Int] expectedR = [-1, -2] +testInsertConflict :: Test +testInsertConflict = it "inserts with conflicts" $ \conn -> do + _ <- O.runDelete conn table10 (const $ O.constant True) + returned <- O.runInsertManyReturning conn table10 insertT id + extras <- O.runInsertManyReturningOnConflictDoNothing conn table10 conflictsT id + moreExtras <- O.runInsertManyOnConflictDoNothing conn table10 moreConflictsT + + returned `shouldBe` afterInsert + extras `shouldBe` afterConflicts + moreExtras `shouldBe` 1 + runQueryTable10 conn `shouldReturn` allRows + + O.runInsertMany conn table10 insertT `shouldThrow` (\ (_ :: PGS.SqlError) -> True) + + where insertT :: [Column O.SqlInt4] + insertT = [1, 2] + + conflictsT :: [Column O.SqlInt4] + conflictsT = [1, 3] + + moreConflictsT :: [Column O.SqlInt4] + moreConflictsT = [3, 4] + + afterInsert :: [Int] + afterInsert = [1, 2] + + afterConflicts :: [Int] + afterConflicts = [3] + + allRows :: [Int] + allRows = [1, 2, 3, 4] + + runQueryTable10 conn = O.runQuery conn (O.queryTable table10) + testKeywordColNames :: Test testKeywordColNames = it "" $ \conn -> do let q :: IO [(Int, Int)] @@ -771,7 +825,7 @@ type JsonTest a = SpecWith (Query (Column a) -> PGS.Connection -> Expectation) -- Test opaleye's equivalent of c1->'c' -testJsonGetFieldValue :: (O.PGIsJson a, O.QueryRunnerColumnDefault a Json.Value) => Query (Column a) -> Test +testJsonGetFieldValue :: (O.SqlIsJson a, O.QueryRunnerColumnDefault a Json.Value) => Query (Column a) -> Test testJsonGetFieldValue dataQuery = it "" $ testH q (`shouldBe` expected) where q = dataQuery >>> proc c1 -> do Arr.returnA -< O.toNullable c1 O..-> O.pgStrictText "c" @@ -779,7 +833,7 @@ expected = [Just $ Json.Number $ fromInteger 21] -- Test opaleye's equivalent of c1->>'c' -testJsonGetFieldText :: (O.PGIsJson a) => Query (Column a) -> Test +testJsonGetFieldText :: (O.SqlIsJson a) => Query (Column a) -> Test testJsonGetFieldText dataQuery = it "" $ testH q (`shouldBe` expected) where q = dataQuery >>> proc c1 -> do Arr.returnA -< O.toNullable c1 O..->> O.pgStrictText "c" @@ -787,7 +841,7 @@ expected = [Just "21"] -- Special Test for Github Issue #350 : https://github.com/tomjaguarpaw/haskell-opaleye/issues/350 -testRestrictWithJsonOp :: (O.PGIsJson a) => Query (Column a) -> Test +testRestrictWithJsonOp :: (O.SqlIsJson a) => Query (Column a) -> Test testRestrictWithJsonOp dataQuery = it "restricts the rows returned by checking equality with a value extracted using JSON operator" $ testH query (`shouldBe` table8data) where query = dataQuery >>> proc col1 -> do t <- table8Q -< () @@ -795,7 +849,7 @@ Arr.returnA -< t -- Test opaleye's equivalent of c1->'a'->2 -testJsonGetArrayValue :: (O.PGIsJson a, O.QueryRunnerColumnDefault a Json.Value) => Query (Column a) -> Test +testJsonGetArrayValue :: (O.SqlIsJson a, O.QueryRunnerColumnDefault a Json.Value) => Query (Column a) -> Test testJsonGetArrayValue dataQuery = it "" $ testH q (`shouldBe` expected) where q = dataQuery >>> proc c1 -> do Arr.returnA -< O.toNullable c1 O..-> O.pgStrictText "a" O..-> O.pgInt4 2 @@ -803,7 +857,7 @@ expected = [Just $ Json.Number $ fromInteger 30] -- Test opaleye's equivalent of c1->'a'->>2 -testJsonGetArrayText :: (O.PGIsJson a) => Query (Column a) -> Test +testJsonGetArrayText :: (O.SqlIsJson a) => Query (Column a) -> Test testJsonGetArrayText dataQuery = it "" $ testH q (`shouldBe` expected) where q = dataQuery >>> proc c1 -> do Arr.returnA -< O.toNullable c1 O..-> O.pgStrictText "a" O..->> O.pgInt4 2 @@ -812,7 +866,7 @@ -- Test opaleye's equivalent of c1->>'missing' -- Note that the missing field does not exist. -testJsonGetMissingField :: (O.PGIsJson a) => Query (Column a) -> Test +testJsonGetMissingField :: (O.SqlIsJson a) => Query (Column a) -> Test testJsonGetMissingField dataQuery = it "" $ testH q (`shouldBe` expected) where q = dataQuery >>> proc c1 -> do Arr.returnA -< O.toNullable c1 O..->> O.pgStrictText "missing" @@ -820,7 +874,7 @@ expected = [Nothing] -- Test opaleye's equivalent of c1#>'{b,x}' -testJsonGetPathValue :: (O.PGIsJson a, O.QueryRunnerColumnDefault a Json.Value) => Query (Column a) -> Test +testJsonGetPathValue :: (O.SqlIsJson a, O.QueryRunnerColumnDefault a Json.Value) => Query (Column a) -> Test testJsonGetPathValue dataQuery = it "" $ testH q (`shouldBe` expected) where q = dataQuery >>> proc c1 -> do Arr.returnA -< O.toNullable c1 O..#> O.pgArray O.pgStrictText ["b", "x"] @@ -828,7 +882,7 @@ expected = [Just $ Json.Number $ fromInteger 42] -- Test opaleye's equivalent of c1#>>'{b,x}' -testJsonGetPathText :: (O.PGIsJson a) => Query (Column a) -> Test +testJsonGetPathText :: (O.SqlIsJson a) => Query (Column a) -> Test testJsonGetPathText dataQuery = it "" $ testH q (`shouldBe` expected) where q = dataQuery >>> proc c1 -> do Arr.returnA -< O.toNullable c1 O..#>> O.pgArray O.pgStrictText ["b", "x"] @@ -874,7 +928,7 @@ testRangeOverlap :: Test testRangeOverlap = it "generates overlap" $ testH q (`shouldBe` [True]) - where range :: Int -> Int -> Column (O.PGRange O.PGInt4) + where range :: Int -> Int -> Column (O.PGRange O.SqlInt4) range a b = O.pgRange O.pgInt4 (R.Inclusive a) (R.Inclusive b) q = A.pure $ (range 3 7) `O.overlap` (range 4 12) @@ -889,34 +943,36 @@ qOverlap r = A.pure $ r `O.overlap` rangeNow testH (qOverlap range1) (`shouldBe` [True]) conn testH (qOverlap range2) (`shouldBe` [True]) conn + testH (A.pure $ O.pgUTCTime now `O.liesWithin` range1) (`shouldBe` [True]) conn + testH (A.pure $ O.pgUTCTime later `O.liesWithin` range1) (`shouldBe` [False]) conn testRangeLeftOf :: Test testRangeLeftOf = it "generates 'left of'" $ testH q (`shouldBe` [True]) - where range :: Int -> Int -> Column (O.PGRange O.PGInt4) + where range :: Int -> Int -> Column (O.PGRange O.SqlInt4) range a b = O.pgRange O.pgInt4 (R.Inclusive a) (R.Inclusive b) q = A.pure $ (range 1 10) O..<< (range 100 110) testRangeRightOf :: Test testRangeRightOf = it "generates 'right of'" $ testH q (`shouldBe` [True]) - where range :: Int -> Int -> Column (O.PGRange O.PGInt4) + where range :: Int -> Int -> Column (O.PGRange O.SqlInt4) range a b = O.pgRange O.pgInt4 (R.Inclusive a) (R.Inclusive b) q = A.pure $ (range 50 60) O..>> (range 20 30) testRangeRightExtension :: Test testRangeRightExtension = it "generates right extension" $ testH q (`shouldBe` [True]) - where range :: Int -> Int -> Column (O.PGRange O.PGInt4) + where range :: Int -> Int -> Column (O.PGRange O.SqlInt4) range a b = O.pgRange O.pgInt4 (R.Inclusive a) (R.Inclusive b) q = A.pure $ (range 1 20) O..&< (range 18 20) testRangeLeftExtension :: Test testRangeLeftExtension = it "generates left extension" $ testH q (`shouldBe` [True]) - where range :: Int -> Int -> Column (O.PGRange O.PGInt4) + where range :: Int -> Int -> Column (O.PGRange O.SqlInt4) range a b = O.pgRange O.pgInt4 (R.Inclusive a) (R.Inclusive b) q = A.pure $ (range 7 20) O..&> (range 5 10) testRangeAdjacency :: Test testRangeAdjacency = it "generates adjacency" $ testH q (`shouldBe` [True]) - where range :: Int -> Int -> Column (O.PGRange O.PGInt4) + where range :: Int -> Int -> Column (O.PGRange O.SqlInt4) range a b = O.pgRange O.pgInt4 (R.Inclusive a) (R.Exclusive b) q = A.pure $ (range 1 2) O..-|- (range 2 3) @@ -1046,6 +1102,7 @@ testValues testValuesEmpty testUpdate + testInsertConflict describe "range" $ do testRangeOverlap testRangeDateOverlap diff --git a/Test/TypeFamilies.hs b/Test/TypeFamilies.hs new file mode 100644 --- /dev/null +++ b/Test/TypeFamilies.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} + +module TypeFamilies where + +import Opaleye.Internal.TypeFamilies + +data (:~) a b where + Eq :: (:~) a a + +-- If it compiles, it works +tests :: () +tests = () + where _ = Eq :: a :~ (Pure :<$> Id :<| a :<| b) + _ = Eq :: a :~ (Id :<| a) + _ = Eq :: (a -> a) :~ (((->) :<$> Id :<*> Id) :<| a) + _ = Eq :: (a -> b) + :~ (((->) :<$> Pure a :<*> Pure b) :<| c) + _ = Eq :: Maybe a :~ ((Maybe :<$> Pure a) :<| b) + _ = Eq :: Maybe a :~ ((Maybe :<$> Id) :<| a) + _ = Eq :: a :~ ((Pure a) :<| b) diff --git a/opaleye.cabal b/opaleye.cabal --- a/opaleye.cabal +++ b/opaleye.cabal @@ -1,6 +1,6 @@ name: opaleye copyright: Copyright (c) 2014-2018 Purely Agile Limited -version: 0.6.1.0 +version: 0.6.7000.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 @@ -18,7 +18,7 @@ CHANGELOG.md *.md Doc/*.md -tested-with: GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3 +tested-with: GHC==8.2.2, GHC==8.0.2 source-repository head type: git @@ -36,8 +36,9 @@ , contravariant >= 1.2 && < 1.5 , postgresql-simple >= 0.5.3 && < 0.6 , pretty >= 1.1.1.0 && < 1.2 - , product-profunctors >= 0.6.2 && < 0.10 + , product-profunctors >= 0.6.2 && < 0.11 , profunctors >= 4.0 && < 5.3 + , scientific >= 0.3 && < 0.4 , semigroups >= 0.13 && < 0.19 , text >= 0.11 && < 1.3 , transformers >= 0.3 && < 0.6 @@ -51,17 +52,23 @@ Opaleye.Column, Opaleye.Constant, Opaleye.Distinct, + Opaleye.Field, Opaleye.FunctionalJoin, Opaleye.Join, Opaleye.Label, Opaleye.Manipulation, + Opaleye.Map, Opaleye.Operators, Opaleye.Order, Opaleye.PGTypes, Opaleye.QueryArr, Opaleye.RunQuery, + Opaleye.RunSelect, + Opaleye.Select, Opaleye.Sql, + Opaleye.SqlTypes, Opaleye.Table, + Opaleye.TypeFamilies, Opaleye.Values, Opaleye.Internal.Aggregate, Opaleye.Internal.Binary, @@ -84,6 +91,7 @@ Opaleye.Internal.Table, Opaleye.Internal.TableMaker, Opaleye.Internal.Tag, + Opaleye.Internal.TypeFamilies, Opaleye.Internal.Unpackspec, Opaleye.Internal.Values Opaleye.Internal.HaskellDB.PrimQuery, @@ -97,7 +105,8 @@ default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: Test.hs - other-modules: QuickCheck + other-modules: QuickCheck, + TypeFamilies hs-source-dirs: Test build-depends: aeson >= 0.6 && < 1.3, diff --git a/src/Opaleye.hs b/src/Opaleye.hs --- a/src/Opaleye.hs +++ b/src/Opaleye.hs @@ -28,6 +28,8 @@ , module Opaleye.QueryArr , module Opaleye.RunQuery , module Opaleye.Sql + , module Opaleye.Select + , module Opaleye.SqlTypes , module Opaleye.Table , module Opaleye.Values ) where @@ -46,6 +48,8 @@ import Opaleye.PGTypes import Opaleye.QueryArr import Opaleye.RunQuery +import Opaleye.Select import Opaleye.Sql +import Opaleye.SqlTypes import Opaleye.Table import Opaleye.Values diff --git a/src/Opaleye/Aggregate.hs b/src/Opaleye/Aggregate.hs --- a/src/Opaleye/Aggregate.hs +++ b/src/Opaleye/Aggregate.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-duplicate-exports #-} --- | Perform aggregation on 'Query's. To aggregate a 'Query' you +-- | Perform aggregation on 'S.Select's. To aggregate a 'S.Select' you -- should construct an 'Aggregator' encoding how you want the -- aggregation to proceed, then call 'aggregate' on it. The -- 'Aggregator' should be constructed from the basic 'Aggregator's @@ -43,7 +43,8 @@ import Opaleye.QueryArr (Query) import qualified Opaleye.Column as C import qualified Opaleye.Order as Ord -import qualified Opaleye.PGTypes as T +import qualified Opaleye.Select as S +import qualified Opaleye.SqlTypes as T import qualified Opaleye.Join as J -- This page of Postgres documentation tell us what aggregate @@ -52,14 +53,14 @@ -- http://www.postgresql.org/docs/9.3/static/functions-aggregate.html {-| -Given a 'Query' producing rows of type @a@ and an 'Aggregator' accepting rows of +Given a 'S.Select' producing rows of type @a@ and an 'Aggregator' accepting rows of type @a@, apply the aggregator to the query. If you simply want to count the number of rows in a query you might find the 'countRows' function more convenient. By design there is no aggregation function of type @Aggregator b b' -> -QueryArr a b -> QueryArr a b'@. Such a function would allow violation +'S.SelectArr' a b -> 'S.SelectArr' a b'@. Such a function would allow violation of SQL's scoping rules and lead to invalid queries. Please note that when aggregating an empty query with no @GROUP BY@ @@ -71,7 +72,7 @@ result of an aggregation. -} -aggregate :: Aggregator a b -> Query a -> Query b +aggregate :: Aggregator a b -> S.Select a -> S.Select b aggregate agg q = Q.simpleQueryArr (A.aggregateU agg . Q.runSimpleQueryArr q) -- | Order the values within each aggregation in `Aggregator` using @@ -83,7 +84,7 @@ -- you need different orderings for different aggregations, use -- 'Opaleye.Internal.Aggregate.orderAggregate'. -aggregateOrdered :: Ord.Order a -> Aggregator a b -> Query a -> Query b +aggregateOrdered :: Ord.Order a -> Aggregator a b -> S.Select a -> S.Select b aggregateOrdered o agg = aggregate (orderAggregate o agg) -- | Aggregate only distinct values @@ -100,36 +101,36 @@ sum = A.makeAggr HPQ.AggrSum -- | Count the number of non-null rows in a group. -count :: Aggregator (C.Column a) (C.Column T.PGInt8) +count :: Aggregator (C.Column a) (C.Column T.SqlInt8) count = A.makeAggr HPQ.AggrCount -- | Count the number of rows in a group. This 'Aggregator' is named -- @countStar@ after SQL's @COUNT(*)@ aggregation function. -countStar :: Aggregator a (C.Column T.PGInt8) -countStar = lmap (const (0 :: C.Column T.PGInt4)) count +countStar :: Aggregator a (C.Column T.SqlInt8) +countStar = lmap (const (0 :: C.Column T.SqlInt4)) count -- | Average of a group -avg :: Aggregator (C.Column T.PGFloat8) (C.Column T.PGFloat8) +avg :: Aggregator (C.Column T.SqlFloat8) (C.Column T.SqlFloat8) avg = A.makeAggr HPQ.AggrAvg -- | Maximum of a group -max :: Ord.PGOrd a => Aggregator (C.Column a) (C.Column a) +max :: Ord.SqlOrd a => Aggregator (C.Column a) (C.Column a) max = A.makeAggr HPQ.AggrMax -- | Maximum of a group -min :: Ord.PGOrd a => Aggregator (C.Column a) (C.Column a) +min :: Ord.SqlOrd a => Aggregator (C.Column a) (C.Column a) min = A.makeAggr HPQ.AggrMin -boolOr :: Aggregator (C.Column T.PGBool) (C.Column T.PGBool) +boolOr :: Aggregator (C.Column T.SqlBool) (C.Column T.SqlBool) boolOr = A.makeAggr HPQ.AggrBoolOr -boolAnd :: Aggregator (C.Column T.PGBool) (C.Column T.PGBool) +boolAnd :: Aggregator (C.Column T.SqlBool) (C.Column T.SqlBool) boolAnd = A.makeAggr HPQ.AggrBoolAnd -arrayAgg :: Aggregator (C.Column a) (C.Column (T.PGArray a)) +arrayAgg :: Aggregator (C.Column a) (C.Column (T.SqlArray a)) arrayAgg = A.makeAggr HPQ.AggrArr -stringAgg :: C.Column T.PGText -> Aggregator (C.Column T.PGText) (C.Column T.PGText) +stringAgg :: C.Column T.SqlText -> Aggregator (C.Column T.SqlText) (C.Column T.SqlText) stringAgg = A.makeAggr' . Just . HPQ.AggrStringAggr . IC.unColumn -- | Count the number of rows in a query. This is different from @@ -142,13 +143,13 @@ -- changing the AST though, so I'm not too keen. -- -- See https://github.com/tomjaguarpaw/haskell-opaleye/issues/162 -countRows :: Query a -> Query (C.Column T.PGInt8) +countRows :: S.Select a -> S.Select (C.Column T.SqlInt8) countRows = fmap (C.fromNullable 0) . fmap snd . (\q -> J.leftJoin (pure ()) (aggregate count q) - (const (T.pgBool True))) - . fmap (const (0 :: C.Column T.PGInt4)) + (const (T.sqlBool True))) + . fmap (const (0 :: C.Column T.SqlInt4)) --- ^^ The count aggregator requires an input of type -- 'Column a' rather than 'a' (I'm not sure if there's a -- good reason for this). To deal with that restriction diff --git a/src/Opaleye/Binary.hs b/src/Opaleye/Binary.hs --- a/src/Opaleye/Binary.hs +++ b/src/Opaleye/Binary.hs @@ -1,25 +1,25 @@ --- | Binary relational operations on 'Query's, that is, operations --- which take two 'Query's as arguments and return a single 'Query'. +-- | Binary relational operations on 'S.Select's, that is, operations +-- which take two 'S.Select's as arguments and return a single 'S.Select'. -- -- All the binary relational operations have the same type -- specializations. For example: -- -- @ --- unionAll :: Query (Column a, Column b) --- -> Query (Column a, Column b) --- -> Query (Column a, Column b) +-- unionAll :: S.Select (Column a, Column b) +-- -> S.Select (Column a, Column b) +-- -> S.Select (Column a, Column b) -- @ -- -- Assuming the @makeAdaptorAndInstance@ splice has been run for the product type @Foo@: -- -- @ --- unionAll :: Query (Foo (Column a) (Column b) (Column c)) --- -> Query (Foo (Column a) (Column b) (Column c)) --- -> Query (Foo (Column a) (Column b) (Column c)) +-- unionAll :: S.Select (Foo (Column a) (Column b) (Column c)) +-- -> S.Select (Foo (Column a) (Column b) (Column c)) +-- -> S.Select (Foo (Column a) (Column b) (Column c)) -- @ -- -- Please note that by design there are no binary relational functions --- of type @QueryArr a b -> QueryArr a b -> QueryArr a b@. Such +-- of type @S.SelectArr a b -> S.SelectArr a b -> S.SelectArr a b@. Such -- functions would allow violation of SQL's scoping rules and lead to -- invalid queries. -- @@ -31,66 +31,66 @@ module Opaleye.Binary where -import Opaleye.QueryArr (Query) import qualified Opaleye.Internal.Binary as B import qualified Opaleye.Internal.PrimQuery as PQ +import qualified Opaleye.Select as S import Data.Profunctor.Product.Default (Default, def) -- * Binary operations -unionAll :: Default B.Binaryspec columns columns => - Query columns -> Query columns -> Query columns +unionAll :: Default B.Binaryspec fields fields => + S.Select fields -> S.Select fields -> S.Select fields unionAll = unionAllExplicit def -- | The same as unionAll, except that it additionally removes any -- duplicate rows. -union :: Default B.Binaryspec columns columns => - Query columns -> Query columns -> Query columns +union :: Default B.Binaryspec fields fields => + S.Select fields -> S.Select fields -> S.Select fields union = unionExplicit def -intersectAll :: Default B.Binaryspec columns columns => - Query columns -> Query columns -> Query columns +intersectAll :: Default B.Binaryspec fields fields => + S.Select fields -> S.Select fields -> S.Select fields intersectAll = intersectAllExplicit def -- | The same as intersectAll, except that it additionally removes any -- duplicate rows. -intersect :: Default B.Binaryspec columns columns => - Query columns -> Query columns -> Query columns +intersect :: Default B.Binaryspec fields fields => + S.Select fields -> S.Select fields -> S.Select fields intersect = intersectExplicit def -exceptAll :: Default B.Binaryspec columns columns => - Query columns -> Query columns -> Query columns +exceptAll :: Default B.Binaryspec fields fields => + S.Select fields -> S.Select fields -> S.Select fields exceptAll = exceptAllExplicit def -- | The same as exceptAll, except that it additionally removes any -- duplicate rows. -except :: Default B.Binaryspec columns columns => - Query columns -> Query columns -> Query columns +except :: Default B.Binaryspec fields fields => + S.Select fields -> S.Select fields -> S.Select fields except = exceptExplicit def -- * Explicit versions -unionAllExplicit :: B.Binaryspec columns columns' - -> Query columns -> Query columns -> Query columns' +unionAllExplicit :: B.Binaryspec fields fields' + -> S.Select fields -> S.Select fields -> S.Select fields' unionAllExplicit = B.sameTypeBinOpHelper PQ.UnionAll -unionExplicit :: B.Binaryspec columns columns' - -> Query columns -> Query columns -> Query columns' +unionExplicit :: B.Binaryspec fields fields' + -> S.Select fields -> S.Select fields -> S.Select fields' unionExplicit = B.sameTypeBinOpHelper PQ.Union -intersectAllExplicit :: B.Binaryspec columns columns' - -> Query columns -> Query columns -> Query columns' +intersectAllExplicit :: B.Binaryspec fields fields' + -> S.Select fields -> S.Select fields -> S.Select fields' intersectAllExplicit = B.sameTypeBinOpHelper PQ.IntersectAll -intersectExplicit :: B.Binaryspec columns columns' - -> Query columns -> Query columns -> Query columns' +intersectExplicit :: B.Binaryspec fields fields' + -> S.Select fields -> S.Select fields -> S.Select fields' intersectExplicit = B.sameTypeBinOpHelper PQ.Intersect -exceptAllExplicit :: B.Binaryspec columns columns' - -> Query columns -> Query columns -> Query columns' +exceptAllExplicit :: B.Binaryspec fields fields' + -> S.Select fields -> S.Select fields -> S.Select fields' exceptAllExplicit = B.sameTypeBinOpHelper PQ.ExceptAll -exceptExplicit :: B.Binaryspec columns columns' - -> Query columns -> Query columns -> Query columns' +exceptExplicit :: B.Binaryspec fields fields' + -> S.Select fields -> S.Select fields -> S.Select fields' exceptExplicit = B.sameTypeBinOpHelper PQ.Except diff --git a/src/Opaleye/Constant.hs b/src/Opaleye/Constant.hs --- a/src/Opaleye/Constant.hs +++ b/src/Opaleye/Constant.hs @@ -4,7 +4,7 @@ import Opaleye.Column (Column) import qualified Opaleye.Column as C -import qualified Opaleye.PGTypes as T +import qualified Opaleye.SqlTypes as T import qualified Data.Aeson as Ae import qualified Data.CaseInsensitive as CI @@ -13,6 +13,7 @@ import qualified Data.Text.Lazy as LT import qualified Data.ByteString as SBS import qualified Data.ByteString.Lazy as LBS +import qualified Data.Scientific as Sci import qualified Data.Time as Time import qualified Data.UUID as UUID @@ -26,8 +27,8 @@ import qualified Database.PostgreSQL.Simple.Range as R --- | 'constant' provides a convenient typeclass wrapper around the --- 'Column' creation functions in "Opaleye.PGTypes". Besides +-- | 'toFields' provides a convenient typeclass wrapper around the +-- 'Column' creation functions in "Opaleye.SqlTypes". Besides -- convenience it doesn't provide any additional functionality. -- -- It can be used with functions like 'Opaleye.Manipulation.runInsert' @@ -36,124 +37,133 @@ -- -- @ -- customInsert --- :: ( 'D.Default' 'Constant' haskells columns ) +-- :: ( 'D.Default' 'Constant' haskells fields ) -- => Connection --- -> 'Opaleye.Table' columns columns' +-- -> 'Opaleye.Table' fields fields' -- -> haskells -- -> IO Int64 --- customInsert conn table haskells = 'Opaleye.Manipulation.runInsert' conn table $ 'constant' haskells +-- customInsert conn table haskells = 'Opaleye.Manipulation.runInsert' conn table $ 'toFields' haskells -- @ -- -- In order to use this function with your custom types, you need to define an -- instance of 'D.Default' 'Constant' for your custom types. -constant :: D.Default Constant haskells columns - => haskells -> columns +toFields :: D.Default Constant haskells fields + => haskells -> fields +toFields = constantExplicit D.def + +constant :: D.Default Constant haskells fields + => haskells -> fields constant = constantExplicit D.def -newtype Constant haskells columns = - Constant { constantExplicit :: haskells -> columns } +newtype Constant haskells fields = + Constant { constantExplicit :: haskells -> fields } +type ToFields = Constant + instance D.Default Constant haskell (Column sql) => D.Default Constant (Maybe haskell) (Column (C.Nullable sql)) where def = Constant (C.maybeToNullable . fmap f) where Constant f = D.def -instance D.Default Constant String (Column T.PGText) where - def = Constant T.pgString +instance D.Default Constant String (Column T.SqlText) where + def = Constant T.sqlString -instance D.Default Constant LBS.ByteString (Column T.PGBytea) where - def = Constant T.pgLazyByteString +instance D.Default Constant LBS.ByteString (Column T.SqlBytea) where + def = Constant T.sqlLazyByteString -instance D.Default Constant SBS.ByteString (Column T.PGBytea) where - def = Constant T.pgStrictByteString +instance D.Default Constant SBS.ByteString (Column T.SqlBytea) where + def = Constant T.sqlStrictByteString -instance D.Default Constant ST.Text (Column T.PGText) where - def = Constant T.pgStrictText +instance D.Default Constant ST.Text (Column T.SqlText) where + def = Constant T.sqlStrictText -instance D.Default Constant LT.Text (Column T.PGText) where - def = Constant T.pgLazyText +instance D.Default Constant LT.Text (Column T.SqlText) where + def = Constant T.sqlLazyText -instance D.Default Constant Int (Column T.PGInt4) where - def = Constant T.pgInt4 +instance D.Default Constant Sci.Scientific (Column T.SqlNumeric) where + def = Constant T.sqlNumeric -instance D.Default Constant Int.Int32 (Column T.PGInt4) where - def = Constant $ T.pgInt4 . fromIntegral +instance D.Default Constant Int (Column T.SqlInt4) where + def = Constant T.sqlInt4 -instance D.Default Constant Int.Int64 (Column T.PGInt8) where - def = Constant T.pgInt8 +instance D.Default Constant Int.Int32 (Column T.SqlInt4) where + def = Constant $ T.sqlInt4 . fromIntegral -instance D.Default Constant Double (Column T.PGFloat8) where - def = Constant T.pgDouble +instance D.Default Constant Int.Int64 (Column T.SqlInt8) where + def = Constant T.sqlInt8 -instance D.Default Constant Bool (Column T.PGBool) where - def = Constant T.pgBool +instance D.Default Constant Double (Column T.SqlFloat8) where + def = Constant T.sqlDouble -instance D.Default Constant UUID.UUID (Column T.PGUuid) where - def = Constant T.pgUUID +instance D.Default Constant Bool (Column T.SqlBool) where + def = Constant T.sqlBool -instance D.Default Constant Time.Day (Column T.PGDate) where - def = Constant T.pgDay +instance D.Default Constant UUID.UUID (Column T.SqlUuid) where + def = Constant T.sqlUUID -instance D.Default Constant Time.UTCTime (Column T.PGTimestamptz) where - def = Constant T.pgUTCTime +instance D.Default Constant Time.Day (Column T.SqlDate) where + def = Constant T.sqlDay -instance D.Default Constant Time.LocalTime (Column T.PGTimestamp) where - def = Constant T.pgLocalTime +instance D.Default Constant Time.UTCTime (Column T.SqlTimestamptz) where + def = Constant T.sqlUTCTime -instance D.Default Constant Time.ZonedTime (Column T.PGTimestamptz) where - def = Constant T.pgZonedTime +instance D.Default Constant Time.LocalTime (Column T.SqlTimestamp) where + def = Constant T.sqlLocalTime -instance D.Default Constant Time.TimeOfDay (Column T.PGTime) where - def = Constant T.pgTimeOfDay +instance D.Default Constant Time.ZonedTime (Column T.SqlTimestamptz) where + def = Constant T.sqlZonedTime -instance D.Default Constant (CI.CI ST.Text) (Column T.PGCitext) where - def = Constant T.pgCiStrictText +instance D.Default Constant Time.TimeOfDay (Column T.SqlTime) where + def = Constant T.sqlTimeOfDay -instance D.Default Constant (CI.CI LT.Text) (Column T.PGCitext) where - def = Constant T.pgCiLazyText +instance D.Default Constant (CI.CI ST.Text) (Column T.SqlCitext) where + def = Constant T.sqlCiStrictText -instance D.Default Constant SBS.ByteString (Column T.PGJson) where - def = Constant T.pgStrictJSON +instance D.Default Constant (CI.CI LT.Text) (Column T.SqlCitext) where + def = Constant T.sqlCiLazyText -instance D.Default Constant LBS.ByteString (Column T.PGJson) where - def = Constant T.pgLazyJSON +instance D.Default Constant SBS.ByteString (Column T.SqlJson) where + def = Constant T.sqlStrictJSON -instance D.Default Constant Ae.Value (Column T.PGJson) where - def = Constant T.pgValueJSON +instance D.Default Constant LBS.ByteString (Column T.SqlJson) where + def = Constant T.sqlLazyJSON -instance D.Default Constant SBS.ByteString (Column T.PGJsonb) where - def = Constant T.pgStrictJSONB +instance D.Default Constant Ae.Value (Column T.SqlJson) where + def = Constant T.sqlValueJSON -instance D.Default Constant LBS.ByteString (Column T.PGJsonb) where - def = Constant T.pgLazyJSONB +instance D.Default Constant SBS.ByteString (Column T.SqlJsonb) where + def = Constant T.sqlStrictJSONB -instance D.Default Constant Ae.Value (Column T.PGJsonb) where - def = Constant T.pgValueJSONB +instance D.Default Constant LBS.ByteString (Column T.SqlJsonb) where + def = Constant T.sqlLazyJSONB +instance D.Default Constant Ae.Value (Column T.SqlJsonb) where + def = Constant T.sqlValueJSONB + instance D.Default Constant haskell (Column sql) => D.Default Constant (Maybe haskell) (Maybe (Column sql)) where def = Constant (constant <$>) instance (D.Default Constant a (Column b), T.IsSqlType b) - => D.Default Constant [a] (Column (T.PGArray b)) where - def = Constant (T.pgArray (constantExplicit D.def)) + => D.Default Constant [a] (Column (T.SqlArray b)) where + def = Constant (T.sqlArray (constantExplicit D.def)) -instance D.Default Constant (R.PGRange Int.Int) (Column (T.PGRange T.PGInt4)) where - def = Constant $ \(R.PGRange a b) -> T.pgRange T.pgInt4 a b +instance D.Default Constant (R.PGRange Int.Int) (Column (T.SqlRange T.SqlInt4)) where + def = Constant $ \(R.PGRange a b) -> T.sqlRange T.sqlInt4 a b -instance D.Default Constant (R.PGRange Int.Int64) (Column (T.PGRange T.PGInt8)) where - def = Constant $ \(R.PGRange a b) -> T.pgRange T.pgInt8 a b +instance D.Default Constant (R.PGRange Int.Int64) (Column (T.SqlRange T.SqlInt8)) where + def = Constant $ \(R.PGRange a b) -> T.sqlRange T.sqlInt8 a b --- TODO ---instance D.Default Constant (R.PGRange _) (Column (T.PGRange PGNumeric)) where +instance D.Default Constant (R.PGRange Sci.Scientific) (Column (T.SqlRange T.SqlNumeric)) where + def = Constant $ \(R.PGRange a b) -> T.sqlRange T.sqlNumeric a b -instance D.Default Constant (R.PGRange Time.LocalTime) (Column (T.PGRange T.PGTimestamp)) where - def = Constant $ \(R.PGRange a b) -> T.pgRange T.pgLocalTime a b +instance D.Default Constant (R.PGRange Time.LocalTime) (Column (T.SqlRange T.SqlTimestamp)) where + def = Constant $ \(R.PGRange a b) -> T.sqlRange T.sqlLocalTime a b -instance D.Default Constant (R.PGRange Time.UTCTime) (Column (T.PGRange T.PGTimestamptz)) where - def = Constant $ \(R.PGRange a b) -> T.pgRange T.pgUTCTime a b +instance D.Default Constant (R.PGRange Time.UTCTime) (Column (T.SqlRange T.SqlTimestamptz)) where + def = Constant $ \(R.PGRange a b) -> T.sqlRange T.sqlUTCTime a b -instance D.Default Constant (R.PGRange Time.Day) (Column (T.PGRange T.PGDate)) where - def = Constant $ \(R.PGRange a b) -> T.pgRange T.pgDay a b +instance D.Default Constant (R.PGRange Time.Day) (Column (T.SqlRange T.SqlDate)) where + def = Constant $ \(R.PGRange a b) -> T.sqlRange T.sqlDay a b -- { Boilerplate instances diff --git a/src/Opaleye/Distinct.hs b/src/Opaleye/Distinct.hs --- a/src/Opaleye/Distinct.hs +++ b/src/Opaleye/Distinct.hs @@ -3,28 +3,28 @@ module Opaleye.Distinct (module Opaleye.Distinct, distinctExplicit) where -import Opaleye.QueryArr (Query) +import Opaleye.Select (Select) import Opaleye.Internal.Distinct (distinctExplicit, Distinctspec) import qualified Data.Profunctor.Product.Default as D --- | Remove duplicate rows from the 'Query'. +-- | Remove duplicate rows from the 'Select'. -- -- Example type specialization: -- -- @ --- distinct :: Query (Column a, Column b) -> Query (Column a, Column b) +-- distinct :: Select (Column a, Column b) -> Select (Column a, Column b) -- @ -- -- Assuming the @makeAdaptorAndInstance@ splice has been run for the product type @Foo@: -- -- @ --- distinct :: Query (Foo (Column a) (Column b) (Column c)) -> Query (Foo (Column a) (Column b) (Column c)) +-- distinct :: Select (Foo (Column a) (Column b) (Column c)) -> Select (Foo (Column a) (Column b) (Column c)) -- @ -- --- By design there is no @distinct@ function of type @QueryArr a b -> --- QueryArr a b@. Such a function would allow violation of SQL's +-- By design there is no @distinct@ function of type @SelectArr a b -> +-- SelectArr a b@. Such a function would allow violation of SQL's -- scoping rules and lead to invalid queries. -distinct :: D.Default Distinctspec columns columns => - Query columns -> Query columns +distinct :: D.Default Distinctspec fields fields => + Select fields -> Select fields distinct = distinctExplicit D.def diff --git a/src/Opaleye/Field.hs b/src/Opaleye/Field.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Field.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} + +module Opaleye.Field where + +import qualified Opaleye.Column as C +import qualified Opaleye.PGTypes as T + +type family Field_ (a :: Nullability) b + +data Nullability = NonNullable | Nullable + +type instance Field_ 'NonNullable a = C.Column a +type instance Field_ 'Nullable a = C.Column (C.Nullable a) + +type FieldNullable a = Field_ 'Nullable a +type Field a = Field_ 'NonNullable a + +-- | A NULL of any type +null :: FieldNullable a +null = C.null + +-- | @TRUE@ if the value of the column is @NULL@, @FALSE@ otherwise. +isNull :: FieldNullable a -> Field T.PGBool +isNull = C.isNull + +-- | If the @Field 'Nullable a@ is NULL then return the @Field +-- 'NonNullable b@ otherwise map the underlying @Field 'Nullable a@ +-- using the provided function. +-- +-- The Opaleye equivalent of 'Data.Maybe.maybe'. +-- +-- Will be generalized to @Field_ n b@ in a later version. +matchNullable :: Field_ 'NonNullable b + -- ^ + -> (Field_ 'NonNullable a -> Field_ 'NonNullable b) + -- ^ + -> Field_ 'Nullable a + -- ^ + -> Field_ 'NonNullable b +matchNullable = C.matchNullable + +-- | If the @Field 'Nullable a@ is NULL then return the provided +-- @Field 'NonNullable a@ otherwise return the underlying @Field +-- 'NonNullable a@. +-- +-- The Opaleye equivalent of 'Data.Maybe.fromMaybe' and very similar +-- to PostgreSQL's @COALESCE@. +-- +-- Will be generalized to @Field_ n a@ in a later version. +fromNullable :: Field_ 'NonNullable a + -- ^ + -> Field_ 'Nullable a + -- ^ + -> Field_ 'NonNullable a +fromNullable = C.fromNullable + +-- | Treat a field as though it were nullable. This is always safe. +-- +-- The Opaleye equivalent of 'Data.Maybe.Just'. +-- +-- Will be generalized to @Field_ n a@ in a later version. +toNullable :: Field_ 'NonNullable a -> Field_ 'Nullable a +toNullable = C.unsafeCoerceColumn + +-- | If the argument is 'Data.Maybe.Nothing' return NULL otherwise return the +-- provided value coerced to a nullable type. +-- +-- Will be generalized to @Maybe (Field_ n a)@ in a later version. +maybeToNullable :: Maybe (Field_ 'NonNullable a) + -> Field_ 'Nullable a +maybeToNullable = C.maybeToNullable diff --git a/src/Opaleye/FunctionalJoin.hs b/src/Opaleye/FunctionalJoin.hs --- a/src/Opaleye/FunctionalJoin.hs +++ b/src/Opaleye/FunctionalJoin.hs @@ -16,45 +16,45 @@ import qualified Data.Profunctor.Product as PP import qualified Opaleye.Column as C -import Opaleye.Internal.Column (Column, Nullable) +import qualified Opaleye.Field as F import qualified Opaleye.Internal.Join as IJ import qualified Opaleye.Internal.Operators as IO import qualified Opaleye.Internal.Unpackspec as IU import qualified Opaleye.Join as J -import qualified Opaleye.PGTypes as T +import qualified Opaleye.Select as S +import qualified Opaleye.SqlTypes as T import qualified Opaleye.Operators as O -import Opaleye.QueryArr (Query) -joinF :: (columnsL -> columnsR -> columnsResult) - -- ^ Calculate result columns from input columns - -> (columnsL -> columnsR -> Column T.PGBool) +joinF :: (fieldsL -> fieldsR -> fieldsResult) + -- ^ Calculate result fields from input fields + -> (fieldsL -> fieldsR -> F.Field T.SqlBool) -- ^ Condition on which to join - -> Query columnsL + -> S.Select fieldsL -- ^ Left query - -> Query columnsR + -> S.Select fieldsR -- ^ Right query - -> Query columnsResult + -> S.Select fieldsResult joinF f cond l r = fmap (uncurry f) (O.keepWhen (uncurry cond) <<< ((,) <$> l <*> r)) -leftJoinF :: (D.Default IO.IfPP columnsResult columnsResult, - D.Default IU.Unpackspec columnsL columnsL, - D.Default IU.Unpackspec columnsR columnsR) - => (columnsL -> columnsR -> columnsResult) +leftJoinF :: (D.Default IO.IfPP fieldsResult fieldsResult, + D.Default IU.Unpackspec fieldsL fieldsL, + D.Default IU.Unpackspec fieldsR fieldsR) + => (fieldsL -> fieldsR -> fieldsResult) -- ^ Calculate result row from input rows for rows in the -- right query satisfying the join condition - -> (columnsL -> columnsResult) + -> (fieldsL -> fieldsResult) -- ^ Calculate result row from input row when there are /no/ -- rows in the right query satisfying the join condition - -> (columnsL -> columnsR -> Column T.PGBool) + -> (fieldsL -> fieldsR -> F.Field T.SqlBool) -- ^ Condition on which to join - -> Query columnsL + -> S.Select fieldsL -- ^ Left query - -> Query columnsR + -> S.Select fieldsR -- ^ Right query - -> Query columnsResult + -> S.Select fieldsResult leftJoinF f fL cond l r = fmap ret j - where a1 = fmap (\x -> (x, T.pgBool True)) + where a1 = fmap (\x -> (x, T.sqlBool True)) j = J.leftJoinExplicit D.def D.def (PP.p2 (IJ.NullMaker id, nullmakerBool)) @@ -64,28 +64,28 @@ ret (lr, (rr, rc)) = O.ifThenElseMany (C.isNull rc) (fL lr) (f lr rr) - nullmakerBool :: IJ.NullMaker (Column T.PGBool) - (Column (Nullable T.PGBool)) + nullmakerBool :: IJ.NullMaker (F.Field T.SqlBool) + (F.FieldNullable T.SqlBool) nullmakerBool = D.def -rightJoinF :: (D.Default IO.IfPP columnsResult columnsResult, - D.Default IU.Unpackspec columnsL columnsL, - D.Default IU.Unpackspec columnsR columnsR) - => (columnsL -> columnsR -> columnsResult) +rightJoinF :: (D.Default IO.IfPP fieldsResult fieldsResult, + D.Default IU.Unpackspec fieldsL fieldsL, + D.Default IU.Unpackspec fieldsR fieldsR) + => (fieldsL -> fieldsR -> fieldsResult) -- ^ Calculate result row from input rows for rows in the -- left query satisfying the join condition - -> (columnsR -> columnsResult) + -> (fieldsR -> fieldsResult) -- ^ Calculate result row from input row when there are /no/ -- rows in the left query satisfying the join condition - -> (columnsL -> columnsR -> Column T.PGBool) + -> (fieldsL -> fieldsR -> F.Field T.SqlBool) -- ^ Condition on which to join - -> Query columnsL + -> S.Select fieldsL -- ^ Left query - -> Query columnsR + -> S.Select fieldsR -- ^ Right query - -> Query columnsResult + -> S.Select fieldsResult rightJoinF f fR cond l r = fmap ret j - where a1 = fmap (\x -> (x, T.pgBool True)) + where a1 = fmap (\x -> (x, T.sqlBool True)) j = J.rightJoinExplicit D.def D.def (PP.p2 (IJ.NullMaker id, nullmakerBool)) @@ -95,33 +95,33 @@ ret ((lr, lc), rr) = O.ifThenElseMany (C.isNull lc) (fR rr) (f lr rr) - nullmakerBool :: IJ.NullMaker (Column T.PGBool) - (Column (Nullable T.PGBool)) + nullmakerBool :: IJ.NullMaker (F.Field T.SqlBool) + (F.FieldNullable T.SqlBool) nullmakerBool = D.def -fullJoinF :: (D.Default IO.IfPP columnsResult columnsResult, - D.Default IU.Unpackspec columnsL columnsL, - D.Default IU.Unpackspec columnsR columnsR) - => (columnsL -> columnsR -> columnsResult) +fullJoinF :: (D.Default IO.IfPP fieldsResult fieldsResult, + D.Default IU.Unpackspec fieldsL fieldsL, + D.Default IU.Unpackspec fieldsR fieldsR) + => (fieldsL -> fieldsR -> fieldsResult) -- ^ Calculate result row from input rows for rows in the -- left and right query satisfying the join condition - -> (columnsL -> columnsResult) + -> (fieldsL -> fieldsResult) -- ^ Calculate result row from left input row when there -- are /no/ rows in the right query satisfying the join -- condition - -> (columnsR -> columnsResult) + -> (fieldsR -> fieldsResult) -- ^ Calculate result row from right input row when there -- are /no/ rows in the left query satisfying the join -- condition - -> (columnsL -> columnsR -> Column T.PGBool) + -> (fieldsL -> fieldsR -> F.Field T.SqlBool) -- ^ Condition on which to join - -> Query columnsL + -> S.Select fieldsL -- ^ Left query - -> Query columnsR + -> S.Select fieldsR -- ^ Right query - -> Query columnsResult + -> S.Select fieldsResult fullJoinF f fL fR cond l r = fmap ret j - where a1 = fmap (\x -> (x, T.pgBool True)) + where a1 = fmap (\x -> (x, T.sqlBool True)) j = J.fullJoinExplicit D.def D.def (PP.p2 (IJ.NullMaker id, nullmakerBool)) @@ -136,6 +136,6 @@ (fL lr) (f lr rr)) - nullmakerBool :: IJ.NullMaker (Column T.PGBool) - (Column (Nullable T.PGBool)) + nullmakerBool :: IJ.NullMaker (F.Field T.SqlBool) + (F.FieldNullable T.SqlBool) nullmakerBool = D.def 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 @@ -1,3 +1,5 @@ +{-# LANGUAGE ConstraintKinds #-} + module Opaleye.Internal.Column where import Data.String @@ -61,8 +63,13 @@ class PGNum a where pgFromInteger :: Integer -> Column a + pgFromInteger = sqlFromInteger -instance PGNum a => Num (Column a) where + sqlFromInteger :: Integer -> Column a + +type SqlNum = PGNum + +instance SqlNum a => Num (Column a) where fromInteger = pgFromInteger (*) = binOp (HPQ.:*) (+) = binOp (HPQ.:+) @@ -77,16 +84,28 @@ class PGFractional a where pgFromRational :: Rational -> Column a + pgFromRational = sqlFromRational -instance (PGNum a, PGFractional a) => Fractional (Column a) where - fromRational = pgFromRational + sqlFromRational :: Rational -> Column a + +type SqlFractional = PGFractional + +instance (SqlNum a, SqlFractional a) => Fractional (Column a) where + fromRational = sqlFromRational (/) = binOp (HPQ.:/) -- | A dummy typeclass whose instances support integral operations. class PGIntegral a +type SqlIntegral = PGIntegral + class PGString a where pgFromString :: String -> Column a + pgFromString = sqlFromString -instance PGString a => IsString (Column a) where - fromString = pgFromString + sqlFromString :: String -> Column a + +type SqlString = PGString + +instance SqlString a => IsString (Column a) where + fromString = sqlFromString diff --git a/src/Opaleye/Internal/HaskellDB/PrimQuery.hs b/src/Opaleye/Internal/HaskellDB/PrimQuery.hs --- a/src/Opaleye/Internal/HaskellDB/PrimQuery.hs +++ b/src/Opaleye/Internal/HaskellDB/PrimQuery.hs @@ -7,6 +7,7 @@ import qualified Opaleye.Internal.Tag as T import Data.ByteString (ByteString) import qualified Data.List.NonEmpty as NEL +import qualified Data.Scientific as Sci type TableName = String type Attribute = String @@ -45,6 +46,7 @@ | ByteStringLit ByteString | IntegerLit Integer | DoubleLit Double + | NumericLit Sci.Scientific | OtherLit String -- ^ used for hacking in custom SQL deriving (Read,Show) diff --git a/src/Opaleye/Internal/HaskellDB/Sql.hs b/src/Opaleye/Internal/HaskellDB/Sql.hs --- a/src/Opaleye/Internal/HaskellDB/Sql.hs +++ b/src/Opaleye/Internal/HaskellDB/Sql.hs @@ -64,5 +64,8 @@ -- | Data type for SQL DELETE statements. data SqlDelete = SqlDelete SqlTable [SqlExpr] +data OnConflict = DoNothing + -- ^ @ON CONFLICT DO NOTHING@ + --- | Data type for SQL INSERT statements. -data SqlInsert = SqlInsert SqlTable [SqlColumn] (NEL.NonEmpty [SqlExpr]) +data SqlInsert = SqlInsert SqlTable [SqlColumn] (NEL.NonEmpty [SqlExpr]) (Maybe OnConflict) diff --git a/src/Opaleye/Internal/HaskellDB/Sql/Default.hs b/src/Opaleye/Internal/HaskellDB/Sql/Default.hs --- a/src/Opaleye/Internal/HaskellDB/Sql/Default.hs +++ b/src/Opaleye/Internal/HaskellDB/Sql/Default.hs @@ -16,7 +16,11 @@ import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Base16 as Base16 import qualified Data.List.NonEmpty as NEL +import qualified Data.Text.Lazy.Builder.Scientific as Sci +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Builder as LT + mkSqlGenerator :: SqlGenerator -> SqlGenerator mkSqlGenerator gen = SqlGenerator { @@ -65,6 +69,7 @@ -> SqlTable -> [Attribute] -> NEL.NonEmpty [PrimExpr] + -> Maybe OnConflict -> SqlInsert defaultSqlInsert gen tbl attrs exprs = SqlInsert tbl (map toSqlColumn attrs) ((fmap . map) (sqlExpr gen) exprs) @@ -239,6 +244,7 @@ else if isInfinite d && d < 0 then "'-Infinity'" else if isInfinite d && d > 0 then "'Infinity'" else show d + NumericLit n -> LT.unpack . LT.toLazyText . Sci.scientificBuilder $ n OtherLit o -> o diff --git a/src/Opaleye/Internal/HaskellDB/Sql/Generate.hs b/src/Opaleye/Internal/HaskellDB/Sql/Generate.hs --- a/src/Opaleye/Internal/HaskellDB/Sql/Generate.hs +++ b/src/Opaleye/Internal/HaskellDB/Sql/Generate.hs @@ -13,7 +13,7 @@ { sqlUpdate :: SqlTable -> [PrimExpr] -> Assoc -> SqlUpdate, sqlDelete :: SqlTable -> [PrimExpr] -> SqlDelete, - sqlInsert :: SqlTable -> [Attribute] -> NEL.NonEmpty [PrimExpr] -> SqlInsert, + sqlInsert :: SqlTable -> [Attribute] -> NEL.NonEmpty [PrimExpr] -> Maybe OnConflict -> SqlInsert, sqlExpr :: PrimExpr -> SqlExpr, sqlLiteral :: Literal -> String, -- | Turn a string into a quoted string. Quote characters diff --git a/src/Opaleye/Internal/HaskellDB/Sql/Print.hs b/src/Opaleye/Internal/HaskellDB/Sql/Print.hs --- a/src/Opaleye/Internal/HaskellDB/Sql/Print.hs +++ b/src/Opaleye/Internal/HaskellDB/Sql/Print.hs @@ -21,7 +21,8 @@ import Opaleye.Internal.HaskellDB.Sql (SqlColumn(..), SqlDelete(..), SqlExpr(..), SqlOrder(..), SqlInsert(..), - SqlUpdate(..), SqlTable(..), SqlRangeBound(..)) + SqlUpdate(..), SqlTable(..), SqlRangeBound(..), + OnConflict(..)) import qualified Opaleye.Internal.HaskellDB.Sql as Sql import Data.List (intersperse) @@ -96,12 +97,17 @@ text "DELETE FROM" <+> ppTable table $$ ppWhere criteria +ppConflictStatement :: Maybe OnConflict -> Doc +ppConflictStatement Nothing = text "" +ppConflictStatement (Just DoNothing) = text "ON CONFLICT DO NOTHING" + ppInsert :: SqlInsert -> Doc -ppInsert (SqlInsert table names values) +ppInsert (SqlInsert table names values onConflict) = text "INSERT INTO" <+> ppTable table <+> parens (commaV ppColumn names) $$ text "VALUES" <+> commaV (parens . commaV ppSqlExpr) (NEL.toList values) + <+> ppConflictStatement onConflict -- If we wanted to make the SQL slightly more readable this would be -- one easy place to do it. Currently we wrap all column references diff --git a/src/Opaleye/Internal/Join.hs b/src/Opaleye/Internal/Join.hs --- a/src/Opaleye/Internal/Join.hs +++ b/src/Opaleye/Internal/Join.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} module Opaleye.Internal.Join where @@ -11,6 +12,8 @@ import qualified Opaleye.Internal.PrimQuery as PQ import qualified Opaleye.PGTypes as T import qualified Opaleye.Column as C +import qualified Opaleye.Map as Map +import qualified Opaleye.Internal.TypeFamilies as TF import qualified Control.Applicative as A @@ -54,6 +57,36 @@ Column cond' = cond (columnsA, columnsB) primQueryR = PQ.Join joinType cond' ljPEsA ljPEsB primQueryA primQueryB +leftJoinAExplicit :: U.Unpackspec a a + -> NullMaker a nullableA + -> Q.Query a + -> Q.QueryArr (a -> Column T.PGBool) nullableA +leftJoinAExplicit uA nullmaker rq = + Q.QueryArr $ \(p, primQueryL, t1) -> + let (columnsR, primQueryR, t2) = Q.runSimpleQueryArr rq ((), t1) + (newColumnsR, ljPEsR) = PM.run $ U.runUnpackspec uA (extractLeftJoinFields 2 t2) columnsR + renamedNullable = toNullable nullmaker newColumnsR + Column cond = p newColumnsR + in ( renamedNullable + , PQ.Join + PQ.LeftJoin + cond + [] + --- ^ I am reasonably confident that we don't need any + --- column names here. Columns that can become NULL need + --- to be written here so that we can wrap them. If we + --- don't constant columns can avoid becoming NULL. + --- However, these are the left columns and cannot become + --- NULL in a left join, so we are fine. + --- + --- Report about the "avoiding NULL" bug: + --- + --- https://github.com/tomjaguarpaw/haskell-opaleye/issues/223 + ljPEsR + primQueryL + primQueryR + , T.next t2) + extractLeftJoinFields :: Int -> T.Tag -> HPQ.PrimExpr @@ -77,3 +110,32 @@ (***!) = PP.defaultProfunctorProduct -- + +data Nulled + +type instance TF.IMap Nulled TF.OT = TF.NullsT +type instance TF.IMap Nulled TF.NullsT = TF.NullsT + +-- It's quite unfortunate that we have to write these out by hand +-- until we probably do nullability as a distinction between +-- +-- Column (Nullable a) +-- Column (NonNullable a) + +type instance Map.Map Nulled (Column (Nullable a)) = Column (Nullable a) + +type instance Map.Map Nulled (Column T.PGInt4) = Column (Nullable T.PGInt4) +type instance Map.Map Nulled (Column T.PGInt8) = Column (Nullable T.PGInt8) +type instance Map.Map Nulled (Column T.PGText) = Column (Nullable T.PGText) +type instance Map.Map Nulled (Column T.PGFloat8) = Column (Nullable T.PGFloat8) +type instance Map.Map Nulled (Column T.PGBool) = Column (Nullable T.PGBool) +type instance Map.Map Nulled (Column T.PGUuid) = Column (Nullable T.PGUuid) +type instance Map.Map Nulled (Column T.PGBytea) = Column (Nullable T.PGBytea) +type instance Map.Map Nulled (Column T.PGText) = Column (Nullable T.PGText) +type instance Map.Map Nulled (Column T.PGDate) = Column (Nullable T.PGDate) +type instance Map.Map Nulled (Column T.PGTimestamp) = Column (Nullable T.PGTimestamp) +type instance Map.Map Nulled (Column T.PGTimestamptz) = Column (Nullable T.PGTimestamptz) +type instance Map.Map Nulled (Column T.PGTime) = Column (Nullable T.PGTime) +type instance Map.Map Nulled (Column T.PGCitext) = Column (Nullable T.PGCitext) +type instance Map.Map Nulled (Column T.PGJson) = Column (Nullable T.PGJson) +type instance Map.Map Nulled (Column T.PGJsonb) = Column (Nullable T.PGJsonb) diff --git a/src/Opaleye/Internal/Manipulation.hs b/src/Opaleye/Internal/Manipulation.hs --- a/src/Opaleye/Internal/Manipulation.hs +++ b/src/Opaleye/Internal/Manipulation.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} module Opaleye.Internal.Manipulation where @@ -7,9 +8,101 @@ import qualified Control.Applicative as A import Opaleye.Internal.Column (Column) +import qualified Opaleye.Internal.HaskellDB.Sql as HSql +import qualified Opaleye.Internal.HaskellDB.Sql.Default as SD +import qualified Opaleye.Internal.HaskellDB.Sql.Generate as SG +import qualified Opaleye.Internal.HaskellDB.Sql.Print as HPrint +import Opaleye.Internal.Helpers ((.:.), (.::.)) +import qualified Opaleye.Internal.PrimQuery as PQ +import qualified Opaleye.Internal.Print as Print +import qualified Opaleye.Internal.RunQuery as IRQ +import qualified Opaleye.RunQuery as RQ +import qualified Opaleye.Internal.Sql as Sql +import qualified Opaleye.Internal.Table as TI +import qualified Opaleye.Internal.Unpackspec as U +import qualified Opaleye.Table as T + +import Data.Int (Int64) +import qualified Data.List.NonEmpty as NEL import Data.Profunctor (Profunctor, dimap) import qualified Data.Profunctor.Product as PP import qualified Data.Profunctor.Product.Default as D +import Data.String (fromString) + +import qualified Database.PostgreSQL.Simple as PGS + +-- | Don't use this internal datatype. Instead you probably want +-- 'Opaleye.Manipulation.rCount' or 'Opaleye.Manipulation.rReturning'. +data Returning a b where + Count + :: Returning a Int64 + Returning + :: D.Default RQ.QueryRunner b c => (a -> b) -> Returning a [c] + ReturningExplicit + :: RQ.QueryRunner b c -> (a -> b) -> Returning a [c] + +arrangeInsertMany :: T.Table columns a + -> NEL.NonEmpty columns + -> Maybe HSql.OnConflict + -> HSql.SqlInsert +arrangeInsertMany table columns onConflict = insert + 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 + onConflict + +arrangeInsertManyReturning :: U.Unpackspec columnsReturned ignored + -> T.Table columnsW columnsR + -> NEL.NonEmpty columnsW + -> (columnsR -> columnsReturned) + -> Maybe HSql.OnConflict + -> Sql.Returning HSql.SqlInsert +arrangeInsertManyReturning unpackspec table columns returningf onConflict = + Sql.Returning insert returningSEs + where insert = arrangeInsertMany table columns onConflict + TI.View columnsR = TI.tableColumnsView (TI.tableColumns table) + returningPEs = U.collectPEs unpackspec (returningf columnsR) + returningSEs = Sql.ensureColumnsGen id (map Sql.sqlExpr returningPEs) + +arrangeInsertManyReturningSql :: U.Unpackspec columnsReturned ignored + -> T.Table columnsW columnsR + -> NEL.NonEmpty columnsW + -> (columnsR -> columnsReturned) + -> Maybe HSql.OnConflict + -> String +arrangeInsertManyReturningSql = + show . Print.ppInsertReturning .::. arrangeInsertManyReturning + +arrangeInsertManySql :: T.Table columnsW columnsR + -> NEL.NonEmpty columnsW + -> Maybe HSql.OnConflict + -> String +arrangeInsertManySql = + show . HPrint.ppInsert .:. arrangeInsertMany + +runInsertManyReturningExplicit + :: RQ.QueryRunner columnsReturned haskells + -> PGS.Connection + -> T.Table columnsW columnsR + -> [columnsW] + -> (columnsR -> columnsReturned) + -> Maybe HSql.OnConflict + -> IO [haskells] +runInsertManyReturningExplicit + qr conn t columns r onConflict = + case NEL.nonEmpty columns of + Nothing -> return [] + Just columns' -> PGS.queryWith_ parser conn + (fromString + (arrangeInsertManyReturningSql u t columns' r + onConflict)) + where IRQ.QueryRunner u _ _ = qr + parser = IRQ.prepareRowParser qr (r v) + 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. newtype Updater a b = Updater (a -> b) 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 @@ -8,7 +8,7 @@ import Control.Applicative (Applicative, pure, (<*>), liftA2) import qualified Control.Monad.Trans.State as State -import Data.Profunctor (Profunctor, dimap) +import Data.Profunctor (Profunctor, dimap, rmap) import Data.Profunctor.Product (ProductProfunctor, empty, (***!)) import qualified Data.Profunctor.Product as PP import qualified Data.Functor.Identity as I @@ -107,12 +107,11 @@ -- } -eitherFunction :: Functor f - => (a -> f b) - -> (a' -> f b') - -> Either a a' - -> f (Either b b') -eitherFunction f g = fmap (either (fmap Left) (fmap Right)) (f PP.+++! g) +eitherFunction :: (PP.SumProfunctor p, Functor f) + => p a (f b) + -> p a' (f b') + -> p (Either a a') (f (Either b b')) +eitherFunction f g = rmap (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. 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 @@ -6,8 +6,9 @@ import qualified Database.PostgreSQL.Simple.Cursor as PGSC (Cursor) import Database.PostgreSQL.Simple.Internal (RowParser) +import qualified Database.PostgreSQL.Simple.FromField as PGS import Database.PostgreSQL.Simple.FromField - (FieldParser, FromField, fromField, pgArrayFieldParser) + (FieldParser, fromField, pgArrayFieldParser) import Database.PostgreSQL.Simple.FromRow (fromRow, fieldWith) import Database.PostgreSQL.Simple.Types (fromPGArray, Only(..)) @@ -32,6 +33,7 @@ import qualified Data.ByteString as SBS import qualified Data.ByteString.Lazy as LBS import qualified Data.Time as Time +import qualified Data.Scientific as Sci import qualified Data.String as String import Data.UUID (UUID) import GHC.Int (Int32, Int64) @@ -67,9 +69,11 @@ data QueryRunnerColumn pgType haskellType = QueryRunnerColumn (U.Unpackspec (Column pgType) ()) (FieldParser haskellType) -instance Functor (QueryRunnerColumn u) where +instance Functor (FromField u) where fmap f ~(QueryRunnerColumn u fp) = QueryRunnerColumn u ((fmap . fmap . fmap) f fp) +type FromField = QueryRunnerColumn + -- | A 'QueryRunner' specifies how to convert Postgres values (@columns@) -- into Haskell values (@haskells@). Most likely you will never need -- to create on of these or handle one directly. It will be provided @@ -98,18 +102,20 @@ -- PGInt4)' has no columns when it is Nothing and one -- column when it is Just. -fieldQueryRunnerColumn :: FromField haskell => QueryRunnerColumn pgType haskell +type FromFields = QueryRunner + +fieldQueryRunnerColumn :: PGS.FromField haskell => FromField pgType haskell fieldQueryRunnerColumn = fieldParserQueryRunnerColumn fromField -fieldParserQueryRunnerColumn :: FieldParser haskell -> QueryRunnerColumn pgType haskell +fieldParserQueryRunnerColumn :: FieldParser haskell -> FromField pgType haskell fieldParserQueryRunnerColumn = QueryRunnerColumn (P.rmap (const ()) U.unpackspecColumn) -queryRunner :: QueryRunnerColumn a b -> QueryRunner (Column a) b +queryRunner :: FromField a b -> FromFields (Column a) b queryRunner qrc = QueryRunner u (const (fieldWith fp)) (const True) where QueryRunnerColumn u fp = qrc -queryRunnerColumnNullable :: QueryRunnerColumn a b - -> QueryRunnerColumn (Nullable a) (Maybe b) +queryRunnerColumnNullable :: FromField a b + -> FromField (Nullable a) (Maybe b) queryRunnerColumnNullable qr = QueryRunnerColumn (P.lmap C.unsafeCoerceColumn u) (fromField' fp) where QueryRunnerColumn u fp = qr @@ -159,6 +165,13 @@ class QueryRunnerColumnDefault pgType haskellType where queryRunnerColumnDefault :: QueryRunnerColumn pgType haskellType +instance QueryRunnerColumnDefault sqlType haskellType + => D.Default FromField sqlType haskellType where + def = queryRunnerColumnDefault + +instance QueryRunnerColumnDefault T.PGNumeric Sci.Scientific where + queryRunnerColumnDefault = fieldQueryRunnerColumn + instance QueryRunnerColumnDefault T.PGInt4 Int where queryRunnerColumnDefault = fieldQueryRunnerColumn @@ -237,32 +250,32 @@ -- } -instance (Typeable b, FromField b, QueryRunnerColumnDefault a b) => +instance (Typeable b, PGS.FromField b, QueryRunnerColumnDefault a b) => QueryRunnerColumnDefault (T.PGRange a) (PGSR.PGRange b) where queryRunnerColumnDefault = fieldQueryRunnerColumn -- Boilerplate instances -instance Functor (QueryRunner c) where +instance Functor (FromFields c) where fmap f (QueryRunner u r b) = QueryRunner u ((fmap . fmap) f r) b -- TODO: Seems like this one should be simpler! -instance Applicative (QueryRunner c) where +instance Applicative (FromFields c) where pure = flip (QueryRunner (P.lmap (const ()) PP.empty)) (const False) . pure . pure QueryRunner uf rf bf <*> QueryRunner ux rx bx = QueryRunner (P.dimap (\x -> (x,x)) (const ()) (uf PP.***! ux)) ((<*>) <$> rf <*> rx) (liftA2 (||) bf bx) -instance P.Profunctor QueryRunner where +instance P.Profunctor FromFields where dimap f g (QueryRunner u r b) = QueryRunner (P.lmap f u) (P.dimap f (fmap g) r) (P.lmap f b) -instance PP.ProductProfunctor QueryRunner where +instance PP.ProductProfunctor FromFields where empty = PP.defaultEmpty (***!) = PP.defaultProfunctorProduct -instance PP.SumProfunctor QueryRunner where +instance PP.SumProfunctor FromFields where f +++! g = QueryRunner (P.rmap (const ()) (fu PP.+++! gu)) (PackMap.eitherFunction fr gr) (either fb gb) @@ -296,7 +309,7 @@ -- } -prepareRowParser :: QueryRunner columns haskells -> columns -> RowParser haskells +prepareRowParser :: FromFields columns haskells -> columns -> RowParser haskells prepareRowParser (QueryRunner _ rowParser nonZeroColumns) cols = if nonZeroColumns cols then rowParser cols diff --git a/src/Opaleye/Internal/TypeFamilies.hs b/src/Opaleye/Internal/TypeFamilies.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Internal/TypeFamilies.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeInType #-} + +-- TODO +-- Updater -- easier -- this one's probably not needed +-- NullMaker -- easier +-- Constant -- harder +-- QueryRunner -- harder + +module Opaleye.Internal.TypeFamilies where + +import Opaleye.Column (Column, Nullable) +import qualified Opaleye.Field as F + +type family IMap f a + +data HT +data OT +data NullsT +data WT + +type NN = 'F.Nullable +type N = 'F.NonNullable + +data Optionality = OReq | OOpt + +type Req = 'OReq +type Opt = 'OOpt + +type family A (a :: Arr h k1 k2) (b :: k1) :: k2 + +data Arr h k1 k2 where + K :: k1 -> Arr h k2 k1 + S :: Arr h k1 (k2 -> k3) + -> Arr h k1 k2 + -> Arr h k1 k3 + I :: Arr h k1 k1 + H :: h -> Arr h k2 k3 + +type (:<*>) = 'S +type Pure = 'K +type (:<$>) f = (:<*>) (Pure f) +type Id = 'I +type (:<|) f x = A f x + +type instance A 'I a = a +type instance A ('K k1) _ = k1 +type instance A ('S f x) a = (A f a) (A x a) + +data C a = C (a, a, F.Nullability) +data TC a = TC ((a, a, F.Nullability), Optionality) + +type instance A ('H HT) ('C '(h, o, NN)) = h +type instance A ('H HT) ('C '(h, o, N)) = Maybe h +type instance A ('H OT) ('C '(h, o, NN)) = Column o +type instance A ('H OT) ('C '(h, o, N)) = Column (Nullable o) +type instance A ('H NullsT) ('C '(h, o, NN)) = Column (Nullable o) + +type instance A ('H HT) ('TC '(t, b)) = A ('H HT) ('C t) +type instance A ('H OT) ('TC '(t, b)) = A ('H OT) ('C t) +type instance A ('H WT) ('TC '(t, Req)) = A ('H OT) ('C t) +type instance A ('H WT) ('TC '(t, Opt)) = Maybe (A ('H OT) ('C t)) +type instance A ('H NullsT) ('TC '(t, b)) = A ('H NullsT) ('C t) + +type RecordField f a b c = A f ('C '(a, b, c)) +type TableField f a b c d = A f ('TC '( '(a, b, c), d)) + +type H = 'H HT +type O = 'H OT +type Nulls = 'H NullsT +type W = 'H WT +type F = 'H diff --git a/src/Opaleye/Join.hs b/src/Opaleye/Join.hs --- a/src/Opaleye/Join.hs +++ b/src/Opaleye/Join.hs @@ -13,85 +13,154 @@ -- Example specialization: -- -- @ --- leftJoin :: Query (Column a, Column b) --- -> Query (Column c, Column (Nullable d)) --- -> (((Column a, Column b), (Column c, Column (Nullable d))) -> Column 'Opaleye.PGTypes.PGBool') --- -> Query ((Column a, Column b), (Column (Nullable c), Column (Nullable d))) +-- leftJoin :: Select (Column a, Column b) +-- -> Select (Column c, Column (Nullable d)) +-- -> (((Column a, Column b), (Column c, Column (Nullable d))) -> Column 'Opaleye.SqlTypes.SqlBool') +-- -> Select ((Column a, Column b), (Column (Nullable c), Column (Nullable d))) -- @ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} module Opaleye.Join where +import qualified Opaleye.Field as F import qualified Opaleye.Internal.Unpackspec as U import qualified Opaleye.Internal.Join as J import qualified Opaleye.Internal.PrimQuery as PQ +import qualified Opaleye.Map as Map +import qualified Opaleye.Select as S +import qualified Opaleye.SqlTypes as T +import qualified Opaleye.PGTypes as T import Opaleye.QueryArr (Query) -import Opaleye.Internal.Column (Column) -import qualified Opaleye.PGTypes as T +import Opaleye.Column (Column) import qualified Data.Profunctor.Product.Default as D -- * Joins -leftJoin :: (D.Default U.Unpackspec columnsL columnsL, - D.Default U.Unpackspec columnsR columnsR, - D.Default J.NullMaker columnsR nullableColumnsR) - => Query columnsL -- ^ Left query - -> Query columnsR -- ^ Right query - -> ((columnsL, columnsR) -> Column T.PGBool) -- ^ Condition on which to join - -> Query (columnsL, nullableColumnsR) -- ^ Left join +leftJoin :: (D.Default U.Unpackspec fieldsL fieldsL, + D.Default U.Unpackspec fieldsR fieldsR, + D.Default J.NullMaker fieldsR nullableFieldsR) + => S.Select fieldsL -- ^ Left query + -> S.Select fieldsR -- ^ Right query + -> ((fieldsL, fieldsR) -> F.Field T.SqlBool) -- ^ Condition on which to join + -> S.Select (fieldsL, nullableFieldsR) -- ^ Left join leftJoin = leftJoinExplicit D.def D.def D.def -rightJoin :: (D.Default U.Unpackspec columnsL columnsL, - D.Default U.Unpackspec columnsR columnsR, - D.Default J.NullMaker columnsL nullableColumnsL) - => Query columnsL -- ^ Left query - -> Query columnsR -- ^ Right query - -> ((columnsL, columnsR) -> Column T.PGBool) -- ^ Condition on which to join - -> Query (nullableColumnsL, columnsR) -- ^ Right join +-- | 'leftJoinA' is a convenient way of using left joins within arrow +-- notation +leftJoinA :: (D.Default U.Unpackspec fieldsR fieldsR, + D.Default J.NullMaker fieldsR nullableFieldsR) + => S.Select fieldsR + -- ^ Right query + -> S.SelectArr (fieldsR -> F.Field T.SqlBool) nullableFieldsR + -- ^ Condition on which to join goes in, left join + -- result comes out +leftJoinA = leftJoinAExplict D.def D.def + +rightJoin :: (D.Default U.Unpackspec fieldsL fieldsL, + D.Default U.Unpackspec fieldsR fieldsR, + D.Default J.NullMaker fieldsL nullableFieldsL) + => S.Select fieldsL -- ^ Left query + -> S.Select fieldsR -- ^ Right query + -> ((fieldsL, fieldsR) -> F.Field T.SqlBool) -- ^ Condition on which to join + -> S.Select (nullableFieldsL, fieldsR) -- ^ Right join rightJoin = rightJoinExplicit D.def D.def D.def -fullJoin :: (D.Default U.Unpackspec columnsL columnsL, - D.Default U.Unpackspec columnsR columnsR, - D.Default J.NullMaker columnsL nullableColumnsL, - D.Default J.NullMaker columnsR nullableColumnsR) - => Query columnsL -- ^ Left query - -> Query columnsR -- ^ Right query - -> ((columnsL, columnsR) -> Column T.PGBool) -- ^ Condition on which to join - -> Query (nullableColumnsL, nullableColumnsR) -- ^ Full outer join +fullJoin :: (D.Default U.Unpackspec fieldsL fieldsL, + D.Default U.Unpackspec fieldsR fieldsR, + D.Default J.NullMaker fieldsL nullableFieldsL, + D.Default J.NullMaker fieldsR nullableFieldsR) + => S.Select fieldsL -- ^ Left query + -> S.Select fieldsR -- ^ Right query + -> ((fieldsL, fieldsR) -> F.Field T.SqlBool) -- ^ Condition on which to join + -> S.Select (nullableFieldsL, nullableFieldsR) -- ^ Full outer join fullJoin = fullJoinExplicit D.def D.def D.def D.def -- * Explicit versions -leftJoinExplicit :: U.Unpackspec columnsL columnsL - -> U.Unpackspec columnsR columnsR - -> J.NullMaker columnsR nullableColumnsR - -> Query columnsL -> Query columnsR - -> ((columnsL, columnsR) -> Column T.PGBool) - -> Query (columnsL, nullableColumnsR) +leftJoinExplicit :: U.Unpackspec fieldsL fieldsL + -> U.Unpackspec fieldsR fieldsR + -> J.NullMaker fieldsR nullableFieldsR + -> S.Select fieldsL -> S.Select fieldsR + -> ((fieldsL, fieldsR) -> F.Field T.SqlBool) + -> S.Select (fieldsL, nullableFieldsR) leftJoinExplicit uA uB nullmaker = J.joinExplicit uA uB id (J.toNullable nullmaker) PQ.LeftJoin -rightJoinExplicit :: U.Unpackspec columnsL columnsL - -> U.Unpackspec columnsR columnsR - -> J.NullMaker columnsL nullableColumnsL - -> Query columnsL -> Query columnsR - -> ((columnsL, columnsR) -> Column T.PGBool) - -> Query (nullableColumnsL, columnsR) +leftJoinAExplict :: U.Unpackspec fieldsR fieldsR + -> J.NullMaker fieldsR nullableFieldsR + -> S.Select fieldsR + -> S.SelectArr (fieldsR -> F.Field T.SqlBool) nullableFieldsR +leftJoinAExplict = J.leftJoinAExplicit + +rightJoinExplicit :: U.Unpackspec fieldsL fieldsL + -> U.Unpackspec fieldsR fieldsR + -> J.NullMaker fieldsL nullableFieldsL + -> S.Select fieldsL -> S.Select fieldsR + -> ((fieldsL, fieldsR) -> F.Field T.SqlBool) + -> S.Select (nullableFieldsL, fieldsR) rightJoinExplicit uA uB nullmaker = J.joinExplicit uA uB (J.toNullable nullmaker) id PQ.RightJoin -fullJoinExplicit :: U.Unpackspec columnsL columnsL - -> U.Unpackspec columnsR columnsR - -> J.NullMaker columnsL nullableColumnsL - -> J.NullMaker columnsR nullableColumnsR - -> Query columnsL -> Query columnsR - -> ((columnsL, columnsR) -> Column T.PGBool) - -> Query (nullableColumnsL, nullableColumnsR) +fullJoinExplicit :: U.Unpackspec fieldsL fieldsL + -> U.Unpackspec fieldsR fieldsR + -> J.NullMaker fieldsL nullableFieldsL + -> J.NullMaker fieldsR nullableFieldsR + -> S.Select fieldsL -> S.Select fieldsR + -> ((fieldsL, fieldsR) -> F.Field T.SqlBool) + -> S.Select (nullableFieldsL, nullableFieldsR) fullJoinExplicit uA uB nullmakerA nullmakerB = J.joinExplicit uA uB (J.toNullable nullmakerA) (J.toNullable nullmakerB) PQ.FullJoin + +-- * Inferrable versions + +leftJoinInferrable :: (D.Default U.Unpackspec columnsL columnsL, + D.Default U.Unpackspec columnsR columnsR, + D.Default J.NullMaker columnsR nullableColumnsR, + Map.Map J.Nulled columnsR ~ nullableColumnsR) + => Query columnsL + -- ^ Left query + -> Query columnsR + -- ^ Right query + -> ((columnsL, columnsR) -> Column T.PGBool) + -- ^ Condition on which to join + -> Query (columnsL, nullableColumnsR) + -- ^ Left join +leftJoinInferrable = leftJoin + +rightJoinInferrable :: (D.Default U.Unpackspec columnsL columnsL, + D.Default U.Unpackspec columnsR columnsR, + D.Default J.NullMaker columnsL nullableColumnsL, + Map.Map J.Nulled columnsL ~ nullableColumnsL) + => Query columnsL + -- ^ Left query + -> Query columnsR + -- ^ Right query + -> ((columnsL, columnsR) -> Column T.PGBool) + -- ^ Condition on which to join + -> Query (nullableColumnsL, columnsR) + -- ^ Right join +rightJoinInferrable = rightJoin + + +fullJoinInferrable :: (D.Default U.Unpackspec columnsL columnsL, + D.Default U.Unpackspec columnsR columnsR, + D.Default J.NullMaker columnsL nullableColumnsL, + D.Default J.NullMaker columnsR nullableColumnsR, + Map.Map J.Nulled columnsL ~ nullableColumnsL, + Map.Map J.Nulled columnsR ~ nullableColumnsR) + => Query columnsL + -- ^ Left query + -> Query columnsR + -- ^ Right query + -> ((columnsL, columnsR) -> Column T.PGBool) + -- ^ Condition on which to join + -> Query (nullableColumnsL, nullableColumnsR) + -- ^ Full outer join +fullJoinInferrable = fullJoin diff --git a/src/Opaleye/Label.hs b/src/Opaleye/Label.hs --- a/src/Opaleye/Label.hs +++ b/src/Opaleye/Label.hs @@ -3,7 +3,8 @@ import Opaleye.QueryArr (Query) import qualified Opaleye.Internal.Label as L import qualified Opaleye.Internal.QueryArr as Q +import qualified Opaleye.Select as S -- | Add a commented label to the generated SQL. -label :: String -> Query a -> Query a +label :: String -> S.Select a -> S.Select a label l a = Q.simpleQueryArr (L.label' l . Q.runSimpleQueryArr a) diff --git a/src/Opaleye/Manipulation.hs b/src/Opaleye/Manipulation.hs --- a/src/Opaleye/Manipulation.hs +++ b/src/Opaleye/Manipulation.hs @@ -1,11 +1,13 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} -- | Inserts, updates and deletes -- -- Please note that Opaleye currently only supports INSERT or UPDATE with --- constant values, not the result of SELECTS. That is, you can +-- constant values, not the result of SELECTs. That is, you can -- generate SQL of the form -- -- @ @@ -22,8 +24,16 @@ module Opaleye.Manipulation (module Opaleye.Manipulation, -- * Other - U.Unpackspec) where + -- | Do not use the export of + -- 'U.Unpackspec'. It will not be + -- exported in version 0.7. + U.Unpackspec, + -- | Currently 'HSql.DoNothing' is the + -- only conflict action supported by + -- Opaleye. + HSql.OnConflict(..)) where +import qualified Opaleye.Field as F import qualified Opaleye.Internal.Sql as Sql import qualified Opaleye.Internal.Print as Print import qualified Opaleye.RunQuery as RQ @@ -31,11 +41,12 @@ import qualified Opaleye.Table as T import qualified Opaleye.Internal.Table as TI import Opaleye.Internal.Column (Column(Column)) -import Opaleye.Internal.Helpers ((.:), (.:.), (.::), (.::.)) +import Opaleye.Internal.Helpers ((.:), (.:.), (.::.)) import Opaleye.Internal.Manipulation (Updater(Updater)) +import qualified Opaleye.Internal.Manipulation as MI import qualified Opaleye.Internal.PrimQuery as PQ import qualified Opaleye.Internal.Unpackspec as U -import Opaleye.PGTypes (PGBool) +import Opaleye.SqlTypes (SqlBool) import qualified Opaleye.Internal.HaskellDB.Sql as HSql import qualified Opaleye.Internal.HaskellDB.Sql.Print as HPrint @@ -50,179 +61,138 @@ import Data.String (fromString) import qualified Data.List.NonEmpty as NEL --- * Manipulation functions +-- * Run a manipulation --- | Insert rows into a table -runInsertMany :: PGS.Connection - -- ^ - -> T.Table columns columns' - -- ^ Table to insert into - -> [columns] - -- ^ Rows to insert - -> IO Int64 - -- ^ Number of rows inserted -runInsertMany conn table columns = case NEL.nonEmpty columns of - -- Inserting the empty list is just the same as returning 0 - Nothing -> return 0 - Just columns' -> (PGS.execute_ conn . fromString .: arrangeInsertManySql) table columns' +-- | Run the 'Insert'. To create an 'Insert' use the 'Insert' +-- constructor. +runInsert_ :: PGS.Connection + -- ^ + -> Insert haskells + -- ^ + -> IO haskells + -- ^ Returns a type that depends on the 'MI.Returning' that + -- you provided when creating the 'Insert'. +runInsert_ conn i = case i of + Insert table_ rows_ returning_ onConflict_ -> + let insert = case (returning_, onConflict_) of + (MI.Count, Nothing) -> + runInsertMany + (MI.Count, Just HSql.DoNothing) -> + runInsertManyOnConflictDoNothing + (MI.Returning f, oc) -> + \c t r -> MI.runInsertManyReturningExplicit D.def c t r f oc + (MI.ReturningExplicit qr f, oc) -> + \c t r -> MI.runInsertManyReturningExplicit qr c t r f oc + in insert conn table_ rows_ --- | Insert rows into a table and return a function of the inserted rows --- --- @runInsertManyReturning@'s use of the 'D.Default' typeclass means that the --- compiler will have trouble inferring types. It is strongly --- recommended that you provide full type signatures when using --- @runInsertManyReturning@. -runInsertManyReturning :: (D.Default RQ.QueryRunner columnsReturned haskells) - => PGS.Connection - -- ^ - -> T.Table columnsW columnsR - -- ^ Table to insert into - -> [columnsW] - -- ^ Rows to insert - -> (columnsR -> columnsReturned) - -- ^ Function @f@ to apply to the inserted rows - -> IO [haskells] - -- ^ Returned rows after @f@ has been applied -runInsertManyReturning = runInsertManyReturningExplicit D.def +-- | Run the 'Update'. To create an 'Update' use the 'Update' +-- constructor. +runUpdate_ :: PGS.Connection + -- ^ + -> Update haskells + -- ^ + -> IO haskells + -- ^ Returns a type that depends on the 'MI.Returning' that + -- you provided when creating the 'Update'. +runUpdate_ conn i = case i of + Update table_ updateWith_ where_ returning_ -> + let update = case returning_ of + MI.Count -> + runUpdate + MI.Returning f -> + \c t u w -> runUpdateReturning c t u w f + MI.ReturningExplicit qr f -> + \c t u w -> runUpdateReturningExplicit qr c t u w f + in update conn table_ updateWith_ where_ --- | 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 +-- | Run the 'Delete'. To create an 'Delete' use the 'Delete' +-- constructor. +runDelete_ :: PGS.Connection + -- ^ + -> Delete Int64 + -- ^ You must pass 'rCount' here. 'runDelete_' does not + -- yet support @DELETE RETURNING@. If you want it please + -- file an issue. + -> IO Int64 + -- ^ Returns a type that depends on the 'MI.Returning' that + -- you provided when creating the 'Update'. +runDelete_ conn i = case i of + Delete table_ where_ returning_ -> + let delete = case returning_ of + MI.Count -> + runDelete + in delete conn table_ where_ --- | 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 --- be left unchanged. -runUpdate :: PGS.Connection - -> T.Table columnsW columnsR - -- ^ Table to update - -> (columnsR -> columnsW) - -- ^ 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 -runUpdate conn = PGS.execute_ conn . fromString .:. arrangeUpdateSql +-- * Create a manipulation +data Insert haskells = forall fieldsW fieldsR. Insert + { iTable :: T.Table fieldsW fieldsR + , iRows :: [fieldsW] + , iReturning :: MI.Returning fieldsR haskells + , iOnConflict :: Maybe HSql.OnConflict + -- ^ NB There is a clash of terminology between Haskell and + -- Postgres. + -- + -- * 'iOnConflict' @=@ 'Nothing' means omit @ON CONFLICT@ statement + -- + -- * 'iOnConflict' @=@ 'Just' 'HSql.DoNothing' means @ON CONFLICT DO + -- NOTHING@ + } --- | Update rows in a table and return a function of the updated rows --- --- 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 --- be left unchanged. +data Update haskells = forall fieldsW fieldsR. Update + { uTable :: T.Table fieldsW fieldsR + , uUpdateWith :: fieldsR -> fieldsW + -- ^ Be careful: providing 'Nothing' to a column created by + -- 'Opaleye.Table.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 be left unchanged. For an + -- easier time wrap your update function in 'updateEasy'. + , uWhere :: fieldsR -> F.Field SqlBool + , uReturning :: MI.Returning fieldsR haskells + } + +-- | A convenient wrapper for writing your update function -- --- @runUpdateReturning@'s use of the 'D.Default' typeclass means --- 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) - => PGS.Connection - -- ^ - -> T.Table columnsW columnsR - -- ^ Table to update - -> (columnsR -> columnsW) - -- ^ 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@. - -> (columnsR -> columnsReturned) - -- ^ Functon @g@ to apply to the updated rows - -> IO [haskells] - -- ^ Returned rows after @g@ has been applied -runUpdateReturning = runUpdateReturningExplicit D.def +-- @uUpdateWith = updateEasy (\\... -> ...)@ +updateEasy :: D.Default Updater fieldsR fieldsW + => (fieldsR -> fieldsR) + -- ^ + -> (fieldsR -> fieldsW) +updateEasy u = u' . u + where Updater u' = D.def --- | Delete rows from a table -runDelete :: PGS.Connection - -- ^ - -> T.Table a columnsR - -- ^ Table to delete rows from - -> (columnsR -> Column PGBool) - -- ^ Predicate function @f@ to choose which rows to delete. - -- 'runDelete' will delete rows for which @f@ returns @TRUE@ - -- and leave unchanged rows for which @f@ returns @FALSE@. - -> IO Int64 - -- ^ The number of rows deleted -runDelete conn = PGS.execute_ conn . fromString .: arrangeDeleteSql +data Delete haskells = forall fieldsW fieldsR. Delete + { dTable :: T.Table fieldsW fieldsR + , dWhere :: fieldsR -> F.Field SqlBool + , dReturning :: MI.Returning fieldsR Int64 + } --- * Explicit versions +-- ** Returning --- | You probably don't need this, but can just use --- 'runInsertReturning' instead. You only need it if you want to run --- an INSERT RETURNING statement but need to be explicit about the --- 'QueryRunner'. -runInsertReturningExplicit :: RQ.QueryRunner columnsReturned haskells - -> PGS.Connection - -> T.Table columnsW columnsR - -> columnsW - -> (columnsR -> columnsReturned) - -> IO [haskells] -runInsertReturningExplicit qr conn t = - runInsertManyReturningExplicit qr conn t . return +-- | Return the number of rows inserted or updated +rCount :: MI.Returning fieldsR Int64 +rCount = MI.Count --- | You probably don't need this, but can just use --- 'runInsertManyReturning' instead. You only need it if you want to --- run an UPDATE RETURNING statement but need to be explicit about the --- 'QueryRunner'. -runInsertManyReturningExplicit :: RQ.QueryRunner columnsReturned haskells - -> PGS.Connection - -> T.Table columnsW columnsR - -> [columnsW] - -> (columnsR -> columnsReturned) - -> IO [haskells] -runInsertManyReturningExplicit qr conn t columns r = - case NEL.nonEmpty columns of - Nothing -> return [] - Just columns' -> PGS.queryWith_ parser conn - (fromString - (arrangeInsertManyReturningSql u t columns' r)) - where IRQ.QueryRunner u _ _ = qr - parser = IRQ.prepareRowParser qr (r v) - 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. +-- | Return a function of the inserted or updated rows +-- +-- 'rReturning''s use of the 'D.Default' typeclass means that the +-- compiler will have trouble inferring types. It is strongly +-- recommended that you provide full type signatures when using +-- 'rReturning'. +rReturning :: D.Default RQ.QueryRunner fields haskells + => (fieldsR -> fields) + -- ^ + -> MI.Returning fieldsR [haskells] +rReturning = MI.Returning --- | You probably don't need this, but can just use --- '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 - -> PGS.Connection - -> T.Table columnsW columnsR - -> (columnsR -> columnsW) - -> (columnsR -> Column PGBool) - -> (columnsR -> columnsReturned) - -> IO [haskells] -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) - TI.View v = TI.tableColumnsView (TI.tableColumns t) +-- | Return a function of the inserted or updated rows. Explicit +-- version. You probably just want to use 'rReturning' instead. +rReturningExplicit :: RQ.QueryRunner fields haskells + -- ^ + -> (fieldsR -> fields) + -- ^ + -> MI.Returning fieldsR [haskells] +rReturningExplicit = MI.ReturningExplicit -- * Deprecated versions @@ -231,7 +201,7 @@ {-# DEPRECATED runInsert "'runInsert' will be removed in version 0.7. \ \Use 'runInsertMany' instead." #-} -runInsert :: PGS.Connection -> T.Table columns columns' -> columns -> IO Int64 +runInsert :: PGS.Connection -> T.Table fields fields' -> fields -> IO Int64 runInsert conn = PGS.execute_ conn . fromString .: arrangeInsertSql -- | @runInsertReturning@'s use of the 'D.Default' typeclass means that the @@ -242,11 +212,11 @@ {-# DEPRECATED runInsertReturning "'runInsertReturning' will be removed in version 0.7. \ \Use 'runInsertManyReturning' instead." #-} -runInsertReturning :: (D.Default RQ.QueryRunner columnsReturned haskells) +runInsertReturning :: (D.Default RQ.QueryRunner fieldsReturned haskells) => PGS.Connection - -> T.Table columnsW columnsR - -> columnsW - -> (columnsR -> columnsReturned) + -> T.Table fieldsW fieldsR + -> fieldsW + -> (fieldsR -> fieldsReturned) -> IO [haskells] runInsertReturning = runInsertReturningExplicit D.def @@ -266,30 +236,25 @@ "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.tableColumnsWriter (TI.tableColumns table) - (columnExprs, columnNames) = TI.runWriter' writer columns - insert = SG.sqlInsert SD.defaultSqlGenerator - (PQ.tiToSqlTable (TI.tableIdentifier table)) - columnNames columnExprs +arrangeInsertMany t columns = MI.arrangeInsertMany t columns Nothing {-# 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 +arrangeInsertManySql t c = MI.arrangeInsertManySql t c Nothing {-# DEPRECATED arrangeUpdate "You probably want 'runUpdate' instead. \ \Will be removed in version 0.7." #-} arrangeUpdate :: T.Table columnsW columnsR - -> (columnsR -> columnsW) -> (columnsR -> Column PGBool) + -> (columnsR -> columnsW) -> (columnsR -> Column SqlBool) -> HSql.SqlUpdate -arrangeUpdate table update cond = +arrangeUpdate t update cond = SG.sqlUpdate SD.defaultSqlGenerator - (PQ.tiToSqlTable (TI.tableIdentifier table)) + (PQ.tiToSqlTable (TI.tableIdentifier t)) [condExpr] (update' tableCols) - where TI.TableProperties writer (TI.View tableCols) = TI.tableColumns table + where TI.TableProperties writer (TI.View tableCols) = TI.tableColumns t update' = map (\(x, y) -> (y, x)) . TI.runWriter writer . update Column condExpr = cond tableCols @@ -297,23 +262,23 @@ "You probably want 'runUpdate' instead. \ \Will be removed in version 0.7." #-} arrangeUpdateSql :: T.Table columnsW columnsR - -> (columnsR -> columnsW) -> (columnsR -> Column PGBool) + -> (columnsR -> columnsW) -> (columnsR -> Column SqlBool) -> String arrangeUpdateSql = show . HPrint.ppUpdate .:. arrangeUpdate {-# 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] +arrangeDelete :: T.Table a columnsR -> (columnsR -> Column SqlBool) -> HSql.SqlDelete +arrangeDelete t cond = + SG.sqlDelete SD.defaultSqlGenerator (PQ.tiToSqlTable (TI.tableIdentifier t)) [condExpr] where Column condExpr = cond tableCols - TI.View tableCols = TI.tableColumnsView (TI.tableColumns table) + TI.View tableCols = TI.tableColumnsView (TI.tableColumns t) {-# DEPRECATED arrangeDeleteSql "You probably want 'runDelete' instead. \ \Will be removed in version 0.7." #-} -arrangeDeleteSql :: T.Table a columnsR -> (columnsR -> Column PGBool) -> String +arrangeDeleteSql :: T.Table a columnsR -> (columnsR -> Column SqlBool) -> String arrangeDeleteSql = show . HPrint.ppDelete .: arrangeDelete {-# DEPRECATED arrangeInsertManyReturning @@ -324,12 +289,8 @@ -> NEL.NonEmpty columnsW -> (columnsR -> columnsReturned) -> Sql.Returning HSql.SqlInsert -arrangeInsertManyReturning unpackspec table columns returningf = - Sql.Returning insert returningSEs - where insert = arrangeInsertMany table columns - TI.View columnsR = TI.tableColumnsView (TI.tableColumns table) - returningPEs = U.collectPEs unpackspec (returningf columnsR) - returningSEs = Sql.ensureColumnsGen id (map Sql.sqlExpr returningPEs) +arrangeInsertManyReturning unpackspec t columns returningf = + MI.arrangeInsertManyReturning unpackspec t columns returningf Nothing {-# DEPRECATED arrangeInsertManyReturningSql "You probably want 'runInsertManyReturning' instead. \ @@ -339,8 +300,8 @@ -> NEL.NonEmpty columnsW -> (columnsR -> columnsReturned) -> String -arrangeInsertManyReturningSql = - show . Print.ppInsertReturning .:: arrangeInsertManyReturning +arrangeInsertManyReturningSql u t c r = + MI.arrangeInsertManyReturningSql u t c r Nothing {-# DEPRECATED arrangeUpdateReturning "You probably want 'runUpdateReturning' instead. \ @@ -348,13 +309,13 @@ arrangeUpdateReturning :: U.Unpackspec columnsReturned ignored -> T.Table columnsW columnsR -> (columnsR -> columnsW) - -> (columnsR -> Column PGBool) + -> (columnsR -> Column SqlBool) -> (columnsR -> columnsReturned) -> Sql.Returning HSql.SqlUpdate -arrangeUpdateReturning unpackspec table updatef cond returningf = +arrangeUpdateReturning unpackspec t updatef cond returningf = Sql.Returning update returningSEs - where update = arrangeUpdate table updatef cond - TI.View columnsR = TI.tableColumnsView (TI.tableColumns table) + where update = arrangeUpdate t updatef cond + TI.View columnsR = TI.tableColumnsView (TI.tableColumns t) returningPEs = U.collectPEs unpackspec (returningf columnsR) returningSEs = Sql.ensureColumnsGen id (map Sql.sqlExpr returningPEs) @@ -364,8 +325,184 @@ arrangeUpdateReturningSql :: U.Unpackspec columnsReturned ignored -> T.Table columnsW columnsR -> (columnsR -> columnsW) - -> (columnsR -> Column PGBool) + -> (columnsR -> Column SqlBool) -> (columnsR -> columnsReturned) -> String arrangeUpdateReturningSql = show . Print.ppUpdateReturning .::. arrangeUpdateReturning + +-- | Insert rows into a table with @ON CONFLICT DO NOTHING@ +{-# DEPRECATED runInsertManyOnConflictDoNothing "Use runInsert_" #-} +runInsertManyOnConflictDoNothing :: PGS.Connection + -- ^ + -> T.Table columns columns' + -- ^ Table to insert into + -> [columns] + -- ^ Rows to insert + -> IO Int64 + -- ^ Number of rows inserted +runInsertManyOnConflictDoNothing conn table_ columns = + case NEL.nonEmpty columns of + -- Inserting the empty list is just the same as returning 0 + Nothing -> return 0 + Just columns' -> (PGS.execute_ conn . fromString .:. MI.arrangeInsertManySql) + table_ columns' (Just HSql.DoNothing) + +-- | Insert rows into a table with @ON CONFLICT DO NOTHING@ and +-- return a function of the inserted rows +-- +-- @runInsertManyReturningOnConflictDoNothing@'s use of the +-- 'D.Default' typeclass means that the compiler will have trouble +-- inferring types. It is strongly recommended that you provide full +-- type signatures when using it. +{-# DEPRECATED runInsertManyReturningOnConflictDoNothing "Use runInsert_" #-} +runInsertManyReturningOnConflictDoNothing + :: (D.Default RQ.QueryRunner columnsReturned haskells) + => PGS.Connection + -- ^ + -> T.Table columnsW columnsR + -- ^ Table to insert into + -> [columnsW] + -- ^ Rows to insert + -> (columnsR -> columnsReturned) + -- ^ Function @f@ to apply to the inserted rows + -> IO [haskells] + -- ^ Returned rows after @f@ has been applied +runInsertManyReturningOnConflictDoNothing = + runInsertManyReturningOnConflictDoNothingExplicit D.def + +-- | Use 'runInsert_' instead. Will be deprecated in version 0.7. +runInsertMany :: PGS.Connection + -- ^ + -> T.Table columns columns' + -- ^ Table to insert into + -> [columns] + -- ^ Rows to insert + -> IO Int64 + -- ^ Number of rows inserted +runInsertMany conn t columns = case NEL.nonEmpty columns of + -- Inserting the empty list is just the same as returning 0 + Nothing -> return 0 + Just columns' -> (PGS.execute_ conn . fromString .: arrangeInsertManySql) t columns' + +-- | Use 'runInsert_' instead. Will be deprecated in version 0.7. +runInsertManyReturning :: (D.Default RQ.QueryRunner columnsReturned haskells) + => PGS.Connection + -- ^ + -> T.Table columnsW columnsR + -- ^ Table to insert into + -> [columnsW] + -- ^ Rows to insert + -> (columnsR -> columnsReturned) + -- ^ Function @f@ to apply to the inserted rows + -> IO [haskells] + -- ^ Returned rows after @f@ has been applied +runInsertManyReturning = runInsertManyReturningExplicit D.def + +-- | Use 'runInsert_' instead. Will be deprecated in version 0.7. +runInsertReturningExplicit :: RQ.QueryRunner columnsReturned haskells + -> PGS.Connection + -> T.Table columnsW columnsR + -> columnsW + -> (columnsR -> columnsReturned) + -> IO [haskells] +runInsertReturningExplicit qr conn t = + runInsertManyReturningExplicit qr conn t . return + +-- | Use 'runInsert_' instead. Will be deprecated in version 0.7. +runInsertManyReturningExplicit :: RQ.QueryRunner columnsReturned haskells + -> PGS.Connection + -> T.Table columnsW columnsR + -> [columnsW] + -> (columnsR -> columnsReturned) + -> IO [haskells] +runInsertManyReturningExplicit qr conn t columns f = + MI.runInsertManyReturningExplicit qr conn t columns f Nothing + +-- | Use 'runInsert_' instead. Will be deprecated in version 0.7. +runInsertManyReturningOnConflictDoNothingExplicit + :: RQ.QueryRunner columnsReturned haskells + -> PGS.Connection + -> T.Table columnsW columnsR + -> [columnsW] + -> (columnsR -> columnsReturned) + -> IO [haskells] +runInsertManyReturningOnConflictDoNothingExplicit qr conn t columns f = + MI.runInsertManyReturningExplicit qr conn t columns f (Just HSql.DoNothing) + +-- | Use 'runUpdate_' instead. Will be deprecated in version 0.7. +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 SqlBool) + -- ^ 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 + +-- | Use 'runUpdate_' instead. Will be deprecated in version 0.7. +runUpdate :: PGS.Connection + -> T.Table columnsW columnsR + -- ^ Table to update + -> (columnsR -> columnsW) + -- ^ Update function to apply to chosen rows + -> (columnsR -> Column SqlBool) + -- ^ 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 +runUpdate conn = PGS.execute_ conn . fromString .:. arrangeUpdateSql + +-- | Use 'runUpdate_' instead. Will be deprecated in version 0.7. +runUpdateReturning :: (D.Default RQ.QueryRunner columnsReturned haskells) + => PGS.Connection + -- ^ + -> T.Table columnsW columnsR + -- ^ Table to update + -> (columnsR -> columnsW) + -- ^ Update function to apply to chosen rows + -> (columnsR -> Column SqlBool) + -- ^ 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@. + -> (columnsR -> columnsReturned) + -- ^ Functon @g@ to apply to the updated rows + -> IO [haskells] + -- ^ Returned rows after @g@ has been applied +runUpdateReturning = runUpdateReturningExplicit D.def + +-- | Use 'runUpdate_' instead. Will be deprecated in version 0.7. +runUpdateReturningExplicit :: RQ.QueryRunner columnsReturned haskells + -> PGS.Connection + -> T.Table columnsW columnsR + -> (columnsR -> columnsW) + -> (columnsR -> Column SqlBool) + -> (columnsR -> columnsReturned) + -> IO [haskells] +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) + TI.View v = TI.tableColumnsView (TI.tableColumns t) + +-- | Use 'runDelete_' instead. Will be deprecated in 0.7. +runDelete :: PGS.Connection + -- ^ + -> T.Table a columnsR + -- ^ Table to delete rows from + -> (columnsR -> Column SqlBool) + -- ^ Predicate function @f@ to choose which rows to delete. + -- 'runDelete' will delete rows for which @f@ returns @TRUE@ + -- and leave unchanged rows for which @f@ returns @FALSE@. + -> IO Int64 + -- ^ The number of rows deleted +runDelete conn = PGS.execute_ conn . fromString .: arrangeDeleteSql diff --git a/src/Opaleye/Map.hs b/src/Opaleye/Map.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Map.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE TypeFamilies #-} + +module Opaleye.Map where + +type family Map f x + +type instance Map f (a1, a2) + = (Map f a1, Map f a2) +type instance Map f (a1, a2, a3) + = (Map f a1, Map f a2, Map f a3) +type instance Map f (a1, a2, a3, a4) + = (Map f a1, Map f a2, Map f a3, Map f a4) +type instance Map f (a1, a2, a3, a4, a5) + = (Map f a1, Map f a2, Map f a3, Map f a4, Map f a5) +type instance Map f (a1, a2, a3, a4, a5, a6) + = (Map f a1, Map f a2, Map f a3, Map f a4, Map f a5, Map f a6) +type instance Map f (a1, a2, a3, a4, a5, a6, a7) + = (Map f a1, Map f a2, Map f a3, Map f a4, Map f a5, Map f a6, + Map f a7) +type instance Map f (a1, a2, a3, a4, a5, a6, a7, a8) + = (Map f a1, Map f a2, Map f a3, Map f a4, Map f a5, Map f a6, + Map f a7, Map f a8) diff --git a/src/Opaleye/Operators.hs b/src/Opaleye/Operators.hs --- a/src/Opaleye/Operators.hs +++ b/src/Opaleye/Operators.hs @@ -1,5 +1,7 @@ {-# LANGUAGE Arrows #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeSynonymInstances #-} -- | Operators on 'Column's. Please note that numeric 'Column' types -- are instances of 'Num', so you can use '*', '/', '+', '-' on them. @@ -10,6 +12,7 @@ import qualified Data.Foldable as F import qualified Data.List.NonEmpty as NEL +import qualified Opaleye.Field as F import Opaleye.Internal.Column (Column(Column), unsafeCase_, unsafeIfThenElse, unsafeGt) import qualified Opaleye.Internal.Column as C @@ -18,7 +21,8 @@ import qualified Opaleye.Internal.Operators as O import Opaleye.Internal.Helpers ((.:)) import qualified Opaleye.Order as Ord -import qualified Opaleye.PGTypes as T +import qualified Opaleye.Select as S +import qualified Opaleye.SqlTypes as T import qualified Opaleye.Column as Column import qualified Opaleye.Distinct as Distinct @@ -28,6 +32,9 @@ import qualified Data.Profunctor.Product.Default as D +-- ^ We can probably disable ConstraintKinds and TypeSynonymInstances +-- when we move to Sql... instead of PG.. + -- * Restriction operators {-| Keep only the rows of a query satisfying a given condition, using @@ -40,18 +47,18 @@ (If you are familiar with 'Control.Monad.MonadPlus' or 'Control.Applicative.Alternative' it may help you to know that 'restrict' corresponds to the 'Control.Monad.guard' function.) -} -restrict :: QueryArr (Column T.PGBool) () +restrict :: S.SelectArr (F.Field T.SqlBool) () restrict = QueryArr f where f (Column predicate, primQ, t0) = ((), PQ.restrict predicate primQ, t0) {-| Add a @WHERE EXISTS@ clause to the current query. -} -restrictExists :: QueryArr a b -> QueryArr a () +restrictExists :: S.SelectArr a b -> S.SelectArr 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 NOT EXISTS@ clause to the current query. -} -restrictNotExists :: QueryArr a b -> QueryArr a () +restrictNotExists :: S.SelectArr a b -> S.SelectArr a () restrictNotExists criteria = QueryArr f where f (a, primQ, t0) = ((), PQ.notExists primQ existsQ, t1) where (_, existsQ, t1) = runSimpleQueryArr criteria (a, t0) @@ -63,10 +70,10 @@ your query using a "point free" style. If you want to use 'A.Arrow' notation then 'restrict' will suit you better. -This is the 'QueryArr' equivalent of 'Prelude.filter' from the +This is the 'S.SelectArr' equivalent of 'Prelude.filter' from the 'Prelude'. -} -keepWhen :: (a -> Column T.PGBool) -> QueryArr a a +keepWhen :: (a -> F.Field T.SqlBool) -> S.SelectArr a a keepWhen p = proc a -> do restrict -< p a A.returnA -< a @@ -74,76 +81,76 @@ -- * Equality operators infix 4 .== -(.==) :: Column a -> Column a -> Column T.PGBool +(.==) :: Column a -> Column a -> F.Field T.SqlBool (.==) = C.binOp (HPQ.:==) infix 4 ./= -(./=) :: Column a -> Column a -> Column T.PGBool +(./=) :: Column a -> Column a -> F.Field T.SqlBool (./=) = C.binOp (HPQ.:<>) infix 4 .=== -- | A polymorphic equality operator that works for all types that you -- have run `makeAdaptorAndInstance` on. This may be unified with -- `.==` in a future version. -(.===) :: D.Default O.EqPP columns columns => columns -> columns -> Column T.PGBool +(.===) :: D.Default O.EqPP fields fields => fields -> fields -> F.Field T.SqlBool (.===) = (O..==) infix 4 ./== -- | A polymorphic inequality operator that works for all types that -- you have run `makeAdaptorAndInstance` on. This may be unified with -- `./=` in a future version. -(./==) :: D.Default O.EqPP columns columns => columns -> columns -> Column T.PGBool +(./==) :: D.Default O.EqPP fields fields => fields -> fields -> F.Field T.SqlBool (./==) = Opaleye.Operators.not .: (O..==) -- * Comparison operators infix 4 .> -(.>) :: Ord.PGOrd a => Column a -> Column a -> Column T.PGBool +(.>) :: Ord.SqlOrd a => Column a -> Column a -> F.Field T.SqlBool (.>) = unsafeGt infix 4 .< -(.<) :: Ord.PGOrd a => Column a -> Column a -> Column T.PGBool +(.<) :: Ord.SqlOrd a => Column a -> Column a -> F.Field T.SqlBool (.<) = C.binOp (HPQ.:<) infix 4 .<= -(.<=) :: Ord.PGOrd a => Column a -> Column a -> Column T.PGBool +(.<=) :: Ord.SqlOrd a => Column a -> Column a -> F.Field T.SqlBool (.<=) = C.binOp (HPQ.:<=) infix 4 .>= -(.>=) :: Ord.PGOrd a => Column a -> Column a -> Column T.PGBool +(.>=) :: Ord.SqlOrd a => Column a -> Column a -> F.Field T.SqlBool (.>=) = C.binOp (HPQ.:>=) -- * Numerical operators -- | Integral division, named after 'Prelude.quot'. It maps to the -- @/@ operator in Postgres. -quot_ :: C.PGIntegral a => Column a -> Column a -> Column a +quot_ :: C.SqlIntegral a => Column a -> Column a -> Column a quot_ = C.binOp (HPQ.:/) -- | The remainder of integral division, named after 'Prelude.rem'. -- It maps to 'MOD' ('%') in Postgres, confusingly described as -- "modulo (remainder)". -rem_ :: C.PGIntegral a => Column a -> Column a -> Column a +rem_ :: C.SqlIntegral a => Column a -> Column a -> Column a rem_ = C.binOp HPQ.OpMod -- * Conditional operators -- | Select the first case for which the condition is true. -case_ :: [(Column T.PGBool, Column a)] -> Column a -> Column a +case_ :: [(F.Field T.SqlBool, Column a)] -> Column a -> Column a case_ = unsafeCase_ -- | Monomorphic if\/then\/else. -- -- This may be replaced by 'ifThenElseMany' in a future version. -ifThenElse :: Column T.PGBool -> Column a -> Column a -> Column a +ifThenElse :: F.Field T.SqlBool -> Column a -> Column a -> Column a ifThenElse = unsafeIfThenElse -- | Polymorphic if\/then\/else. -ifThenElseMany :: D.Default O.IfPP columns columns - => Column T.PGBool - -> columns - -> columns - -> columns +ifThenElseMany :: D.Default O.IfPP fields fields + => F.Field T.SqlBool + -> fields + -> fields + -> fields ifThenElseMany = O.ifExplict D.def -- * Logical operators @@ -151,43 +158,43 @@ infixr 2 .|| -- | Boolean or -(.||) :: Column T.PGBool -> Column T.PGBool -> Column T.PGBool +(.||) :: F.Field T.SqlBool -> F.Field T.SqlBool -> F.Field T.SqlBool (.||) = C.binOp HPQ.OpOr infixr 3 .&& -- | Boolean and -(.&&) :: Column T.PGBool -> Column T.PGBool -> Column T.PGBool +(.&&) :: F.Field T.SqlBool -> F.Field T.SqlBool -> F.Field T.SqlBool (.&&) = (O..&&) -- | Boolean not -not :: Column T.PGBool -> Column T.PGBool +not :: F.Field T.SqlBool -> F.Field T.SqlBool not = C.unOp HPQ.OpNot -- | True when any element of the container is true -ors :: F.Foldable f => f (Column T.PGBool) -> Column T.PGBool -ors = F.foldl' (.||) (T.pgBool False) +ors :: F.Foldable f => f (F.Field T.SqlBool) -> F.Field T.SqlBool +ors = F.foldl' (.||) (T.sqlBool False) -- * Text operators --- | Concatenate 'Column' 'T.PGText' -(.++) :: Column T.PGText -> Column T.PGText -> Column T.PGText +-- | Concatenate 'F.Field' 'T.SqlText' +(.++) :: F.Field T.SqlText -> F.Field T.SqlText -> F.Field T.SqlText (.++) = C.binOp (HPQ.:||) -- | To lowercase -lower :: Column T.PGText -> Column T.PGText +lower :: F.Field T.SqlText -> F.Field T.SqlText lower = C.unOp HPQ.OpLower -- | To uppercase -upper :: Column T.PGText -> Column T.PGText +upper :: F.Field T.SqlText -> F.Field T.SqlText upper = C.unOp HPQ.OpUpper -- | Postgres @LIKE@ operator -like :: Column T.PGText -> Column T.PGText -> Column T.PGBool +like :: F.Field T.SqlText -> F.Field T.SqlText -> F.Field T.SqlBool like = C.binOp HPQ.OpLike -- | Postgres @ILIKE@ operator -ilike :: Column T.PGText -> Column T.PGText -> Column T.PGBool +ilike :: F.Field T.SqlText -> F.Field T.SqlText -> F.Field T.SqlBool ilike = C.binOp HPQ.OpILike charLength :: C.PGString a => Column a -> Column Int @@ -200,7 +207,7 @@ -- 'in_' @validProducts@ @product@ checks whether @product@ is a valid -- product. 'in_' @validProducts@ is a function which checks whether -- a product is a valid product. -in_ :: (Functor f, F.Foldable f) => f (Column a) -> Column a -> Column T.PGBool +in_ :: (Functor f, F.Foldable f) => f (Column a) -> Column a -> F.Field T.SqlBool in_ fcas (Column a) = Column $ case NEL.nonEmpty (F.toList fcas) of Nothing -> HPQ.ConstExpr (HPQ.BoolLit False) Just xs -> HPQ.BinExpr HPQ.OpIn a (HPQ.ListExpr (fmap C.unColumn xs)) @@ -211,8 +218,8 @@ -- This operation is equivalent to Postgres's @IN@ operator but, for -- expediency, is currently implemented using a @LEFT JOIN@. Please -- file a bug if this causes any issues in practice. -inQuery :: D.Default O.EqPP columns columns - => columns -> Query columns -> Query (Column T.PGBool) +inQuery :: D.Default O.EqPP fields fields + => fields -> Query fields -> S.Select (F.Field T.SqlBool) inQuery c q = qj' where -- Remove every row that isn't equal to c -- Replace the ones that are with '1' @@ -223,13 +230,13 @@ -- Left join with a query that has a single row -- We either get a single row with '1' -- or a single row with 'NULL' - qj :: Query (Column T.PGInt4, Column (C.Nullable T.PGInt4)) + qj :: Query (F.Field T.SqlInt4, Column (C.Nullable T.SqlInt4)) qj = Join.leftJoin (A.arr (const 1)) (Distinct.distinct q') (uncurry (.==)) -- Check whether it is 'NULL' - qj' :: Query (Column T.PGBool) + qj' :: Query (F.Field T.SqlBool) qj' = A.arr (Opaleye.Operators.not . Column.isNull . snd) @@ -238,124 +245,135 @@ -- * JSON operators -- | Class of Postgres types that represent json values. --- Used to overload functions and operators that work on both 'T.PGJson' and 'T.PGJsonb'. +-- Used to overload functions and operators that work on both 'T.SqlJson' and 'T.SqlJsonb'. -- -- Warning: making additional instances of this class can lead to broken code! class PGIsJson a -instance PGIsJson T.PGJson -instance PGIsJson T.PGJsonb +type SqlIsJson = PGIsJson +instance PGIsJson T.SqlJson +instance PGIsJson T.SqlJsonb + -- | Class of Postgres types that can be used to index json values. -- -- Warning: making additional instances of this class can lead to broken code! class PGJsonIndex a -instance PGJsonIndex T.PGInt4 -instance PGJsonIndex T.PGInt8 -instance PGJsonIndex T.PGText +type SqlJsonIndex = PGJsonIndex +instance PGJsonIndex T.SqlInt4 +instance PGJsonIndex T.SqlInt8 +instance PGJsonIndex T.SqlText + -- | Get JSON object field by key. infixl 8 .-> -(.->) :: (PGIsJson a, PGJsonIndex k) - => Column (C.Nullable a) -- ^ - -> Column k -- ^ key or index - -> Column (C.Nullable a) +(.->) :: (SqlIsJson a, SqlJsonIndex k) + => F.FieldNullable a -- ^ + -> F.Field k -- ^ key or index + -> F.FieldNullable a (.->) = C.binOp (HPQ.:->) -- | Get JSON object field as text. infixl 8 .->> -(.->>) :: (PGIsJson a, PGJsonIndex k) - => Column (C.Nullable a) -- ^ - -> Column k -- ^ key or index - -> Column (C.Nullable T.PGText) +(.->>) :: (SqlIsJson a, SqlJsonIndex k) + => F.FieldNullable a -- ^ + -> F.Field k -- ^ key or index + -> F.FieldNullable T.SqlText (.->>) = C.binOp (HPQ.:->>) -- | Get JSON object at specified path. infixl 8 .#> -(.#>) :: (PGIsJson a) - => Column (C.Nullable a) -- ^ - -> Column (T.PGArray T.PGText) -- ^ path - -> Column (C.Nullable a) +(.#>) :: (SqlIsJson a) + => F.FieldNullable a -- ^ + -> Column (T.SqlArray T.SqlText) -- ^ path + -> F.FieldNullable a (.#>) = C.binOp (HPQ.:#>) -- | Get JSON object at specified path as text. infixl 8 .#>> -(.#>>) :: (PGIsJson a) - => Column (C.Nullable a) -- ^ - -> Column (T.PGArray T.PGText) -- ^ path - -> Column (C.Nullable T.PGText) +(.#>>) :: (SqlIsJson a) + => F.FieldNullable a -- ^ + -> Column (T.SqlArray T.SqlText) -- ^ path + -> F.FieldNullable T.SqlText (.#>>) = C.binOp (HPQ.:#>>) -- | Does the left JSON value contain within it the right value? infix 4 .@> -(.@>) :: Column T.PGJsonb -> Column T.PGJsonb -> Column T.PGBool +(.@>) :: F.Field T.SqlJsonb -> F.Field T.SqlJsonb -> F.Field T.SqlBool (.@>) = C.binOp (HPQ.:@>) -- | Is the left JSON value contained within the right value? infix 4 .<@ -(.<@) :: Column T.PGJsonb -> Column T.PGJsonb -> Column T.PGBool +(.<@) :: F.Field T.SqlJsonb -> F.Field T.SqlJsonb -> F.Field T.SqlBool (.<@) = C.binOp (HPQ.:<@) -- | Does the key/element string exist within the JSON value? infix 4 .? -(.?) :: Column T.PGJsonb -> Column T.PGText -> Column T.PGBool +(.?) :: F.Field T.SqlJsonb -> F.Field T.SqlText -> F.Field T.SqlBool (.?) = C.binOp (HPQ.:?) -- | Do any of these key/element strings exist? infix 4 .?| -(.?|) :: Column T.PGJsonb -> Column (T.PGArray T.PGText) -> Column T.PGBool +(.?|) :: F.Field T.SqlJsonb + -> Column (T.SqlArray T.SqlText) + -> F.Field T.SqlBool (.?|) = C.binOp (HPQ.:?|) -- | Do all of these key/element strings exist? infix 4 .?& -(.?&) :: Column T.PGJsonb -> Column (T.PGArray T.PGText) -> Column T.PGBool +(.?&) :: F.Field T.SqlJsonb + -> Column (T.SqlArray T.SqlText) + -> F.Field T.SqlBool (.?&) = C.binOp (HPQ.:?&) --- * PGArray operators +-- * SqlArray operators -emptyArray :: T.IsSqlType a => Column (T.PGArray a) -emptyArray = T.pgArray id [] +emptyArray :: T.IsSqlType a => Column (T.SqlArray a) +emptyArray = T.sqlArray id [] -arrayPrepend :: Column a -> Column (T.PGArray a) -> Column (T.PGArray a) +arrayPrepend :: Column a -> Column (T.SqlArray a) -> Column (T.SqlArray a) arrayPrepend (Column e) (Column es) = Column (HPQ.FunExpr "array_prepend" [e, es]) -singletonArray :: T.IsSqlType a => Column a -> Column (T.PGArray a) +singletonArray :: T.IsSqlType a => Column a -> Column (T.SqlArray a) singletonArray x = arrayPrepend x emptyArray -index :: (C.PGIntegral n) => Column (T.PGArray a) -> Column n -> Column (C.Nullable a) +index :: (C.SqlIntegral n) => Column (T.SqlArray a) -> Column n -> Column (C.Nullable a) index (Column a) (Column b) = Column (HPQ.ArrayIndex a b) -- * Range operators -overlap :: Column (T.PGRange a) -> Column (T.PGRange a) -> Column T.PGBool +overlap :: Column (T.SqlRange a) -> Column (T.SqlRange a) -> F.Field T.SqlBool overlap = C.binOp (HPQ.:&&) +liesWithin :: T.IsRangeType a => Column a -> Column (T.SqlRange a) -> F.Field T.SqlBool +liesWithin = C.binOp (HPQ.:<@) + infix 4 .<< -(.<<) :: Column (T.PGRange a) -> Column (T.PGRange a) -> Column T.PGBool +(.<<) :: Column (T.SqlRange a) -> Column (T.SqlRange a) -> F.Field T.SqlBool (.<<) = C.binOp (HPQ.:<<) infix 4 .>> -(.>>) :: Column (T.PGRange a) -> Column (T.PGRange a) -> Column T.PGBool +(.>>) :: Column (T.SqlRange a) -> Column (T.SqlRange a) -> F.Field T.SqlBool (.>>) = C.binOp (HPQ.:>>) infix 4 .&< -(.&<) :: Column (T.PGRange a) -> Column (T.PGRange a) -> Column T.PGBool +(.&<) :: Column (T.SqlRange a) -> Column (T.SqlRange a) -> F.Field T.SqlBool (.&<) = C.binOp (HPQ.:&<) infix 4 .&> -(.&>) :: Column (T.PGRange a) -> Column (T.PGRange a) -> Column T.PGBool +(.&>) :: Column (T.SqlRange a) -> Column (T.SqlRange a) -> F.Field T.SqlBool (.&>) = C.binOp (HPQ.:&>) infix 4 .-|- -(.-|-) :: Column (T.PGRange a) -> Column (T.PGRange a) -> Column T.PGBool +(.-|-) :: Column (T.SqlRange a) -> Column (T.SqlRange a) -> F.Field T.SqlBool (.-|-) = C.binOp (HPQ.:-|-) -- * Other operators -timestamptzAtTimeZone :: Column T.PGTimestamptz - -> Column T.PGText - -> Column T.PGTimestamp +timestamptzAtTimeZone :: F.Field T.SqlTimestamptz + -> F.Field T.SqlText + -> F.Field T.SqlTimestamp timestamptzAtTimeZone = C.binOp HPQ.OpAtTimeZone -- * Deprecated @@ -363,7 +381,7 @@ {-# DEPRECATED doubleOfInt "Use 'C.unsafeCast' instead. \ \Will be removed in version 0.7." #-} -doubleOfInt :: Column T.PGInt4 -> Column T.PGFloat8 +doubleOfInt :: F.Field T.SqlInt4 -> F.Field T.SqlFloat8 doubleOfInt (Column e) = Column (HPQ.CastExpr "float8" e) -- | Identical to 'restrictExists'. Will be deprecated in version 0.7. diff --git a/src/Opaleye/Order.hs b/src/Opaleye/Order.hs --- a/src/Opaleye/Order.hs +++ b/src/Opaleye/Order.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeSynonymInstances #-} + -- | Ordering, @LIMIT@ and @OFFSET@ module Opaleye.Order ( -- * Order by @@ -15,55 +18,60 @@ , O.exact -- * Other , PGOrd + , SqlOrd ) where import qualified Opaleye.Column as C import Opaleye.QueryArr (Query) import qualified Opaleye.Internal.QueryArr as Q import qualified Opaleye.Internal.Order as O -import qualified Opaleye.PGTypes as T +import qualified Opaleye.Select as S +import qualified Opaleye.SqlTypes as T import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ -{-| Order the rows of a `Query` according to the `Order`. +-- We can probably disable ConstraintKinds and TypeSynonymInstances +-- when we move to Sql... instead of PG.. +{-| Order the rows of a `S.Select` according to the `O.Order`. + @ import Data.Monoid ((\<\>)) \-- Order by the first column ascending. When first columns are equal \-- order by second column descending. -example :: 'Query' ('C.Column' 'T.PGInt4', 'C.Column' 'T.PGText') - -> 'Query' ('C.Column' 'T.PGInt4', 'C.Column' 'T.PGText') +example :: 'S.Select' ('C.Column' 'T.SqlInt4', 'C.Column' 'T.SqlText') + -> 'S.Select' ('C.Column' 'T.SqlInt4', 'C.Column' 'T.SqlText') example = 'orderBy' ('asc' fst \<\> 'desc' snd) @ -} -orderBy :: O.Order a -> Query a -> Query a +orderBy :: O.Order a -> S.Select a -> S.Select a orderBy os q = Q.simpleQueryArr (O.orderByU os . Q.runSimpleQueryArr q) -- | Specify an ascending ordering by the given expression. -- (Any NULLs appear last) -asc :: PGOrd b => (a -> C.Column b) -> O.Order a +asc :: SqlOrd b => (a -> C.Column b) -> O.Order a asc = O.order HPQ.OrderOp { HPQ.orderDirection = HPQ.OpAsc , HPQ.orderNulls = HPQ.NullsLast } -- | Specify an descending ordering by the given expression. -- (Any NULLs appear first) -desc :: PGOrd b => (a -> C.Column b) -> O.Order a +desc :: SqlOrd b => (a -> C.Column b) -> O.Order a desc = O.order HPQ.OrderOp { HPQ.orderDirection = HPQ.OpDesc , HPQ.orderNulls = HPQ.NullsFirst } -- | Specify an ascending ordering by the given expression. -- (Any NULLs appear first) -ascNullsFirst :: PGOrd b => (a -> C.Column b) -> O.Order a +ascNullsFirst :: SqlOrd b => (a -> C.Column b) -> O.Order a ascNullsFirst = O.order HPQ.OrderOp { HPQ.orderDirection = HPQ.OpAsc , HPQ.orderNulls = HPQ.NullsFirst } -- | Specify an descending ordering by the given expression. -- (Any NULLs appear last) -descNullsLast :: PGOrd b => (a -> C.Column b) -> O.Order a +descNullsLast :: SqlOrd b => (a -> C.Column b) -> O.Order a descNullsLast = O.order HPQ.OrderOp { HPQ.orderDirection = HPQ.OpDesc , HPQ.orderNulls = HPQ.NullsLast } @@ -96,7 +104,7 @@ SELECT * FROM (SELECT * FROM yourTable LIMIT 10) OFFSET 50 @ -} -limit :: Int -> Query a -> Query a +limit :: Int -> S.Select a -> S.Select a limit n a = Q.simpleQueryArr (O.limit' n . Q.runSimpleQueryArr a) {- | @@ -106,7 +114,7 @@ /WARNING:/ Please read the documentation of 'limit' before combining 'offset' with 'limit'. -} -offset :: Int -> Query a -> Query a +offset :: Int -> S.Select a -> S.Select a offset n a = Q.simpleQueryArr (O.offset' n . Q.runSimpleQueryArr a) -- * Other @@ -114,18 +122,20 @@ -- | Typeclass for Postgres types which support ordering operations. class PGOrd a where -instance PGOrd T.PGBool -instance PGOrd T.PGDate -instance PGOrd T.PGFloat8 -instance PGOrd T.PGFloat4 -instance PGOrd T.PGInt8 -instance PGOrd T.PGInt4 -instance PGOrd T.PGInt2 -instance PGOrd T.PGNumeric -instance PGOrd T.PGText -instance PGOrd T.PGTime -instance PGOrd T.PGTimestamptz -instance PGOrd T.PGTimestamp -instance PGOrd T.PGCitext -instance PGOrd T.PGUuid +type SqlOrd = PGOrd + +instance PGOrd T.SqlBool +instance PGOrd T.SqlDate +instance PGOrd T.SqlFloat8 +instance PGOrd T.SqlFloat4 +instance PGOrd T.SqlInt8 +instance PGOrd T.SqlInt4 +instance PGOrd T.SqlInt2 +instance PGOrd T.SqlNumeric +instance PGOrd T.SqlText +instance PGOrd T.SqlTime +instance PGOrd T.SqlTimestamptz +instance PGOrd T.SqlTimestamp +instance PGOrd T.SqlCitext +instance PGOrd T.SqlUuid instance PGOrd a => PGOrd (C.Nullable a) diff --git a/src/Opaleye/PGTypes.hs b/src/Opaleye/PGTypes.hs --- a/src/Opaleye/PGTypes.hs +++ b/src/Opaleye/PGTypes.hs @@ -19,6 +19,7 @@ import qualified Data.Text.Lazy as LText import qualified Data.ByteString as SByteString import qualified Data.ByteString.Lazy as LByteString +import Data.Scientific as Sci import qualified Data.Time as Time import qualified Data.UUID as UUID @@ -27,26 +28,27 @@ import qualified Database.PostgreSQL.Simple.Range as R instance C.PGNum PGFloat8 where - pgFromInteger = pgDouble . fromInteger + sqlFromInteger = pgDouble . fromInteger instance C.PGNum PGInt4 where - pgFromInteger = pgInt4 . fromInteger + sqlFromInteger = pgInt4 . fromInteger instance C.PGNum PGInt8 where - pgFromInteger = pgInt8 . fromInteger + sqlFromInteger = pgInt8 . fromInteger instance C.PGFractional PGFloat8 where - pgFromRational = pgDouble . fromRational + sqlFromRational = pgDouble . fromRational instance C.PGIntegral PGInt2 +instance C.PGIntegral PGNumeric instance C.PGIntegral PGInt4 instance C.PGIntegral PGInt8 instance C.PGString PGText where - pgFromString = pgString + sqlFromString = pgString instance C.PGString PGCitext where - pgFromString = pgCiLazyText . CI.mk . LText.pack + sqlFromString = pgCiLazyText . CI.mk . LText.pack -- * Creating SQL values @@ -65,6 +67,9 @@ pgLazyText :: LText.Text -> Column PGText pgLazyText = IPT.literalColumn . HPQ.StringLit . LText.unpack +pgNumeric :: Sci.Scientific -> Column PGNumeric +pgNumeric = IPT.literalColumn . HPQ.NumericLit + pgInt4 :: Int -> Column PGInt4 pgInt4 = IPT.literalColumn . HPQ.IntegerLit . fromIntegral @@ -155,11 +160,11 @@ {-# DEPRECATED showPGType "Use 'showSqlType' instead. 'showPGType' will be removed \ \in version 0.7." #-} -class IsSqlType pgType where - showPGType :: proxy pgType -> String +class IsSqlType sqlType where + showPGType :: proxy sqlType -> String showPGType = showSqlType - showSqlType :: proxy pgType -> String + showSqlType :: proxy sqlType -> String showSqlType = showPGType instance IsSqlType PGBool where diff --git a/src/Opaleye/RunQuery.hs b/src/Opaleye/RunQuery.hs --- a/src/Opaleye/RunQuery.hs +++ b/src/Opaleye/RunQuery.hs @@ -1,8 +1,12 @@ {-# LANGUAGE FlexibleContexts #-} +-- | This module will be deprecated in 0.7. Use "Opaleye.RunSelect" instead. + module Opaleye.RunQuery (module Opaleye.RunQuery, -- * Datatypes IRQ.Cursor, + IRQ.FromFields, + IRQ.FromField, QueryRunner, IRQ.QueryRunnerColumn, IRQ.QueryRunnerColumnDefault (..), @@ -17,8 +21,8 @@ import qualified Data.String as String import Opaleye.Column (Column) +import qualified Opaleye.Select as S import qualified Opaleye.Sql as S -import Opaleye.QueryArr (Query) import Opaleye.Internal.RunQuery (QueryRunner(QueryRunner)) import qualified Opaleye.Internal.RunQuery as IRQ import qualified Opaleye.Internal.QueryArr as Q @@ -26,7 +30,7 @@ import qualified Data.Profunctor as P import qualified Data.Profunctor.Product.Default as D --- * Running 'Query's +-- * Running 'S.Select's -- | @runQuery@'s use of the 'D.Default' typeclass means that the -- compiler will have trouble inferring types. It is strongly @@ -36,21 +40,21 @@ -- Example type specialization: -- -- @ --- runQuery :: Query (Column 'Opaleye.PGTypes.PGInt4', Column 'Opaleye.PGTypes.PGText') -> IO [(Int, String)] +-- runQuery :: 'S.Select' (Column 'Opaleye.SqlTypes.SqlInt4', Column 'Opaleye.SqlTypes.SqlText') -> IO [(Int, String)] -- @ -- -- Assuming the @makeAdaptorAndInstance@ splice has been run for the product type @Foo@: -- -- @ --- runQuery :: Query (Foo (Column 'Opaleye.PGTypes.PGInt4') (Column 'Opaleye.PGTypes.PGText') (Column 'Opaleye.PGTypes.PGBool') +-- runQuery :: 'S.Select' (Foo (Column 'Opaleye.SqlTypes.SqlInt4') (Column 'Opaleye.SqlTypes.SqlText') (Column 'Opaleye.SqlTypes.SqlBool') -- -> IO [Foo Int String Bool] -- @ -- -- Opaleye types are converted to Haskell types based on instances of -- the 'Opaleye.Internal.RunQuery.QueryRunnerColumnDefault' typeclass. -runQuery :: D.Default QueryRunner columns haskells +runQuery :: D.Default IRQ.FromFields fields haskells => PGS.Connection - -> Query columns + -> S.Select fields -> IO [haskells] runQuery = runQueryExplicit D.def @@ -60,9 +64,9 @@ -- This fold is /not/ strict. The stream consumer is responsible for -- forcing the evaluation of its result to avoid space leaks. runQueryFold - :: D.Default QueryRunner columns haskells + :: D.Default IRQ.FromFields fields haskells => PGS.Connection - -> Query columns + -> S.Select fields -> b -> (b -> haskells -> IO b) -> IO b @@ -79,7 +83,7 @@ -- instance QueryRunnerColumnDefault Foo Foo where -- queryRunnerColumnDefault = -- queryRunnerColumn ('Opaleye.Column.unsafeCoerceColumn' --- :: Column Foo -> Column PGInt4) +-- :: Column Foo -> Column SqlInt4) -- Foo -- queryRunnerColumnDefault -- @ @@ -92,17 +96,17 @@ -- * Explicit versions -runQueryExplicit :: QueryRunner columns haskells +runQueryExplicit :: IRQ.FromFields fields haskells -> PGS.Connection - -> Query columns + -> S.Select fields -> IO [haskells] runQueryExplicit qr conn q = maybe (return []) (PGS.queryWith_ parser conn) sql where (sql, parser) = prepareQuery qr q runQueryFoldExplicit - :: QueryRunner columns haskells + :: IRQ.FromFields fields haskells -> PGS.Connection - -> Query columns + -> S.Select fields -> b -> (b -> haskells -> IO b) -> IO b @@ -118,17 +122,17 @@ -- -- Returns 'Nothing' when the query returns zero rows. declareCursor - :: D.Default QueryRunner columns haskells + :: D.Default IRQ.FromFields fields haskells => PGS.Connection - -> Query columns + -> S.Select fields -> IO (IRQ.Cursor haskells) declareCursor = declareCursorExplicit D.def --- | Like 'declareCursor' but takes a 'QueryRunner' explicitly. +-- | Like 'declareCursor' but takes a 'IRQ.FromFields' explicitly. declareCursorExplicit - :: QueryRunner columns haskells + :: IRQ.FromFields fields haskells -> PGS.Connection - -> Query columns + -> S.Select fields -> IO (IRQ.Cursor haskells) declareCursorExplicit qr conn q = case mbQuery of @@ -138,7 +142,7 @@ (mbQuery, rowParser) = prepareQuery qr q -- | Close the given cursor. -closeCursor :: IRQ.Cursor columns -> IO () +closeCursor :: IRQ.Cursor fields -> IO () closeCursor IRQ.EmptyCursor = pure () closeCursor (IRQ.Cursor _ cursor) = PGSC.closeCursor cursor @@ -158,7 +162,7 @@ -- * Deprecated functions {-# DEPRECATED prepareQuery "Will be removed in version 0.7" #-} -prepareQuery :: QueryRunner columns haskells -> Query columns -> (Maybe PGS.Query, FR.RowParser haskells) +prepareQuery :: IRQ.FromFields fields haskells -> S.Select fields -> (Maybe PGS.Query, FR.RowParser haskells) prepareQuery qr@(QueryRunner u _ _) q = (sql, parser) where sql :: Maybe PGS.Query sql = fmap String.fromString (S.showSqlForPostgresExplicit u q) diff --git a/src/Opaleye/RunSelect.hs b/src/Opaleye/RunSelect.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/RunSelect.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +module Opaleye.RunSelect + (module Opaleye.RunSelect, + -- * Datatypes + IRQ.Cursor, + IRQ.FromFields, + IRQ.FromField) where + +import Control.Applicative (pure, (<$>)) +import qualified Database.PostgreSQL.Simple as PGS +import qualified Database.PostgreSQL.Simple.Cursor as PGSC +import qualified Database.PostgreSQL.Simple.FromRow as FR +import qualified Data.String as String + +import Opaleye.Column (Column) +import qualified Opaleye.Select as S +import qualified Opaleye.RunQuery as RQ +import qualified Opaleye.Sql as S +import Opaleye.Internal.RunQuery (FromFields) +import qualified Opaleye.Internal.RunQuery as IRQ +import qualified Opaleye.Internal.QueryArr as Q + +import qualified Data.Profunctor as P +import qualified Data.Profunctor.Product.Default as D + +-- * Running 'S.Select's + +-- | @runSelect@'s use of the 'D.Default' typeclass means that the +-- compiler will have trouble inferring types. It is strongly +-- recommended that you provide full type signatures when using +-- @runSelect@. +-- +-- Example type specialization: +-- +-- @ +-- runSelect :: 'S.Select' (Column 'Opaleye.SqlTypes.SqlInt4', Column 'Opaleye.SqlTypes.SqlText') -> IO [(Int, String)] +-- @ +-- +-- Assuming the @makeAdaptorAndInstance@ splice has been run for the product type @Foo@: +-- +-- @ +-- runSelect :: 'S.Select' (Foo (Column 'Opaleye.SqlTypes.SqlInt4') (Column 'Opaleye.SqlTypes.SqlText') (Column 'Opaleye.SqlTypes.SqlBool') +-- -> IO [Foo Int String Bool] +-- @ +runSelect :: D.Default FromFields fields haskells + => PGS.Connection + -- ^ + -> S.Select fields + -- ^ + -> IO [haskells] +runSelect = RQ.runQuery + +-- | @runSelectFold@ streams the results of a query incrementally and consumes +-- the results with a left fold. +-- +-- This fold is /not/ strict. The stream consumer is responsible for +-- forcing the evaluation of its result to avoid space leaks. +runSelectFold + :: D.Default FromFields fields haskells + => PGS.Connection + -- ^ + -> S.Select fields + -- ^ + -> b + -- ^ + -> (b -> haskells -> IO b) + -- ^ + -> IO b +runSelectFold = RQ.runQueryFold + +-- * Cursor interface + +-- | Declare a temporary cursor. The cursor is given a unique name for the given +-- connection. +-- +-- Returns 'Nothing' when the query returns zero rows. +declareCursor + :: D.Default FromFields fields haskells + => PGS.Connection + -- ^ + -> S.Select fields + -- ^ + -> IO (IRQ.Cursor haskells) +declareCursor = RQ.declareCursor + +-- | Close the given cursor. +closeCursor :: IRQ.Cursor fields -> IO () +closeCursor = RQ.closeCursor + +-- | Fold over a chunk of rows, calling the supplied fold-like function on each +-- row as it is received. In case the cursor is exhausted, a 'Left' value is +-- returned, otherwise a 'Right' value is returned. +foldForward + :: IRQ.Cursor haskells + -- ^ + -> Int + -- ^ + -> (a -> haskells -> IO a) + -- ^ + -> a + -- ^ + -> IO (Either a a) +foldForward = RQ.foldForward + +-- * Explicit versions + +runSelectExplicit :: FromFields fields haskells + -> PGS.Connection + -> S.Select fields + -> IO [haskells] +runSelectExplicit = RQ.runQueryExplicit + +runSelectFoldExplicit + :: FromFields fields haskells + -> PGS.Connection + -> S.Select fields + -> b + -> (b -> haskells -> IO b) + -> IO b +runSelectFoldExplicit = RQ.runQueryFoldExplicit + +declareCursorExplicit + :: FromFields fields haskells + -> PGS.Connection + -> S.Select fields + -> IO (IRQ.Cursor haskells) +declareCursorExplicit = RQ.declareCursorExplicit diff --git a/src/Opaleye/Select.hs b/src/Opaleye/Select.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/Select.hs @@ -0,0 +1,6 @@ +module Opaleye.Select where + +import qualified Opaleye.QueryArr as Q + +type SelectArr = Q.QueryArr +type Select = SelectArr () diff --git a/src/Opaleye/Sql.hs b/src/Opaleye/Sql.hs --- a/src/Opaleye/Sql.hs +++ b/src/Opaleye/Sql.hs @@ -13,6 +13,8 @@ import qualified Opaleye.Internal.QueryArr as Q import qualified Opaleye.Internal.Tag as T +import qualified Opaleye.Select as S + import qualified Data.Profunctor.Product.Default as D -- * Showing SQL @@ -25,56 +27,56 @@ -- Example type specialization: -- -- @ --- showSql :: Query (Column a, Column b) -> Maybe String +-- showSql :: Select (Column a, Column b) -> Maybe String -- @ -- -- Assuming the @makeAdaptorAndInstance@ splice has been run for the -- product type @Foo@: -- -- @ --- showSql :: Query (Foo (Column a) (Column b) (Column c)) -> Maybe String +-- showSql :: Select (Foo (Column a) (Column b) (Column c)) -> Maybe String -- @ -showSql :: forall columns. - D.Default U.Unpackspec columns columns - => Q.Query columns +showSql :: forall fields. + D.Default U.Unpackspec fields fields + => S.Select fields -> Maybe String -showSql = showSqlExplicit (D.def :: U.Unpackspec columns columns) +showSql = showSqlExplicit (D.def :: U.Unpackspec fields fields) -- | Show the unoptimized SQL query string generated from the query. -showSqlUnopt :: forall columns. - D.Default U.Unpackspec columns columns - => Q.Query columns +showSqlUnopt :: forall fields. + D.Default U.Unpackspec fields fields + => S.Select fields -> Maybe String -showSqlUnopt = showSqlUnoptExplicit (D.def :: U.Unpackspec columns columns) +showSqlUnopt = showSqlUnoptExplicit (D.def :: U.Unpackspec fields fields) -- * Explicit versions -showSqlExplicit :: U.Unpackspec columns b -> Q.Query columns -> Maybe String +showSqlExplicit :: U.Unpackspec fields b -> S.Select fields -> Maybe String showSqlExplicit = formatAndShowSQL . (\(x, y, z) -> (x, Op.optimize y, z)) .: Q.runQueryArrUnpack -showSqlUnoptExplicit :: U.Unpackspec columns b -> Q.Query columns -> Maybe String +showSqlUnoptExplicit :: U.Unpackspec fields b -> S.Select fields -> Maybe String showSqlUnoptExplicit = formatAndShowSQL .: Q.runQueryArrUnpack -- * Deprecated functions -- | Will be deprecated in version 0.7. Use 'showSql' instead. showSqlForPostgres :: forall columns . D.Default U.Unpackspec columns columns => - Q.Query columns -> Maybe String + S.Select columns -> Maybe String showSqlForPostgres = showSql -- | Will be deprecated in version 0.7. Use 'showSqlUnopt' instead. showSqlForPostgresUnopt :: forall columns . D.Default U.Unpackspec columns columns => - Q.Query columns -> Maybe String + S.Select columns -> Maybe String showSqlForPostgresUnopt = showSqlUnopt -- | Will be deprecated in version 0.7. Use 'showSqlExplicit' instead. -showSqlForPostgresExplicit :: U.Unpackspec columns b -> Q.Query columns -> Maybe String +showSqlForPostgresExplicit :: U.Unpackspec columns b -> S.Select columns -> Maybe String showSqlForPostgresExplicit = showSqlExplicit -- | Will be deprecated in version 0.7. Use 'showSqlUnoptExplicit' instead. -showSqlForPostgresUnoptExplicit :: U.Unpackspec columns b -> Q.Query columns -> Maybe String +showSqlForPostgresUnoptExplicit :: U.Unpackspec columns b -> S.Select columns -> Maybe String showSqlForPostgresUnoptExplicit = showSqlUnoptExplicit {-# DEPRECATED formatAndShowSQL diff --git a/src/Opaleye/SqlTypes.hs b/src/Opaleye/SqlTypes.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/SqlTypes.hs @@ -0,0 +1,145 @@ +module Opaleye.SqlTypes (module Opaleye.SqlTypes, + P.IsSqlType, + P.IsRangeType) where + +import qualified Opaleye.Field as F +import qualified Opaleye.PGTypes as P +import Opaleye.PGTypes (IsSqlType, IsRangeType) + +import qualified Data.Aeson as Ae +import qualified Data.ByteString as SByteString +import qualified Data.ByteString.Lazy as LByteString +import qualified Data.CaseInsensitive as CI +import Data.Int (Int64) +import Data.Scientific as Sci +import qualified Data.Text as SText +import qualified Data.Text.Lazy as LText +import qualified Data.Time as Time +import qualified Data.UUID as UUID + +import qualified Database.PostgreSQL.Simple.Range as R + +-- * Creating SQL values + +sqlString :: String -> F.Field SqlText +sqlString = P.pgString + +sqlLazyByteString :: LByteString.ByteString -> F.Field SqlBytea +sqlLazyByteString = P.pgLazyByteString + +sqlStrictByteString :: SByteString.ByteString -> F.Field SqlBytea +sqlStrictByteString = P.pgStrictByteString + +sqlStrictText :: SText.Text -> F.Field SqlText +sqlStrictText = P.pgStrictText + +sqlLazyText :: LText.Text -> F.Field SqlText +sqlLazyText = P.pgLazyText + +sqlNumeric :: Sci.Scientific -> F.Field SqlNumeric +sqlNumeric = P.pgNumeric + +sqlInt4 :: Int -> F.Field SqlInt4 +sqlInt4 = P.pgInt4 + +sqlInt8 :: Int64 -> F.Field SqlInt8 +sqlInt8 = P.pgInt8 + +sqlDouble :: Double -> F.Field SqlFloat8 +sqlDouble = P.pgDouble + +sqlBool :: Bool -> F.Field SqlBool +sqlBool = P.pgBool + +sqlUUID :: UUID.UUID -> F.Field SqlUuid +sqlUUID = P.pgUUID + +sqlDay :: Time.Day -> F.Field SqlDate +sqlDay = P.pgDay + +sqlUTCTime :: Time.UTCTime -> F.Field SqlTimestamptz +sqlUTCTime = P.pgUTCTime + +sqlLocalTime :: Time.LocalTime -> F.Field SqlTimestamp +sqlLocalTime = P.pgLocalTime + +sqlZonedTime :: Time.ZonedTime -> F.Field SqlTimestamptz +sqlZonedTime = P.pgZonedTime + +sqlTimeOfDay :: Time.TimeOfDay -> F.Field SqlTime +sqlTimeOfDay = P.pgTimeOfDay + +-- "We recommend not using the type time with time zone" +-- http://www.postgresql.org/docs/8.3/static/datatype-datetime.html + + +sqlCiStrictText :: CI.CI SText.Text -> F.Field SqlCitext +sqlCiStrictText = P.pgCiStrictText + +sqlCiLazyText :: CI.CI LText.Text -> F.Field SqlCitext +sqlCiLazyText = P.pgCiLazyText + +-- No CI String instance since postgresql-simple doesn't define FromField (CI String) + +-- The json data type was introduced in PostgreSQL version 9.2 +-- JSON values must be SQL string quoted +sqlJSON :: String -> F.Field SqlJson +sqlJSON = P.pgJSON + +sqlStrictJSON :: SByteString.ByteString -> F.Field SqlJson +sqlStrictJSON = P.pgStrictJSON + +sqlLazyJSON :: LByteString.ByteString -> F.Field SqlJson +sqlLazyJSON = P.pgLazyJSON + +sqlValueJSON :: Ae.ToJSON a => a -> F.Field SqlJson +sqlValueJSON = P.pgValueJSON + +-- The jsonb data type was introduced in PostgreSQL version 9.4 +-- JSONB values must be SQL string quoted +-- +-- TODO: We need to add literal JSON and JSONB types so we can say +-- `castToTypeTyped JSONB` rather than `castToType "jsonb"`. +sqlJSONB :: String -> F.Field SqlJsonb +sqlJSONB = P.pgJSONB + +sqlStrictJSONB :: SByteString.ByteString -> F.Field SqlJsonb +sqlStrictJSONB = P.pgStrictJSONB + +sqlLazyJSONB :: LByteString.ByteString -> F.Field SqlJsonb +sqlLazyJSONB = P.pgLazyJSONB + +sqlValueJSONB :: Ae.ToJSON a => a -> F.Field SqlJsonb +sqlValueJSONB = P.pgValueJSONB + +sqlArray :: IsSqlType b => (a -> F.Field b) -> [a] -> F.Field (SqlArray b) +sqlArray = P.pgArray + +sqlRange :: IsRangeType b + => (a -> F.Field b) + -> R.RangeBound a + -> R.RangeBound a + -> F.Field (SqlRange b) +sqlRange = P.pgRange + +-- * SQL datatypes + +type SqlBool = P.PGBool +type SqlDate = P.PGDate +type SqlFloat4 = P.PGFloat4 +type SqlFloat8 = P.PGFloat8 +type SqlInt8 = P.PGInt8 +type SqlInt4 = P.PGInt4 +type SqlInt2 = P.PGInt2 +type SqlNumeric = P.PGNumeric +type SqlText = P.PGText +type SqlTime = P.PGTime +type SqlTimestamp = P.PGTimestamp +type SqlTimestamptz = P.PGTimestamptz +type SqlUuid = P.PGUuid +type SqlCitext = P.PGCitext +type SqlArray = P.PGArray +type SqlBytea = P.PGBytea +type SqlJson = P.PGJson +type SqlJsonb = P.PGJsonb +type SqlRange = P.PGRange diff --git a/src/Opaleye/Table.hs b/src/Opaleye/Table.hs --- a/src/Opaleye/Table.hs +++ b/src/Opaleye/Table.hs @@ -8,56 +8,56 @@ Columns can be required or optional and, independently, nullable or non-nullable. - A required non-nullable @PGInt4@ (for example) is created with + A required non-nullable @SqlInt4@ (for example) is created with 'required' and gives rise to a @ - TableColumns (Column PGInt4) (Column PGInt4) + TableColumns (Column SqlInt4) (Column SqlInt4) @ The leftmost argument is the type of writes. When you insert or - update into this column you must give it a @Column PGInt4@ (which you - can create with @pgInt4 :: Int -> Column PGInt4@). + update into this column you must give it a @Column SqlInt4@ (which you + can create with @sqlInt4 :: Int -> Column SqlInt4@). - A required nullable @PGInt4@ is created with 'required' and gives rise + A required nullable @SqlInt4@ is created with 'required' and gives rise to a @ - TableColumns (Column (Nullable PGInt4)) (Column (Nullable PGInt4)) + TableColumns (Column (Nullable SqlInt4)) (Column (Nullable SqlInt4)) @ When you insert or update into this column you must give it a @Column - (Nullable PGInt4)@, which you can create either with @pgInt4@ and + (Nullable SqlInt4)@, which you can create either with @sqlInt4@ and @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 @SqlInt4@ is created with 'optional' and gives rise to a @ - TableColumns (Maybe (Column PGInt4)) (Column PGInt4) + TableColumns (Maybe (Column SqlInt4)) (Column SqlInt4) @ 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 + (Column SqlInt4)@. 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@. + you have to provide a @Just@ containing a @Column SqlInt4@. - An optional nullable @PGInt4@ is created with 'optional' and gives + An optional nullable @SqlInt4@ is created with 'optional' and gives rise to a @ - TableColumns (Maybe (Column (Nullable PGInt4))) (Column (Nullable PGInt4)) + TableColumns (Maybe (Column (Nullable SqlInt4))) (Column (Nullable SqlInt4)) @ 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 + (Column (Nullable SqlInt4))@. If you provide @Nothing@ then the default value will be used. Otherwise you have to provide a @Just@ containing - a @Column (Nullable PGInt4)@ (which can be null). + a @Column (Nullable SqlInt4)@ (which can be null). -} @@ -69,7 +69,7 @@ T.optional, T.required, -- * Querying tables - queryTable, + selectTable, -- * Other TableColumns, -- * Deprecated @@ -87,31 +87,35 @@ import qualified Opaleye.Internal.Tag as Tag import qualified Opaleye.Internal.Unpackspec as U +import qualified Opaleye.Select as S + import qualified Data.Profunctor.Product.Default as D -- | Example type specialization: -- -- @ --- queryTable :: Table w (Column a, Column b) --- -> Query (Column a, Column b) +-- selectTable :: Table w (Column a, Column b) +-- -> Select (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)) +-- selectTable :: Table w (Foo (Column a) (Column b) (Column c)) +-- -> Select (Foo (Column a) (Column b) (Column c)) -- @ -queryTable :: D.Default U.Unpackspec columns columns => - Table a columns -> Q.Query columns -queryTable = queryTableExplicit D.def +selectTable :: D.Default U.Unpackspec fields fields + => Table a fields + -- ^ + -> S.Select fields +selectTable = selectTableExplicit D.def -- | Create a table with unqualified names. table :: String -- ^ Table name - -> TableColumns writeColumns viewColumns - -> Table writeColumns viewColumns + -> TableColumns writeFields viewFields + -> Table writeFields viewFields table = T.Table -- | Create a table. @@ -119,14 +123,30 @@ -- ^ Schema name -> String -- ^ Table name - -> TableColumns writeColumns viewColumns - -> Table writeColumns viewColumns + -> TableColumns writeFields viewFields + -> Table writeFields viewFields tableWithSchema = T.TableWithSchema -- * Explicit versions -queryTableExplicit :: U.Unpackspec tablecolumns columns -> - Table a tablecolumns -> Q.Query columns -queryTableExplicit cm table' = Q.simpleQueryArr f where +selectTableExplicit :: U.Unpackspec tablefields fields + -- ^ + -> Table a tablefields + -- ^ + -> S.Select fields +selectTableExplicit cm table' = Q.simpleQueryArr f where f ((), t0) = (retwires, primQ, Tag.next t0) where (retwires, primQ) = T.queryTable cm table' t0 + +-- * Deprecated versions + +-- | Use 'selectTable' instead. Will be deprecated in version 0.7. +queryTable :: D.Default U.Unpackspec fields fields => + Table a fields -> S.Select fields +queryTable = selectTable + +-- | Use 'selectTableExplicit' instead. Will be deprecated in version +-- 0.7. +queryTableExplicit :: U.Unpackspec tablefields fields -> + Table a tablefields -> S.Select fields +queryTableExplicit = selectTableExplicit diff --git a/src/Opaleye/TypeFamilies.hs b/src/Opaleye/TypeFamilies.hs new file mode 100644 --- /dev/null +++ b/src/Opaleye/TypeFamilies.hs @@ -0,0 +1,20 @@ +module Opaleye.TypeFamilies + ( TF.TableField + , TF.RecordField + , (TF.:<*>) + , (TF.:<$>) + , TF.Id + , TF.Pure + , TF.IMap + , TF.F + , TF.O + , TF.H + , TF.W + , TF.N + , TF.NN + , TF.Opt + , TF.Req + , TF.Nulls + ) where + +import Opaleye.Internal.TypeFamilies as TF diff --git a/src/Opaleye/Values.hs b/src/Opaleye/Values.hs --- a/src/Opaleye/Values.hs +++ b/src/Opaleye/Values.hs @@ -3,9 +3,9 @@ module Opaleye.Values where import qualified Opaleye.Internal.QueryArr as Q -import Opaleye.QueryArr (Query) import Opaleye.Internal.Values as V import qualified Opaleye.Internal.Unpackspec as U +import qualified Opaleye.Select as S import Data.Profunctor.Product.Default (Default, def) @@ -15,22 +15,22 @@ -- Example type specialization: -- -- @ --- values :: [(Column a, Column b)] -> Query (Column a, Column b) +-- values :: [(Column a, Column b)] -> Select (Column a, Column b) -- @ -- -- Assuming the @makeAdaptorAndInstance@ splice has been run for the -- product type @Foo@: -- -- @ --- queryTable :: [Foo (Column a) (Column b) (Column c)] -> Query (Foo (Column a) (Column b) (Column c)) +-- queryTable :: [Foo (Column a) (Column b) (Column c)] -> S.Select (Foo (Column a) (Column b) (Column c)) -- @ -values :: (Default V.Valuesspec columns columns, - Default U.Unpackspec columns columns) => - [columns] -> Q.Query columns +values :: (Default V.Valuesspec fields fields, + Default U.Unpackspec fields fields) => + [fields] -> S.Select fields values = valuesExplicit def def -valuesExplicit :: U.Unpackspec columns columns' - -> V.Valuesspec columns columns' - -> [columns] -> Query columns' -valuesExplicit unpack valuesspec columns = - Q.simpleQueryArr (V.valuesU unpack valuesspec columns) +valuesExplicit :: U.Unpackspec fields fields' + -> V.Valuesspec fields fields' + -> [fields] -> S.Select fields' +valuesExplicit unpack valuesspec fields = + Q.simpleQueryArr (V.valuesU unpack valuesspec fields)