opaleye 0.7.6.2 → 0.10.8.0
raw patch · 79 files changed
Files
- CHANGELOG.md +238/−3
- Doc/Tutorial/DefaultExplanation.lhs +1/−1
- Doc/Tutorial/TutorialBasic.lhs +24/−27
- Doc/Tutorial/TutorialBasicMonomorphic.lhs +19/−36
- LICENSE +1/−1
- README.md +3/−3
- Test/Opaleye/Test/Arbitrary.hs +19/−12
- Test/Opaleye/Test/Fields.hs +0/−1
- Test/QuickCheck.hs +4/−5
- Test/Test.hs +218/−47
- opaleye.cabal +24/−25
- src/Opaleye.hs +8/−21
- src/Opaleye/Adaptors.hs +0/−1
- src/Opaleye/Aggregate.hs +76/−37
- src/Opaleye/Binary.hs +3/−5
- src/Opaleye/Column.hs +5/−42
- src/Opaleye/Constant.hs +0/−4
- src/Opaleye/Distinct.hs +10/−7
- src/Opaleye/Exists.hs +8/−9
- src/Opaleye/Experimental/Enum.hs +17/−20
- src/Opaleye/Field.hs +63/−48
- src/Opaleye/FunctionalJoin.hs +2/−90
- src/Opaleye/Inferrable.hs +9/−0
- src/Opaleye/Internal/Aggregate.hs +113/−42
- src/Opaleye/Internal/Binary.hs +17/−15
- src/Opaleye/Internal/Column.hs +45/−32
- src/Opaleye/Internal/Constant.hs +60/−57
- src/Opaleye/Internal/Distinct.hs +9/−10
- src/Opaleye/Internal/HaskellDB/PrimQuery.hs +46/−4
- src/Opaleye/Internal/HaskellDB/Sql.hs +12/−1
- src/Opaleye/Internal/HaskellDB/Sql/Default.hs +63/−34
- src/Opaleye/Internal/HaskellDB/Sql/Print.hs +29/−2
- src/Opaleye/Internal/Inferrable.hs +100/−89
- src/Opaleye/Internal/JSONBuildObjectFields.hs +5/−5
- src/Opaleye/Internal/Join.hs +27/−60
- src/Opaleye/Internal/Lateral.hs +0/−2
- src/Opaleye/Internal/Locking.hs +3/−1
- src/Opaleye/Internal/Manipulation.hs +20/−78
- src/Opaleye/Internal/MaybeFields.hs +54/−26
- src/Opaleye/Internal/Operators.hs +44/−54
- src/Opaleye/Internal/Optimize.hs +16/−7
- src/Opaleye/Internal/Order.hs +21/−30
- src/Opaleye/Internal/PGTypes.hs +25/−8
- src/Opaleye/Internal/PGTypesExternal.hs +52/−43
- src/Opaleye/Internal/PackMap.hs +21/−4
- src/Opaleye/Internal/PrimQuery.hs +169/−48
- src/Opaleye/Internal/Print.hs +62/−22
- src/Opaleye/Internal/QueryArr.hs +64/−65
- src/Opaleye/Internal/Rebind.hs +16/−6
- src/Opaleye/Internal/RunQuery.hs +96/−100
- src/Opaleye/Internal/RunQueryExternal.hs +3/−29
- src/Opaleye/Internal/Sql.hs +70/−32
- src/Opaleye/Internal/Table.hs +41/−61
- src/Opaleye/Internal/TableMaker.hs +0/−70
- src/Opaleye/Internal/Tag.hs +8/−0
- src/Opaleye/Internal/TypeFamilies.hs +0/−3
- src/Opaleye/Internal/Unpackspec.hs +16/−21
- src/Opaleye/Internal/Values.hs +128/−117
- src/Opaleye/Internal/Window.hs +181/−0
- src/Opaleye/Join.hs +22/−67
- src/Opaleye/Label.hs +15/−1
- src/Opaleye/Manipulation.hs +88/−193
- src/Opaleye/Map.hs +0/−4
- src/Opaleye/MaybeFields.hs +12/−6
- src/Opaleye/Operators.hs +128/−113
- src/Opaleye/Order.hs +78/−44
- src/Opaleye/PGTypes.hs +0/−4
- src/Opaleye/QueryArr.hs +0/−3
- src/Opaleye/RunQuery.hs +0/−4
- src/Opaleye/RunSelect.hs +28/−33
- src/Opaleye/Select.hs +1/−1
- src/Opaleye/Sql.hs +2/−25
- src/Opaleye/SqlTypes.hs +19/−6
- src/Opaleye/Table.hs +20/−43
- src/Opaleye/ToFields.hs +1/−3
- src/Opaleye/TypeFamilies.hs +1/−4
- src/Opaleye/Values.hs +6/−37
- src/Opaleye/Window.hs +114/−0
- src/Opaleye/With.hs +150/−0
CHANGELOG.md view
@@ -1,6 +1,241 @@+## 0.10.8.0++* Added `sqlElemAny`, a version of `sqlElem` that uses `= any` under+ the hood. (Thanks to @simmsb).++## 0.10.7.0++* Added `unsafeCastSqlType`, `typedNull` and `untypedNull`, allowing+ workaround for+ [#621](https://github.com/tomjaguarpaw/haskell-opaleye/issues/621).+ Thanks to @fpringle.++## 0.10.6.0++* Added `int2` functions and instances (thanks to @fpringle)++## 0.10.5.0++* Added `Opaleye.Inferrable`++* Added `limitField` and `offsetField`++## 0.10.4.0++* Added `instance Default Updater (Field_ n a) ()`++* Added `omitOnWriteTableField`++* Added `inMany` and removed `Functor` constraint from `in_`.++## 0.10.3.1++* Improve Haddock++## 0.10.3.0++* Added `enumShowSqlType` and `sqlTypeWithSchema` (thanks to+ @stevemao)++## 0.10.2.3++* Documentation improvements++## 0.10.2.2++* Documentation improvements++## 0.10.2.1++* Fixed bug that generated broken queries when using ordered+ `aggregateOrdered` with `distinctAggregator`, and when using set+ aggregation.++## 0.10.2.0++* Added `isJustAnd`++* Add `withMaterialized` (thanks to Shane O'Brien)++* Added 'dateTruncTimestamp` and `dateTruncTimestamptz` (thanks to+ @njaremko)++## 0.10.1.1++* Fix bugs in `WITH`. See+ https://github.com/tomjaguarpaw/haskell-opaleye/pull/572 (thanks to+ Shane O'Brien)++## 0.10.1.0++* Added `withRecursiveDistinct` (thanks to Shane O'Brien)++## 0.10.0.0++* Changed `relationValuedExpr` to work in more cases. (This is a+ breaking change to an internal function.)++* Removed the following, which were all previously deprecated:++ `valuesSafe`, `valuesSafeExplicit`, `valuesUnsafe`,+ `valuesUnsafeExplicit`, `ValuesspecSafe`, `fieldQueryRunnerColumn`,+ `fieldParserQueryRunnerColumn`, `queryRunner`, `joinF`, `leftJoinF`,+ `rightJoinF`, `fromFieldToFieldsEnum`, `keepWhen`++ See their documentation in the 0.9 series to learn about their+ replacements.++## 0.9.7.0++* Added `filterWhere` (thanks to Shane O'Brien)++## 0.9.6.2++* No externally visible changes++## 0.9.6.1++* No externally visible changes++## 0.9.6.0++* Add `Opaleye.Window` to support window functions. Thanks to Shane+ O'Brien.++## 0.9.5.1++* Actually expose `arrayAgg_`++## 0.9.5.0++* Add `arrayAgg_` for aggregating nullable fields++## 0.9.4.1++* Actually expose `ascNullsLast` and `descNullsFirst`.++## 0.9.4.0++* Added `instance DefaultFromField (T.SqlArray_ Nullable a) [Maybe b]`++* Changed `ascNullsFirst` and `descNullsLast` to work with nullable+ fields. This rectifies an oversight from the `Column` to `Field`+ change. This may technically be a PVP violation but I think the+ risk of breakage is very small. If you experience breakage please+ report it on [the issue+ tracker](https://github.com/tomjaguarpaw/haskell-opaleye/issues/new).++* Added `ascNullsLast` and `descNullsFirst`.++* Thanks to @abigailalice for pointing out the oversights in the+ `Column` to `Field` change.++## 0.9.3.3++* No externally visible changes++* Substantial internal changes to `Opaleye.Values`++## 0.9.3.2++* No externally visible changes++## 0.9.3.1++* No externally visible changes++## 0.9.3.0++* Add `with` and `withRecursive` (thanks to Erik Hesselink and Shane+ O'Brien).++* Add `Default ToFields` and `DefaultFromField` instances for+ postgresql-simple's `Aeson` (thanks to Bas Van Dijk).++## 0.9.2.0++* Added `nullableToMaybeFields` and `maybeFieldsToNullable`++## 0.9.1.0++* Added `distinctOnExplicit` and `distinctOnByExplicit`++* Added `label'` as a future replacement for `label`++* Exported `SqlFractional` from `Opaleye.SqlTypes`++* Fixed [a bug in+ `forUpdate`](https://github.com/tomjaguarpaw/haskell-opaleye/issues/540)++* The internal implementation of `QueryArr` has changed.++## 0.9.0.0++The switch from `Column` to `Field` is complete. This is a small yet+pervasive change. To update your code please change all usages of+`Column` as follows:++* `Column` of a non-nullable type: to `Field`+* `Column` of a nullable type: to `FieldNullable`+* `Column` of a nullability-polymorphic type: to `Field_ n`++For example++* `Column SqlText` -> `Field SqlText`+* `Column (Nullable SqlInt4)` -> `FieldNullable SqlInt4`+* `Column a` -> `Field_ n a`++This is the only change that has been made in this version, in order+to ease user transition.++* See also+ <https://github.com/tomjaguarpaw/haskell-opaleye/issues/326>++## 0.8.1.0++* Cosmetic and re-export changes only.++## 0.8.0.1++* Support GHC 9.2++## 0.8.0.0++* Removed the following deprecated functions, types and modules++ * `Opaleye.Query`, `Query`, `QueryArr`, `queryRunnerColumnDefault`+ * `Opaleye.RunQuery`, `runQuery`, `runQueryFold`,+ `queryRunnerColumn`+ * `Opaleye.Constant`, `constant`+ * The `Table` and `TableWithSchema` constructors+ * `View`, `Writer`, `required`, `optional`, `readOnly`,+ `tableColumn`, `queryTable`+ * `Nulled`, `leftJoinInferrable`, `rightJoinInferrable`, `fullJoinInferrable`+ * `unpackspecColumn`+ * `TableField`+ * `runInsertManyReturningOnConflictDoNothing`,+ `runInsertManyReturning`, `runUpdateEasy`, `runUpdateReturning`,+ `runDelete`+ * `charLength`, `exists`, `notExists`, `inQuery`+ * `PGIsJson`, `PGOrd`, `PG<typename>`+ * `showSqlForPostgres`, `showSqlForPostgresUnopt`++* Replaced the following old internal names++ * `QueryRunnerColumnDefault` -> `DefaultFromField`+ * `QueryRunnerColumn` -> `FromField` (type alias and constructor)+ * `QueryRunner` -> `FromFields` (type alias and constructor)++* `Opaleye.Join.optional` exported from top-level++* Bug fix: `distinctOn` and `distinctOnBy` now return a single row if+ zero columns are chosen to be distinct.++* Add `runInsert`/`Update`/`Delete` without underscore+ ## 0.7.6.2 -Fix ISO 8601 date fomatting. Thanks to Michal @kozak.+Fix ISO 8601 date formatting. Thanks to Michal @kozak. ## 0.7.6.1 @@ -163,7 +398,7 @@ ## 0.6.7003.1 -* Bumped some depedencies so there is an install plan on GHC 8.6+* Bumped some dependencies so there is an install plan on GHC 8.6 ## 0.6.7003.0 @@ -351,7 +586,7 @@ * Ordering operators and `max` and `min` aggregators are now restricted to a typeclass * Added `stringAgg` and `arrayAgg` aggregations. * Added `PGOrd` typeclass for typesafe ordering operations.-* Support sorting NULLs first or last with `ascNullsFirst` and `descNullsFirst`+* Support sorting NULLs first or last with `ascNullsFirst` and `descNullsLast` * Added JSON types * Added `runInsertMany`
Doc/Tutorial/DefaultExplanation.lhs view
@@ -119,7 +119,7 @@ Binaryspec (T a1 ... an) (T a1 ... an) (This requires the `Default` instance for `T` as generated by-`Data.Profunctor.Product.TH.makeAdaptorAndInstance`, or an equivalent+`Data.Profunctor.Product.TH.makeAdaptorAndInstanceInferrable`, or an equivalent instance defined by hand). It means we don't have to explicitly specify the `Binaryspec` value.
Doc/Tutorial/TutorialBasic.lhs view
@@ -2,23 +2,27 @@ > {-# LANGUAGE FlexibleInstances #-} > {-# LANGUAGE MultiParamTypeClasses #-} > {-# LANGUAGE TemplateHaskell #-}+> {-# LANGUAGE TypeFamilies #-}+> {-# LANGUAGE TypeOperators #-}+> {-# LANGUAGE UndecidableInstances #-} > > module TutorialBasic where > > import Prelude hiding (sum) > > import Opaleye (Field, FieldNullable, matchNullable, isNull,+> MaybeFields, > Table, table, tableField, selectTable, > Select, (.==), (.<=), (.&&), (.<), > (.===), > (.++), ifThenElse, sqlString, aggregate, groupBy,-> count, avg, sum, leftJoin, runSelect,+> count, avg, sum, optional, runSelect, > showSql, where_, Unpackspec, > SqlInt4, SqlInt8, SqlText, SqlDate, SqlFloat8, SqlBool) > > import Data.Profunctor.Product (p2, p3) > import Data.Profunctor.Product.Default (Default)-> import Data.Profunctor.Product.TH (makeAdaptorAndInstance)+> import Data.Profunctor.Product.TH (makeAdaptorAndInstanceInferrable) > import Data.Time.Calendar (Day) > > import qualified Database.PostgreSQL.Simple as PGS@@ -103,7 +107,7 @@ differences encountered in practice as an Opaleye bug. SELECT name,- age+ age, address FROM personTable @@ -129,7 +133,7 @@ have instances defined for them. The instances are derivable with Template Haskell. -> $(makeAdaptorAndInstance "pBirthday" ''Birthday')+> $(makeAdaptorAndInstanceInferrable "pBirthday" ''Birthday') You don't have to use Template Haskell, but it just saves us writing things out by hand here. If you want to avoid Template Haskell see@@ -171,8 +175,7 @@ Projection gives us our first example of using "do notation" to write Opaleye queries. -Here we run the `personSelect` passing in () to signify "zero-arguments". We pattern match on the results and return only the+Here we run the `personSelect`, pattern match on the results and return only the fields we are interested in. > nameAge :: Select (Field SqlText, Field SqlInt4)@@ -569,7 +572,7 @@ > , quantity :: d > , radius :: e } >-> $(makeAdaptorAndInstance "pWidget" ''Widget)+> $(makeAdaptorAndInstanceInferrable "pWidget" ''Widget) 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.@@ -644,25 +647,19 @@ 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 fields into nullable-fields 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.--> type FieldNullableBirthday = Birthday' (FieldNullable SqlText)-> (FieldNullable SqlDate)--A left join is expressed by specifying the two tables to join and the-join condition.+Opaleye supports left/right and full outer joins. A left or right+join is expressed by using `optional`. For full outer joins see+`Opaleye.Join`. > personBirthdayLeftJoin :: Select ((Field SqlText, Field SqlInt4, Field SqlText),-> FieldNullableBirthday)-> personBirthdayLeftJoin = leftJoin personSelect birthdaySelect eqName-> where eqName ((name, _, _), birthdayRow) = name .== bdName birthdayRow+> MaybeFields BirthdayField)+> personBirthdayLeftJoin = do+> personRow@(name, _, _) <- personSelect+> mBirthdayRow <- optional $ do+> birthdayRow <- birthdaySelect+> where_ (name .== bdName birthdayRow)+> pure birthdayRow+> pure (personRow, mBirthdayRow) The generated SQL is @@ -737,7 +734,7 @@ > , wLocation :: b > , wNumGoods :: c } >-> $(makeAdaptorAndInstance "pWarehouse" ''Warehouse')+> $(makeAdaptorAndInstanceInferrable "pWarehouse" ''Warehouse') We could represent the integer ID in Opaleye as a `SqlInt4` @@ -761,7 +758,7 @@ On the other hand we can make a newtype for the warehouse ID > newtype WarehouseId' a = WarehouseId a-> $(makeAdaptorAndInstance "pWarehouseId" ''WarehouseId')+> $(makeAdaptorAndInstanceInferrable "pWarehouseId" ''WarehouseId') > > type WarehouseIdField = WarehouseId' (Field SqlInt4) >@@ -827,7 +824,7 @@ > runEmployeesSelect = runSelect Newtypes are taken care of automatically by the typeclass instance-that was generated by `makeAdaptorAndInstance`. A `WarehouseId'+that was generated by `makeAdaptorAndInstanceInferrable`. A `WarehouseId' (Field SqlInt4)` becomes a `WarehouseId' Int` when the select is run. We could run the select `selectTable goodWarehouseTable` like this.
Doc/Tutorial/TutorialBasicMonomorphic.lhs view
@@ -7,12 +7,13 @@ > import Prelude hiding (sum) > > import Opaleye (Field, FieldNullable,-> Table, table, selectTable,+> Table, table, tableWithSchema, selectTable,+> MaybeFields, > tableField, > Select, (.==), > aggregate, groupBy,-> count, avg, sum, leftJoin, runSelect,-> showSql, Unpackspec,+> count, avg, sum, optional, runSelect,+> showSql, where_, Unpackspec, > SqlInt4, SqlInt8, SqlText, SqlDate, SqlFloat8) > > import qualified Opaleye as O@@ -69,9 +70,9 @@ > personTable' :: Table (Field SqlText, Field SqlInt4, Field SqlText) > (Field SqlText, Field SqlInt4, Field SqlText)-> personTable' = table "personTable" (p3 ( tableField "name"-> , tableField "age"-> , tableField "address" ))+> personTable' = tableWithSchema "myschema" "personTable" (p3 ( tableField "name"+> , tableField "age"+> , tableField "address" )) By default, the table `"personTable"` is looked up in PostgreSQL's default `"public"` schema. If we wanted to specify a different schema we@@ -114,7 +115,7 @@ differences encountered in practice as an Opaleye bug. SELECT name,- age+ age, address FROM personTable @@ -276,38 +277,20 @@ 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!)+Opaleye supports left/right and full outer joins. A left or right+join is expressed by using `optional`. For full outer joins see+`Opaleye.Join`. -Because left joins can change non-nullable fields into nullable-fields 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. -> data BirthdayFieldNullable =-> BirthdayFieldNullable { bdNameFieldNullable :: FieldNullable SqlText-> , bdDayFieldNullable :: FieldNullable SqlDate }->-> instance Default O.Unpackspec BirthdayFieldNullable BirthdayFieldNullable where-> def = BirthdayFieldNullable <$> P.lmap bdNameFieldNullable D.def-> <*> P.lmap bdDayFieldNullable D.def->-> instance Default Opaleye.Internal.Join.NullMaker BirthdayField BirthdayFieldNullable where-> def = BirthdayFieldNullable <$> P.lmap bdNameField D.def-> <*> P.lmap bdDayField D.def--Again, this is all derivable using `Generic` or Template Haskell, if-someone would take the time to implement it.--A left join is expressed by specifying the two tables to join and the-join condition.- > personBirthdayLeftJoin :: Select ((Field SqlText, Field SqlInt4, Field SqlText),-> BirthdayFieldNullable)-> personBirthdayLeftJoin = leftJoin personSelect birthdaySelect eqName-> where eqName ((name, _, _), birthdayRow) =-> name .== bdNameField birthdayRow+> MaybeFields BirthdayField)+> personBirthdayLeftJoin = do+> personRow@(name, _, _) <- personSelect+> mBirthdayRow <- optional $ do+> birthdayRow <- birthdaySelect+> where_ (name .== bdNameField birthdayRow)+> pure birthdayRow+> pure (personRow, mBirthdayRow) The generated SQL is
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2014-2018 Purely Agile Limited; 2019-2021 Tom Ellis+Copyright (c) 2014-2018 Purely Agile Limited; 2019-2026 Tom Ellis All rights reserved.
README.md view
@@ -1,4 +1,4 @@-# Brief introduction to Opaleye [](https://hackage.haskell.org/package/opaleye) [](https://github.com/tomjaguarpaw/haskell-opaleye/actions)+# Brief introduction to Opaleye [](https://hackage.haskell.org/package/opaleye)[](https://www.stackage.org/package/opaleye)[](https://github.com/tomjaguarpaw/haskell-opaleye/actions) Opaleye is a Haskell library that provides an SQL-generating embedded domain specific language for targeting Postgres. You need Opaleye if@@ -12,7 +12,7 @@ > "We use it for most of our DB code. It's very flexible and almost always as performant as manually written queries" – [Adam- Bergmark](http://ircbrowse.net/browse/haskell?id=22634197×tamp=1460980502#t1460980502),+ Bergmark](https://github.com/bergmark), [Silk.co](http://www.silk.co/) > "Opaleye is absolutely fantastic. It has been solid in production@@ -123,7 +123,7 @@ for six months, and this policy has not been changed to the contrary, then full ownership of the project, including the GitHub repository, Hackage upload rights, and the right to amend this backup maintainers-policy passes to Joe Hermaszewski (@expipiplus1).+policy passes to Ellie Hermaszewska (@expipiplus1). # Contributors
Test/Opaleye/Test/Arbitrary.hs view
@@ -13,9 +13,10 @@ import Opaleye.Test.Fields import qualified Opaleye as O+import qualified Opaleye.Exists as OE import qualified Opaleye.Join as OJ -import Control.Applicative (pure, (<$>), (<*>), liftA2)+import Control.Applicative (liftA2) import qualified Control.Arrow as Arrow import Control.Arrow ((<<<)) import Control.Category ((.), id)@@ -301,7 +302,7 @@ arbitrarySelectRecurse1 = arbitraryG (fmap ArbitrarySelect) [- -- I'm not sure this is neccessary anymore. It should be covered by+ -- I'm not sure this is necessary anymore. It should be covered by -- other generation pathways. map (\fg size -> fg <*> arbitrarySelectArr size) [ pure (<<< pure emptyChoices) ]@@ -447,13 +448,13 @@ TQ.oneof [ do ArbitraryHaskellsList l <- TQ.arbitrary- return (fmap fieldsList (O.valuesSafe (fmap O.toFields l)))+ return (fmap fieldsList (O.values (fmap O.toFields l))) , -- We test empty lists of values separately, because we -- used to not support them do s <- TQ.choose (0, 5) l <- TQ.vectorOf s (pure ())- return (fmap (const emptyChoices) (O.valuesSafe l))+ return (fmap (const emptyChoices) (O.values l)) ] ] @@ -470,7 +471,7 @@ genSelectMapper :: [TQ.Gen (O.Select Fields -> O.Select Fields)] genSelectMapper = [ do- return (O.distinctExplicit distinctFields)+ return (O.distinctExplicit unpackFields distinctFields) , do ArbitraryPositiveInt l <- TQ.arbitrary return (O.limit l)@@ -480,9 +481,8 @@ , do o <- TQ.arbitrary return (O.orderBy (arbitraryOrder o))- , do- return (O.aggregate aggregateFields)+ return (O.aggregateExplicit unpackFields aggregateFields) , do let q' q = P.dimap (\_ -> fst . firstBoolOrTrue (O.sqlBool True)) (fieldsList@@ -492,6 +492,15 @@ . fmap listFields) (O.optionalRestrictExplicit unpackFields q) return q'+ , do+ thisLabel <- TQ.arbitrary+ pure $ \select -> do+ O.label' thisLabel+ select+ , do+ pure $ \select -> do+ exists <- OE.exists select+ pure (Choices [Left (CBool exists)]) ] genSelectMapper2 :: [TQ.Gen (O.Select Fields -> O.Select Fields@@ -508,16 +517,14 @@ return (arbitraryBinary binaryOperation) ] where arbitraryBinary binaryOperation q1 q2 =- (fmap fieldsList+ fmap fieldsList (binaryOperation (fmap listFields q1)- (fmap listFields q2)))+ (fmap listFields q2)) genSelectArrMapper :: [TQ.Gen (O.SelectArr a Fields -> O.SelectArr a Fields)] genSelectArrMapper =- [ do- thisLabel <- TQ.arbitrary- return (O.label thisLabel)+ [ ] genSelectArrMaybeMapper :: [TQ.Gen (O.SelectArr a Fields
Test/Opaleye/Test/Fields.hs view
@@ -18,7 +18,6 @@ import qualified Opaleye.Internal.Values as OV import Control.Arrow ((>>>))-import Control.Applicative (pure) import qualified Data.Profunctor.Product.Default as D import qualified Data.Profunctor as P import qualified Data.Profunctor.Product as PP
Test/QuickCheck.hs view
@@ -20,7 +20,6 @@ import qualified Opaleye.Exists as OE import qualified Database.PostgreSQL.Simple as PGS-import Control.Applicative (Applicative, pure, (<$>), (<*>)) import qualified Control.Arrow as Arrow import Control.Arrow ((<<<)) import Control.Category (Category, (.), id)@@ -433,7 +432,7 @@ distinct :: ArbitrarySelect -> Connection -> IO TQ.Property distinct =- compareDenotation' (O.distinctExplicit distinctFields) nub+ compareDenotation' (O.distinctExplicit unpackFields distinctFields) nub -- When we generalise compareDenotation... we can just test --@@ -444,19 +443,19 @@ values :: ArbitraryHaskellsList -> Connection -> IO TQ.Property values (ArbitraryHaskellsList l) =- compareNoSort (denotation (fmap fieldsList (O.valuesSafe (fmap O.toFields l))))+ compareNoSort (denotation (fmap fieldsList (O.values (fmap O.toFields l)))) (pureList (fmap fieldsList l)) -- We test values entries of length two in values, and values entries -- of length zero here. Ideally we would find some way to merge them. valuesEmpty :: [()] -> Connection -> IO TQ.Property valuesEmpty l =- compareNoSort (denotationExplicit D.def (O.valuesSafe l))+ compareNoSort (denotationExplicit D.def (O.values l)) (pureList l) aggregate :: ArbitrarySelect -> Connection -> IO TQ.Property aggregate =- compareDenotationNoSort' (O.aggregate aggregateFields)+ compareDenotationNoSort' (O.aggregateExplicit unpackFields aggregateFields) aggregateDenotation
Test/Test.hs view
@@ -6,14 +6,16 @@ module Main where import qualified Configuration.Dotenv as Dotenv-import Control.Applicative ((<$>), (<*>), (<|>))+import Control.Applicative ((<|>)) import qualified Control.Applicative as A import Control.Arrow ((&&&), (***), (<<<), (>>>)) import qualified Control.Arrow as Arr+import Control.Monad (guard) import qualified Data.Aeson as Json import qualified Data.Function as F+import Data.Int (Int32) import qualified Data.List as L-import Data.Monoid ((<>))+import qualified Data.List.NonEmpty as NE import qualified Data.Ord as Ord import qualified Data.Profunctor as P import qualified Data.Profunctor.Product as PP@@ -23,13 +25,18 @@ import qualified Data.Text as T import qualified Data.Time.Compat as Time import qualified Data.Time.Clock.POSIX.Compat as Time+import Data.Tuple (swap) import qualified Database.PostgreSQL.Simple as PGS import qualified Database.PostgreSQL.Simple.Range as R import GHC.Int (Int64)-import Opaleye (Field, Nullable, Select,+import Opaleye (Field, FieldNullable, Select, SelectArr, (.==), (.>)) import qualified Opaleye as O+import qualified Opaleye.Field as F import qualified Opaleye.Internal.Aggregate as IA+import qualified Opaleye.Internal.Column as O (unColumn)+import qualified Opaleye.Internal.HaskellDB.PrimQuery as O (AggrOp (..), PrimExpr (..))+import qualified Opaleye.Internal.Operators as O (relationValuedExpr) import Opaleye.Internal.RunQuery (DefaultFromField) import Opaleye.Internal.MaybeFields as OM import Opaleye.Internal.Locking as OL@@ -46,7 +53,7 @@ Status ====== -The Hspec tests are very superficial and pretty much the bare mininmum+The Hspec tests are very superficial and pretty much the bare minimum that needs to be tested. The property tests are very thorough, but could be made even more thorough. @@ -87,7 +94,7 @@ -} -required :: String -> O.TableFields (O.Column a) (O.Column a)+required :: String -> O.TableFields (O.Field a) (O.Field a) required = O.requiredTableField twoIntTable :: String@@ -353,8 +360,8 @@ O.restrict -< fst t .== 1 Arr.returnA -< t -testExists :: Test-testExists = it "restricts the rows returned with EXISTS" $+testRestrictExists :: Test+testRestrictExists = it "restricts the rows returned with EXISTS" $ select `selectShouldReturnSorted` filter ((== 1) . fst) (L.sort table1data) where select = proc () -> do t <- table1Q -< ()@@ -363,8 +370,8 @@ O.restrict -< fst t' .> fst t) -< t Arr.returnA -< t -testNotExists :: Test-testNotExists = it "restricts the rows returned with NOT EXISTS" $+testRestrictNotExists :: Test+testRestrictNotExists = it "restricts the rows returned with NOT EXISTS" $ select `selectShouldReturnSorted` filter ((== 2) . fst) (L.sort table1data) where select = proc () -> do t <- table1Q -< ()@@ -443,7 +450,7 @@ it "distinct on ()" $ let p = const ()- q = O.distinctOnCorrect p table1Q+ q = O.distinctOn p table1Q in distinctOn p q it "distinct on (col1)" $ let p = fst@@ -461,7 +468,7 @@ it "distinct on () order by col1" $ let proj = const () ord = f1- q = O.distinctOnByCorrect proj (O.asc ord) $ O.values pgTriples+ q = O.distinctOnBy proj (O.asc ord) $ O.values pgTriples in distinctOnBy proj ord q it "distinct on (col1) order by col2" $ let proj = f1@@ -506,8 +513,10 @@ testAggregate0 :: Test testAggregate0 = it "" $ O.aggregate (PP.p2 (O.sum, O.sumInt4))- (O.keepWhen (const (O.sqlBool False))- <<< table1Q)+ (proc () -> do+ r <- table1Q -< ()+ O.restrict -< O.sqlBool False+ Arr.returnA -< r) `selectShouldReturnSorted` ([] :: [(Int, Int64)]) testAggregateFunction :: Test@@ -609,6 +618,36 @@ ] sortedData = L.sortBy (Ord.comparing snd) table7data ++testStringArrayAggregateOrderedDistinct :: Test+testStringArrayAggregateOrderedDistinct = it "" $ q `selectShouldReturnSorted` expected+ where q =+ O.aggregateOrdered+ (O.asc snd)+ (PP.p2 (O.arrayAgg, O.distinctAggregator . O.stringAgg . O.sqlString $ ","))+ table7Q+ expected = [ ( map fst sortedData+ , L.intercalate "," $ map NE.head $ NE.group $ map snd sortedData+ )+ ]+ sortedData = L.sortBy (Ord.comparing snd) table7data++-- See+--+-- https://github.com/tomjaguarpaw/haskell-opaleye/pull/578#issuecomment-1782638274+testStringArrayAggregateOrderedDistinctDuplicateFields :: Test+testStringArrayAggregateOrderedDistinctDuplicateFields = xit "" $ q `selectShouldReturnSorted` expected+ where q =+ O.aggregateOrdered+ (O.asc (\x -> snd x O..++ snd x))+ (PP.p2 (O.arrayAgg, O.distinctAggregator . O.stringAgg . O.sqlString $ ","))+ table7Q+ expected = [ ( map fst sortedData+ , L.intercalate "," $ map NE.head $ NE.group $ map snd sortedData+ )+ ]+ sortedData = L.sortBy (Ord.comparing snd) table7data+ -- | Using orderAggregate you can apply different orderings to -- different aggregates. @@ -642,7 +681,10 @@ testCountRows0 :: Test testCountRows0 = it "" $ q `selectShouldReturnSorted` [0 :: Int64]- where q = O.countRows (O.keepWhen (const (O.sqlBool False)) <<< table7Q)+ where q = O.countRows (proc () -> do+ r <- table7Q -< ()+ O.restrict -< O.sqlBool False+ Arr.returnA -< r) testCountRows3 :: Test testCountRows3 = it "" $ q `selectShouldReturnSorted` [3 :: Int64]@@ -697,6 +739,38 @@ testOffsetLimit :: Test testOffsetLimit = it "" $ limitOrderShouldMatch (O.offset 2 . O.limit 2) (drop 2 . take 2) +limitFieldOrderShouldMatch+ :: (Field O.SqlInt8 -> Select (Field O.SqlInt4, Field O.SqlInt4) -> Select (Field O.SqlInt4, Field O.SqlInt4))+ -> (Int -> [(Int, Int)] -> [(Int, Int)])+ -> (PGS.Connection -> Expectation)+limitFieldOrderShouldMatch olQ ol =+ testH+ (nsQ >>= \n -> olQ n (orderQ table1Q))+ ((ns >>= \n -> ol n (order table1data)) `shouldBe`)+ where+ orderQ = O.orderBy (O.desc snd)+ order = L.sortBy (flip (Ord.comparing snd))+ ns = [1, 2, 3, 4]+ nsQ = O.values $ fromIntegral <$> ns++testLimitField :: Test+testLimitField = it "" $ limitFieldOrderShouldMatch O.limitField take++testOffsetField :: Test+testOffsetField = it "" $ limitFieldOrderShouldMatch O.offsetField drop++testLimitFieldOffset :: Test+testLimitFieldOffset = it "" $+ limitFieldOrderShouldMatch+ (\n -> O.limitField n . O.offsetField n)+ (\n -> take n . drop n)++testOffsetFieldLimit :: Test+testOffsetFieldLimit = it "" $+ limitFieldOrderShouldMatch+ (\n -> O.offsetField n . O.limitField n)+ (\n -> drop n . take n)+ testDistinctAndAggregate :: Test testDistinctAndAggregate = it "" $ q `selectShouldReturnSorted` expectedResult where q = O.distinct table1Q@@ -724,7 +798,7 @@ testDoubleLeftJoin :: Test testDoubleLeftJoin = it "" $ testDoubleH lj [(1 :: Int, Just (1 :: Int))] where lj :: Select (Field O.SqlInt4)- -> Select (Field O.SqlInt4, Field (Nullable O.SqlInt4))+ -> Select (Field O.SqlInt4, FieldNullable O.SqlInt4) lj q = O.leftJoin q q (uncurry (.==)) testDoubleValues :: Test@@ -737,7 +811,7 @@ where u q = q `O.unionAll` q aLeftJoin :: Select ((Field O.SqlInt4, Field O.SqlInt4),- (Field (Nullable O.SqlInt4), Field (Nullable O.SqlInt4)))+ (FieldNullable O.SqlInt4, FieldNullable O.SqlInt4)) aLeftJoin = O.leftJoin table1Q table3Q (\(l, r) -> fst l .== fst r) testLeftJoin :: Test@@ -751,9 +825,9 @@ testLeftJoinNullable :: Test testLeftJoinNullable = it "" $ testH q (`shouldBe` expected) where q :: Select ((Field O.SqlInt4, Field O.SqlInt4),- ((Field (Nullable O.SqlInt4), Field (Nullable O.SqlInt4)),- (Field (Nullable O.SqlInt4),- Field (Nullable O.SqlInt4))))+ ((FieldNullable O.SqlInt4, FieldNullable O.SqlInt4),+ (FieldNullable O.SqlInt4,+ FieldNullable O.SqlInt4))) q = O.leftJoin table3Q aLeftJoin cond cond (x, y) = fst x .== fst (fst y)@@ -763,20 +837,6 @@ , ((1, 50), ((Just 1, Just 100), (Just 1, Just 50))) , ((1, 50), ((Just 1, Just 200), (Just 1, Just 50))) ] -testLeftJoinF :: Test-testLeftJoinF = it "" $ testH q (`shouldBe` expected)- where q = O.leftJoinF (,)- (\x -> (x, (-1, -2)))- (\l r -> fst l .== fst r)- table1Q- table3Q-- expected :: [((Int, Int), (Int, Int))]- expected = [ ((1, 100), (1, 50))- , ((1, 100), (1, 50))- , ((1, 200), (1, 50))- , ((2, 300), (-1, -2)) ]- testThreeWayProduct :: Test testThreeWayProduct = it "" $ testH q (`shouldBe` expected) where q = A.liftA3 (,,) table1Q table2Q table3Q@@ -817,6 +877,36 @@ testTableFunctor = it "" $ testH (O.selectTable table1F) (result `shouldBe`) where result = fmap (\(col1, col2) -> (col1 + col2, col1 - col2)) table1data +recursive = O.withRecursive table1Q $ \(n, x) -> do+ O.where_ (n O..< 5)+ pure (n + 1, x + 1)++testWithRecursive :: Test+testWithRecursive = it "with recursive" $ testH recursive (`shouldBe` expected)+ where expected = withRecursive [] table1data $ \(n, x) -> do+ guard (n < 5)+ pure (n + 1, x + 1)+ withRecursive r s f =+ let r' = s ++ (r >>= f)+ in if r' == r then r else withRecursive r' s f++testWith :: Test+testWith = it "with" $ testH with (`shouldBe` expected)+ where with = O.with table1Q $ \t -> (,) <$> t <*> table2Q+ expected = (,) <$> table1data <*> table2data++testNestedWith :: Test+testNestedWith = it "with nested within with" $ testH with (`shouldBe` expected)+ where+ with = O.with table1Q $ \t -> O.with table2Q $ \u -> (,) <$> t <*> u+ expected = (,) <$> table1data <*> table2data++testWithRebind :: Test+testWithRebind = it "with (rebinding)" $ testH with (`shouldBe` expected)+ where+ with = O.with (fmap swap table1Q) $ \t -> (,) <$> t <*> table2Q+ expected = (,) <$> fmap swap table1data <*> table2data+ -- TODO: This is getting too complicated testUpdate :: Test testUpdate = it "" $ \conn -> do@@ -895,11 +985,11 @@ extras <- O.runInsert_ conn O.Insert { O.iTable = table10 , O.iRows = conflictsT , O.iReturning = O.rReturning id- , O.iOnConflict = Just O.DoNothing }+ , O.iOnConflict = Just O.doNothing } moreExtras <- O.runInsert_ conn O.Insert { O.iTable = table10 , O.iRows = moreConflictsT , O.iReturning = O.rCount- , O.iOnConflict = Just O.DoNothing }+ , O.iOnConflict = Just O.doNothing } returned `shouldBe` afterInsert extras `shouldBe` afterConflicts@@ -1044,6 +1134,15 @@ testH (A.pure (O.sqlElem 999 (O.sqlArray O.sqlInt4 [5,6,7]))) (`shouldBe` [False]) +testSqlElemAny :: Test+testSqlElemAny = do+ it "checks presence of the element (SqlInt4)" $+ testH (A.pure (O.sqlElemAny 5 (O.sqlArray O.sqlInt4 [5,6,7])))+ (`shouldBe` [True])+ it "checks absence of the element (SqlInt4)" $+ testH (A.pure (O.sqlElemAny 999 (O.sqlArray O.sqlInt4 [5,6,7])))+ (`shouldBe` [False])+ type JsonTest a = SpecWith (Select (Field a) -> PGS.Connection -> Expectation) -- Test opaleye's equivalent of c1->'c' testJsonGetFieldValue :: (O.SqlIsJson a, DefaultFromField a Json.Value)@@ -1068,10 +1167,13 @@ testRestrictWithJsonOp dataSelect = it "restricts the rows returned by checking equality with a value extracted using JSON operator" $ testH select (`shouldBe` table8data) where select = dataSelect >>> proc col1 -> do t <- table8Q -< ()- O.restrict -< (O.toNullable col1 O..->> O.sqlStrictText "c")- .== O.toNullable (O.sqlStrictText "21")+ O.restrict -< nonNullOrFalse (O.toNullable col1 O..->> O.sqlStrictText "c") $ \x1 ->+ nonNullOrFalse (O.toNullable (O.sqlStrictText "21")) $ \x2 ->+ x1 .== x2 Arr.returnA -< t + nonNullOrFalse = flip (F.matchNullable (O.sqlBool False))+ -- Test opaleye's equivalent of c1->'a'->2 testJsonGetArrayValue :: (O.SqlIsJson a, DefaultFromField a Json.Value) => Select (Field a) -> Test@@ -1279,7 +1381,7 @@ it "MaybeFields equality" $ testH query2 (`shouldBe` [True]) where nothing_ = OM.nothingFields :: MaybeFields () query :: Select (MaybeFields (Field O.SqlInt4))- query = O.distinct (O.valuesSafe [ fmap (const 0) nothing_+ query = O.distinct (O.values [ fmap (const 0) nothing_ , fmap (const 1) nothing_ ]) query2 :: Select (Field O.SqlBool) query2 = pure ((fmap (const (0 :: Field O.SqlInt4)) nothing_)@@ -1392,6 +1494,59 @@ (realToFrac (Time.ctTime c :: Time.NominalDiffTime) :: Time.DiffTime) + Time.timeOfDayToTime t +testUnnest :: Test+testUnnest = do+ it "unnest" $ testH query (`shouldBe` expectation)+ where query :: Select (Field O.SqlInt4, Field O.SqlText)+ query = O.relationValuedExpr (const expr)+ where+ expr = O.FunExpr "unnest" [O.unColumn as', O.unColumn bs']+ where+ as' :: Field (O.SqlArray O.SqlInt4)+ as' = O.toFields as+ bs' :: Field (O.SqlArray O.SqlText)+ bs' = O.toFields bs++ as :: [Int32]+ as = [1, 2, 3]++ bs :: [T.Text]+ bs = ["a", "b", "c"]++ expectation :: [(Int32, T.Text)]+ expectation = zipWith (,) as bs++testSetAggregate :: Test+testSetAggregate = do+ it "set aggregate (percentile_cont)" $ testH query (`shouldBe` [expectation])+ where query :: Select (Field O.SqlFloat8)+ query = O.aggregate median (O.values as)++ median :: IA.Aggregator (Field O.SqlFloat8) (Field O.SqlFloat8)+ median = percentileCont 0.5++ percentileCont :: O.Field O.SqlFloat8 -> IA.Aggregator (Field O.SqlFloat8) (Field O.SqlFloat8)+ percentileCont fraction = IA.withinGroup (O.asc id) (P.lmap (const fraction) aggr)+ where+ aggr = IA.makeAggr (O.AggrOther "percentile_cont")++ as :: [Field O.SqlFloat8]+ as = [1, 2, 3, 4]++ expectation :: Double+ expectation = 2.5++-- See https://github.com/tomjaguarpaw/haskell-opaleye/issues/621+testSelectCaseNull :: Test+testSelectCaseNull = do+ it "" $ testH query (`shouldBe` expectation)+ where query :: Select (O.FieldNullable O.SqlInt4)+ -- Fails with null instead of typedNull+ query = O.values [O.toNullable 0, O.ifThenElse (O.toFields True) O.typedNull O.typedNull]++ expectation :: [Maybe Int]+ expectation = [Just 0, Nothing]+ main :: IO () main = do let envVarName = "POSTGRES_CONNSTRING"@@ -1405,12 +1560,12 @@ let mconnectString = connectStringEnvVar <|> connectStringDotEnv - connectString <- maybe- (fail ("Set " ++ envVarName ++ " environment variable\n"- ++ "For example " ++ envVarName ++ "='user=tom dbname=opaleye_test "- ++ "host=localhost port=25433 password=tom'"))- (pure . String.fromString)- mconnectString+ connectString <- case mconnectString of+ Nothing ->+ fail ("Set " ++ envVarName ++ " environment variable\n"+ ++ "For example " ++ envVarName ++ "='user=tom dbname=opaleye_test "+ ++ "host=localhost port=25433 password=tom'")+ Just s -> pure (String.fromString s) conn <- PGS.connectPostgreSQL connectString @@ -1449,8 +1604,8 @@ testSelect testProduct testRestrict- testExists- testNotExists+ testRestrictExists+ testRestrictNotExists testIn testNum testDiv@@ -1470,8 +1625,11 @@ testOverwriteAggregateOrdered testMultipleAggregateOrdered testStringArrayAggregateOrdered+ testStringArrayAggregateOrderedDistinct+ testStringArrayAggregateOrderedDistinctDuplicateFields testDistinctAndAggregate testDoubleAggregate+ testSetAggregate describe "distinct" $ do testDistinct describe "distinct on"@@ -1489,6 +1647,11 @@ testOffset testLimitOffset testOffsetLimit+ describe "limit field" $ do+ testLimitField+ testOffsetField+ testLimitFieldOffset+ testOffsetFieldLimit describe "double" $ do testDoubleDistinct testDoubleLeftJoin@@ -1504,11 +1667,11 @@ testArrayAppend testArrayPosition testSqlElem+ testSqlElemAny describe "joins" $ do testLeftJoin testLeftJoinNullable testThreeWayProduct- testLeftJoinF describe "json" $ jsonTests table8Q describe "jsonb" $ do jsonTests table9Q@@ -1530,6 +1693,7 @@ testUpdate testDeleteReturning testInsertConflict+ testSelectCaseNull describe "range" $ do testRangeOverlap testRangeDateOverlap@@ -1554,3 +1718,10 @@ testAddIntervalFromTimestampToTimestamp testAddIntervalFromTimestamptzToTimestamptz testAddIntervalFromTimeToTime+ describe "with" $ do+ testWithRecursive+ testWith+ testNestedWith+ testWithRebind+ describe "relation valued exprs" $ do+ testUnnest
opaleye.cabal view
@@ -1,6 +1,6 @@ name: opaleye-copyright: Copyright (c) 2014-2018 Purely Agile Limited; 2019-2021 Tom Ellis-version: 0.7.6.2+copyright: Copyright (c) 2014-2018 Purely Agile Limited; 2019-2026 Tom Ellis+version: 0.10.8.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@@ -9,15 +9,14 @@ bug-reports: https://github.com/tomjaguarpaw/haskell-opaleye/issues license: BSD3 license-file: LICENSE-author: Purely Agile-maintainer: Purely Agile+maintainer: Tom Ellis category: Database build-type: Simple cabal-version: 1.18 extra-doc-files: README.md CHANGELOG.md *.md-tested-with: GHC==9.0, GHC==8.10, GHC==8.8, GHC==8.6, GHC==8.4, GHC==8.2, GHC==8.0+tested-with: GHC==9.12, GHC==9.10, GHC==9.8, GHC==9.6, GHC==9.4, GHC==9.2, GHC==9.0, GHC==8.10, GHC==8.8 source-repository head type: git@@ -25,48 +24,47 @@ library default-language: Haskell2010+ default-extensions: MultiParamTypeClasses,+ FlexibleContexts,+ FlexibleInstances hs-source-dirs: src build-depends:- aeson >= 0.6 && < 1.6- , base >= 4.9 && < 5+ aeson >= 0.6 && < 2.3+ , base >= 4.9 && < 4.22 , base16-bytestring >= 0.1.1.6 && < 1.1 , case-insensitive >= 1.2 && < 1.3- , bytestring >= 0.10 && < 0.11+ , bytestring >= 0.10 && < 0.13 , contravariant >= 1.2 && < 1.6- , postgresql-simple >= 0.6 && < 0.7+ , postgresql-simple >= 0.6 && < 0.8 , pretty >= 1.1.1.0 && < 1.2- , product-profunctors >= 0.8.0.0 && < 0.12+ , product-profunctors >= 0.11.0.3 && < 0.12 , profunctors >= 4.0 && < 5.7 , scientific >= 0.3 && < 0.4- , semigroups >= 0.13 && < 0.20- , text >= 0.11 && < 1.3- , transformers >= 0.3 && < 0.6+ , semigroups >= 0.13 && < 0.21+ , text >= 0.11 && < 2.2+ , transformers >= 0.3 && < 0.7 , time-compat >= 1.9.5 && < 1.12 , time-locale-compat >= 0.1 && < 0.2- , uuid >= 1.3 && < 1.4+ , uuid-types >= 1.0.5 && < 1.1 , void >= 0.4 && < 0.8 exposed-modules: Opaleye, Opaleye.Adaptors, Opaleye.Aggregate, Opaleye.Binary, Opaleye.Column,- Opaleye.Constant, Opaleye.Distinct, Opaleye.Experimental.Enum, Opaleye.Exists, Opaleye.Field, Opaleye.FunctionalJoin,+ Opaleye.Inferrable, Opaleye.Join, Opaleye.Label, Opaleye.Lateral, Opaleye.Manipulation,- Opaleye.Map, Opaleye.MaybeFields, Opaleye.Operators, Opaleye.Order,- Opaleye.PGTypes,- Opaleye.QueryArr,- Opaleye.RunQuery, Opaleye.RunSelect, Opaleye.Select, Opaleye.Sql,@@ -75,6 +73,8 @@ Opaleye.ToFields, Opaleye.TypeFamilies, Opaleye.Values,+ Opaleye.With,+ Opaleye.Window, Opaleye.Internal.Aggregate, Opaleye.Internal.Binary, Opaleye.Internal.Constant,@@ -103,17 +103,17 @@ Opaleye.Internal.RunQueryExternal, Opaleye.Internal.Sql, Opaleye.Internal.Table,- Opaleye.Internal.TableMaker, Opaleye.Internal.Tag, Opaleye.Internal.TypeFamilies, Opaleye.Internal.Unpackspec,- Opaleye.Internal.Values+ Opaleye.Internal.Values,+ Opaleye.Internal.Window, Opaleye.Internal.HaskellDB.PrimQuery, Opaleye.Internal.HaskellDB.Sql, Opaleye.Internal.HaskellDB.Sql.Default, Opaleye.Internal.HaskellDB.Sql.Generate, Opaleye.Internal.HaskellDB.Sql.Print- ghc-options: -Wall -Wcompat+ ghc-options: -Wall -Wcompat -Wno-unticked-promoted-constructors test-suite test default-language: Haskell2010@@ -128,7 +128,7 @@ Wrapped hs-source-dirs: Test build-depends:- aeson >= 0.6 && < 1.6,+ aeson, base >= 4 && < 5, bytestring, containers,@@ -140,9 +140,8 @@ product-profunctors, QuickCheck, semigroups,- text >= 0.11 && < 1.3,+ text >= 0.11 && < 2.2, time-compat,- uuid, transformers, hspec, hspec-discover,
src/Opaleye.hs view
@@ -1,3 +1,5 @@+-- {-# OPTIONS_HADDOCK ignore-exports #-}+ -- | An SQL-generating DSL targeting PostgreSQL. Allows Postgres -- queries to be written within Haskell in a typesafe and composable -- fashion.@@ -17,7 +19,6 @@ , module Opaleye.Aggregate , module Opaleye.Binary , module Opaleye.Column- , module Opaleye.Internal.Constant , module Opaleye.Distinct , module Opaleye.Field , module Opaleye.FunctionalJoin@@ -28,9 +29,6 @@ , module Opaleye.MaybeFields , module Opaleye.Operators , module Opaleye.Order- , module Opaleye.Internal.PGTypesExternal- , module Opaleye.QueryArr- , module Opaleye.RunQuery , module Opaleye.RunSelect , module Opaleye.Sql , module Opaleye.Select@@ -38,43 +36,32 @@ , module Opaleye.Table , module Opaleye.ToFields , module Opaleye.Values+ , module Opaleye.With+ , module Opaleye.Window ) where import Opaleye.Adaptors import Opaleye.Aggregate import Opaleye.Binary import Opaleye.Column-import Opaleye.Internal.Constant- hiding (toFields)+ hiding (null,+ isNull) import Opaleye.Distinct import Opaleye.Field- hiding (null,- isNull,- matchNullable,- fromNullable,- toNullable,- maybeToNullable) import Opaleye.FunctionalJoin import Opaleye.Join- hiding (optional) import Opaleye.Label import Opaleye.Lateral import Opaleye.Manipulation import Opaleye.MaybeFields- hiding (optional) import Opaleye.Operators import Opaleye.Order-import Opaleye.Internal.PGTypesExternal-import Opaleye.QueryArr-import Opaleye.RunQuery import Opaleye.RunSelect- hiding (foldForward,- closeCursor,- declareCursor,- declareCursorExplicit) import Opaleye.Select import Opaleye.Sql import Opaleye.SqlTypes import Opaleye.Table import Opaleye.ToFields import Opaleye.Values+import Opaleye.Window+import Opaleye.With
src/Opaleye/Adaptors.hs view
@@ -63,7 +63,6 @@ Updater, -- * Valuesspec Valuesspec,- ValuesspecSafe, valuesspecField, valuesspecMaybeFields, -- * WithNulls
src/Opaleye/Aggregate.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+ -- | 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@@ -11,10 +14,12 @@ aggregate , aggregateOrdered , distinctAggregator+ , filterWhere , Aggregator -- * Basic 'Aggregator's , groupBy , Opaleye.Aggregate.sum+ , sumInt2 , sumInt4 , sumInt8 , count@@ -25,24 +30,32 @@ , boolOr , boolAnd , arrayAgg+ , arrayAgg_ , jsonAgg , stringAgg -- * Counting rows , countRows+ -- * Explicit+ , aggregateExplicit ) where -import Control.Applicative (pure)+import Control.Arrow (second, (<<<)) import Data.Profunctor (lmap) import qualified Data.Profunctor as P+import qualified Data.Profunctor.Product.Default as D import qualified Opaleye.Internal.Aggregate as A import Opaleye.Internal.Aggregate (Aggregator, orderAggregate)-import qualified Opaleye.Internal.Column as IC+import Opaleye.Internal.MaybeFields (MaybeFields (MaybeFields)) import qualified Opaleye.Internal.QueryArr as Q import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ+import qualified Opaleye.Internal.Operators as O import qualified Opaleye.Internal.PackMap as PM+import Opaleye.Internal.Rebind (rebindExplicit)+import qualified Opaleye.Internal.Tag as Tag+import qualified Opaleye.Internal.Unpackspec as U -import qualified Opaleye.Column as C+import qualified Opaleye.Field as F import qualified Opaleye.Order as Ord import qualified Opaleye.Select as S import qualified Opaleye.SqlTypes as T@@ -78,8 +91,8 @@ -} -- See 'Opaleye.Internal.Sql.aggregate' for details of how aggregating -- by an empty query with no group by is handled.-aggregate :: Aggregator a b -> S.Select a -> S.Select b-aggregate agg q = Q.productQueryArr (A.aggregateU agg . Q.runSimpleQueryArr q)+aggregate :: D.Default U.Unpackspec a a => Aggregator a b -> S.Select a -> S.Select b+aggregate = aggregateExplicit D.def -- | Order the values within each aggregation in `Aggregator` using -- the given ordering. This is only relevant for aggregations that@@ -90,16 +103,35 @@ -- you need different orderings for different aggregations, use -- 'Opaleye.Internal.Aggregate.orderAggregate'. -aggregateOrdered :: Ord.Order a -> Aggregator a b -> S.Select a -> S.Select b+aggregateExplicit :: U.Unpackspec a a' -> Aggregator a' b -> S.Select a -> S.Select b+aggregateExplicit u agg q = Q.productQueryArr $ do+ (a, pq) <- Q.runSimpleSelect (rebindExplicit u <<< q)+ t <- Tag.fresh+ pure (second ($ pq) (A.aggregateU agg (a, t)))++aggregateOrdered :: D.Default U.Unpackspec a a => Ord.Order a -> Aggregator a b -> S.Select a -> S.Select b aggregateOrdered o agg = aggregate (orderAggregate o agg) -- | Aggregate only distinct values distinctAggregator :: Aggregator a b -> Aggregator a b distinctAggregator (A.Aggregator (PM.PackMap pm)) =- A.Aggregator (PM.PackMap (\f c -> pm (f . P.first' (fmap (\(a,b,_) -> (a,b,HPQ.AggrDistinct)))) c))+ A.Aggregator (PM.PackMap (\f c -> pm (f . setDistinct) c))+ where+ setDistinct (HPQ.GroupBy expr) = HPQ.GroupBy expr+ setDistinct (HPQ.Aggregate aggr) =+ HPQ.Aggregate aggr+ { HPQ.aggrDistinct = HPQ.AggrDistinct+ } +-- | Aggregate only rows matching the given predicate+filterWhere+ :: (a -> F.Field T.SqlBool)+ -> Aggregator a b+ -> Aggregator a (MaybeFields b)+filterWhere = A.filterWhereInternal (MaybeFields . O.not . F.isNull)+ -- | Group the aggregation by equality on the input to 'groupBy'.-groupBy :: Aggregator (C.Column a) (C.Column a)+groupBy :: Aggregator (F.Field_ n a) (F.Field_ n a) groupBy = A.makeAggr' Nothing -- | Sum all rows in a group.@@ -107,49 +139,53 @@ -- WARNING! The type of this operation is wrong and will crash at -- runtime when the argument is 'T.SqlInt4' or 'T.SqlInt8'. For those -- use 'sumInt4' or 'sumInt8' instead.-sum :: Aggregator (C.Column a) (C.Column a)-sum = A.makeAggr HPQ.AggrSum+sum :: Aggregator (F.Field a) (F.Field a)+sum = A.unsafeSum -sumInt4 :: Aggregator (C.Column T.SqlInt4) (C.Column T.SqlInt8)-sumInt4 = fmap C.unsafeCoerceColumn Opaleye.Aggregate.sum+sumInt2 :: Aggregator (F.Field T.SqlInt2) (F.Field T.SqlInt8)+sumInt2 = fmap F.unsafeCoerceField Opaleye.Aggregate.sum -sumInt8 :: Aggregator (C.Column T.SqlInt8) (C.Column T.SqlNumeric)-sumInt8 = fmap C.unsafeCoerceColumn Opaleye.Aggregate.sum+sumInt4 :: Aggregator (F.Field T.SqlInt4) (F.Field T.SqlInt8)+sumInt4 = fmap F.unsafeCoerceField Opaleye.Aggregate.sum +sumInt8 :: Aggregator (F.Field T.SqlInt8) (F.Field T.SqlNumeric)+sumInt8 = fmap F.unsafeCoerceField Opaleye.Aggregate.sum+ -- | Count the number of non-null rows in a group.-count :: Aggregator (C.Column a) (C.Column T.SqlInt8)+count :: Aggregator (F.Field a) (F.Field 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.SqlInt8)-countStar = lmap (const (0 :: C.Column T.SqlInt4)) count+countStar :: Aggregator a (F.Field T.SqlInt8)+countStar = lmap (const (0 :: F.Field T.SqlInt4)) count -- | Average of a group-avg :: Aggregator (C.Column T.SqlFloat8) (C.Column T.SqlFloat8)-avg = A.makeAggr HPQ.AggrAvg+avg :: Aggregator (F.Field T.SqlFloat8) (F.Field T.SqlFloat8)+avg = A.unsafeAvg -- | Maximum of a group-max :: Ord.SqlOrd a => Aggregator (C.Column a) (C.Column a)-max = A.makeAggr HPQ.AggrMax+max :: Ord.SqlOrd a => Aggregator (F.Field a) (F.Field a)+max = A.unsafeMax -- | Maximum of a group-min :: Ord.SqlOrd a => Aggregator (C.Column a) (C.Column a)-min = A.makeAggr HPQ.AggrMin+min :: Ord.SqlOrd a => Aggregator (F.Field a) (F.Field a)+min = A.unsafeMin -boolOr :: Aggregator (C.Column T.SqlBool) (C.Column T.SqlBool)+boolOr :: Aggregator (F.Field T.SqlBool) (F.Field T.SqlBool) boolOr = A.makeAggr HPQ.AggrBoolOr -boolAnd :: Aggregator (C.Column T.SqlBool) (C.Column T.SqlBool)+boolAnd :: Aggregator (F.Field T.SqlBool) (F.Field T.SqlBool) boolAnd = A.makeAggr HPQ.AggrBoolAnd -arrayAgg :: Aggregator (C.Column a) (C.Column (T.SqlArray a))-arrayAgg = A.makeAggr HPQ.AggrArr+arrayAgg :: Aggregator (F.Field a) (F.Field (T.SqlArray a))+arrayAgg = P.dimap F.unsafeCoerceField F.unsafeCoerceField arrayAgg_ -{-|-Aggregates values, including nulls, as a JSON array+arrayAgg_ :: Aggregator (F.Field_ n a) (F.Field (T.SqlArray_ n a))+arrayAgg_ = A.makeAggr HPQ.AggrArr -An example usage:+{-|+Aggregates values as a JSON array. An example usage: @ import qualified Opaleye as O@@ -166,12 +202,15 @@ @"[{\\"summary\\" : \\"xy\\", \\"details\\" : \\"a\\"}, {\\"summary\\" : \\"z\\", \\"details\\" : \\"a\\"}, {\\"summary\\" : \\"more text\\", \\"details\\" : \\"a\\"}]"@ -}-jsonAgg :: Aggregator (C.Column a) (C.Column T.SqlJson)+jsonAgg :: Aggregator (F.Field a) (F.Field T.SqlJson) jsonAgg = A.makeAggr HPQ.JsonArr -stringAgg :: C.Column T.SqlText- -> Aggregator (C.Column T.SqlText) (C.Column T.SqlText)-stringAgg = A.makeAggr' . Just . HPQ.AggrStringAggr . IC.unColumn+stringAgg :: F.Field T.SqlText+ -> Aggregator (F.Field T.SqlText) (F.Field T.SqlText)+stringAgg delimiter =+ A.makeAggrExplicit+ (U.unpackspecField <* lmap (const delimiter) U.unpackspecField)+ HPQ.AggrStringAggr -- | Count the number of rows in a query. This is different from -- 'aggregate' 'count' because it always returns exactly one row, even@@ -183,13 +222,13 @@ -- changing the AST though, so I'm not too keen. -- -- See https://github.com/tomjaguarpaw/haskell-opaleye/issues/162-countRows :: S.Select a -> S.Select (C.Column T.SqlInt8)-countRows = fmap (C.fromNullable 0)+countRows :: S.Select a -> S.Select (F.Field T.SqlInt8)+countRows = fmap (F.fromNullable 0) . fmap snd . (\q -> J.leftJoin (pure ()) (aggregate count q) (const (T.sqlBool True)))- . fmap (const (0 :: C.Column T.SqlInt4))+ . fmap (const (0 :: F.Field 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
src/Opaleye/Binary.hs view
@@ -10,7 +10,7 @@ -- -> S.Select (Field a, Field b) -- @ ----- Assuming the @makeAdaptorAndInstance@ splice has been run for the product type @Foo@:+-- Assuming the @makeAdaptorAndInstanceInferrable@ splice has been run for the product type @Foo@: -- -- @ -- unionAll :: S.Select (Foo (Field a) (Field b) (Field c))@@ -32,8 +32,6 @@ -- @Control.Applicative.Alternative@ instance but it fails to work -- only because of the typeclass constraint it has. -{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-}- module Opaleye.Binary (-- * Binary operations unionAll, union,@@ -114,6 +112,6 @@ exceptExplicit = B.sameTypeBinOpHelper PQ.Except binaryspecField :: (B.Binaryspec- (Opaleye.Internal.Column.Column a)- (Opaleye.Internal.Column.Column a))+ (Opaleye.Internal.Column.Field_ n a)+ (Opaleye.Internal.Column.Field_ n a)) binaryspecField = B.binaryspecColumn
src/Opaleye/Column.hs view
@@ -1,25 +1,16 @@ {-# OPTIONS_GHC -fno-warn-duplicate-exports #-}--- | Do not use. Will be deprecated in version 0.8. Use--- "Opaleye.Field" instead.------ Functions for working directly with 'Column's.+-- | Functions for working directly with 'Column's. -- -- Please note that numeric 'Column' types are instances of 'Num', so -- you can use '*', '/', '+', '-' on them.------ 'Column' will be renamed to 'Opaleye.Field.Field_' in version 0.8,--- so you might want to use the latter as much as you can. -module Opaleye.Column (-- * 'Column'+module Opaleye.Column {-# DEPRECATED "Use \"Opaleye.Field\" instead. Will be removed in version 0.11." #-}+ (-- * 'Column' Column, -- * Working with @NULL@ Nullable, null, isNull,- matchNullable,- fromNullable,- toNullable,- maybeToNullable, -- * Unsafe operations unsafeCast, unsafeCoerceColumn,@@ -29,6 +20,7 @@ import Opaleye.Internal.Column (Column, Nullable, unsafeCoerceColumn, unsafeCast, unsafeCompositeField)+import qualified Opaleye.Field as F import qualified Opaleye.Internal.Column as C import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ import qualified Opaleye.Internal.PGTypesExternal as T@@ -36,40 +28,11 @@ -- | A NULL of any type null :: Column (Nullable a)-null = C.Column (HPQ.ConstExpr HPQ.NullLit)+null = F.null -- | @TRUE@ if the value of the column is @NULL@, @FALSE@ otherwise. isNull :: Column (Nullable a) -> Column T.PGBool isNull = C.unOp HPQ.OpIsNull---- | If the @Column (Nullable a)@ is NULL then return the @Column b@--- otherwise map the underlying @Column a@ using the provided--- function.------ The Opaleye equivalent of 'Data.Maybe.maybe'.-matchNullable :: Column b -> (Column a -> Column b) -> Column (Nullable a)- -> Column b-matchNullable replacement f x = C.unsafeIfThenElse (isNull x) replacement- (f (unsafeCoerceColumn x))---- | If the @Column (Nullable a)@ is NULL then return the provided--- @Column a@ otherwise return the underlying @Column a@.------ The Opaleye equivalent of 'Data.Maybe.fromMaybe' and very similar--- to PostgreSQL's @COALESCE@.-fromNullable :: Column a -> Column (Nullable a) -> Column a-fromNullable = flip matchNullable id---- | Treat a column as though it were nullable. This is always safe.------ The Opaleye equivalent of 'Data.Maybe.Just'.-toNullable :: Column a -> Column (Nullable a)-toNullable = unsafeCoerceColumn---- | If the argument is 'Data.Maybe.Nothing' return NULL otherwise return the--- provided value coerced to a nullable type.-maybeToNullable :: Maybe (Column a) -> Column (Nullable a)-maybeToNullable = maybe null toNullable joinNullable :: Column (Nullable (Nullable a)) -> Column (Nullable a) joinNullable = unsafeCoerceColumn
− src/Opaleye/Constant.hs
@@ -1,4 +0,0 @@-module Opaleye.Constant {-# DEPRECATED "Use \"Opaleye.ToFields\" instead. Will be removed in version 0.8." #-}- (module Opaleye.Internal.Constant) where--import Opaleye.Internal.Constant
src/Opaleye/Distinct.hs view
@@ -1,14 +1,15 @@-{-# LANGUAGE FlexibleContexts #-}- module Opaleye.Distinct (distinct,- distinctOnCorrect,- distinctOnByCorrect,- Distinctspec,+ distinctOn,+ distinctOnBy, -- * Explicit versions distinctExplicit, -- * Adaptors+ Distinctspec, distinctspecField, distinctspecMaybeFields,+ -- * Deprecated+ distinctOnCorrect,+ distinctOnByCorrect, ) where @@ -17,6 +18,7 @@ import Opaleye.Order import qualified Data.Profunctor.Product.Default as D+import Opaleye.Internal.Unpackspec (Unpackspec) -- | Remove duplicate rows from the 'Select'. --@@ -26,7 +28,7 @@ -- distinct :: Select (Field a, Field b) -> Select (Field a, Field b) -- @ ----- Assuming the @makeAdaptorAndInstance@ splice has been run for the product type @Foo@:+-- Assuming the @makeAdaptorAndInstanceInferrable@ splice has been run for the product type @Foo@: -- -- @ -- distinct :: Select (Foo (Field a) (Field b) (Field c)) -> Select (Foo (Field a) (Field b) (Field c))@@ -39,5 +41,6 @@ -- 'Opaleye.Lateral.laterally' 'distinct' :: 'Data.Profunctor.Product.Default' 'Distinctspec' fields fields => 'Opaleye.Select.SelectArr' i fields -> 'Opaleye.Select.SelectArr' i fields -- @ distinct :: D.Default Distinctspec fields fields =>+ D.Default Unpackspec fields fields => Select fields -> Select fields-distinct = distinctExplicit D.def+distinct = distinctExplicit D.def D.def
src/Opaleye/Exists.hs view
@@ -1,11 +1,11 @@ module Opaleye.Exists (exists) where import Opaleye.Field (Field)-import Opaleye.Internal.Column (Column (Column))-import Opaleye.Internal.QueryArr (runSimpleQueryArr, productQueryArr)+import Opaleye.Internal.Column (Field_(Column))+import Opaleye.Internal.QueryArr (productQueryArr, runSimpleSelect) import Opaleye.Internal.PackMap (run, extractAttr) import Opaleye.Internal.PrimQuery (PrimQuery' (Exists))-import Opaleye.Internal.Tag (next)+import Opaleye.Internal.Tag (fresh) import Opaleye.Select (Select) import Opaleye.SqlTypes (SqlBool) @@ -13,9 +13,8 @@ -- -- This operation is equivalent to Postgres's @EXISTS@ operator. exists :: Select a -> Select (Field SqlBool)-exists q = productQueryArr (f . runSimpleQueryArr q)- where- f (_, query, tag) = (Column result, Exists binding query, tag')- where- (result, [(binding, ())]) = run (extractAttr "exists" tag ())- tag' = next tag+exists q = productQueryArr $ do+ (_, query) <- runSimpleSelect q+ tag <- fresh+ let (result, [(binding, ())]) = run (extractAttr "exists" tag ())+ pure (Column result, Exists binding query)
src/Opaleye/Experimental/Enum.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE RankNTypes #-} module Opaleye.Experimental.Enum (@@ -8,22 +8,22 @@ enumMapperWithSchema, enumFromField, enumToFields,- fromFieldToFieldsEnum,+ enumShowSqlType, ) where -import Opaleye.Column (Column)+import Opaleye.Field (Field) import qualified Opaleye as O-import qualified Opaleye.Internal.Inferrable as I+import qualified Opaleye.Internal.PGTypes as IPT import qualified Opaleye.Internal.RunQuery as RQ import Data.ByteString.Char8 (unpack)-import qualified Data.Profunctor.Product.Default as D-import Text.PrettyPrint.HughesPJ ((<>), doubleQuotes, render, text)+import Text.PrettyPrint.HughesPJ (doubleQuotes, render, text) import Prelude hiding ((<>)) data EnumMapper sqlEnum haskellSum = EnumMapper { enumFromField :: RQ.FromField sqlEnum haskellSum- , enumToFields :: O.ToFields haskellSum (Column sqlEnum)+ , enumToFields :: O.ToFields haskellSum (Field sqlEnum)+ , enumShowSqlType :: forall proxy. proxy sqlEnum -> String } -- | Create a mapping between a Postgres @ENUM@ type and a Haskell@@ -82,11 +82,14 @@ -- defaultFromField = enumFromField sqlRatingMapper -- -- instance rating ~ Rating--- => D.Default (Inferrable O.FromFields) (O.Column SqlRating) rating where--- def = Inferrable D.def+-- => D.Default (Inferrable O.FromField) SqlRating rating where+-- def = inferrableDef ----- instance D.Default O.ToFields Rating (O.Column SqlRating) where+-- instance D.Default O.ToFields Rating (O.Field SqlRating) where -- def = enumToFields sqlRatingMapper+--+-- instance IsSqlType SqlRating where+-- showSqlType = enumShowSqlType sqlRatingMapper -- @ enumMapper :: String -- ^ The name of the @ENUM@ type@@ -116,7 +119,9 @@ -- ^ The @sqlEnum@ type variable is phantom. To protect -- yourself against type mismatches you should set it to -- the Haskell type that you use to represent the @ENUM@.-enumMapperWithSchema schema type_ = enumMapper' (render (doubleQuotes (text schema) <> text "." <> doubleQuotes (text type_)))+enumMapperWithSchema schema type_ =+ enumMapper'+ (IPT.sqlTypeWithSchema schema type_) enumMapper' :: String -- ^ The name of the @ENUM@ type@@ -133,6 +138,7 @@ enumMapper' type_ from to_ = EnumMapper { enumFromField = fromFieldEnum , enumToFields = toFieldsEnum+ , enumShowSqlType = \_ -> type_ } where toFieldsEnum = O.toToFields (O.unsafeCast type_ . O.sqlString . to_)@@ -141,12 +147,3 @@ Just s -> case from (unpack s) of Just r -> r Nothing -> error ("Unexpected: " ++ unpack s)---- | Use 'enumMapper' instead. Will be deprecated in 0.8.-fromFieldToFieldsEnum :: String- -> (String -> Maybe haskellSum)- -> (haskellSum -> String)- -> (RQ.FromField sqlEnum haskellSum,- O.ToFields haskellSum (Column sqlEnum))-fromFieldToFieldsEnum type_ from to_ = (enumFromField e, enumToFields e)- where e = enumMapper type_ from to_
src/Opaleye/Field.hs view
@@ -1,16 +1,22 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+ -- | Functions for working directly with 'Field_'s. -- -- Please note that numeric 'Field_' types are instances of 'Num', so -- you can use '*', '/', '+', '-' on them. To create 'Field_'s, see -- "Opaleye.ToFields" and "Opaleye.SqlTypes". ----- 'Field_' used to be called 'C.Column' and for technical reasons+-- 'Field_' used to be called t'C.Column' and for technical reasons -- there are still a few uses of the old name around. If you see--- @'C.Column' SqlType@ then you can understand it as @'Field'--- SqlType@, and if you see @'C.Column' ('C.Nullable' SqlType)@ then+-- @t'C.Column' SqlType@ then you can understand it as @'Field'+-- SqlType@, and if you see @t'C.Column' ( t'C.Nullable' SqlType )@ then -- you can understand it as @'FieldNullable' SqlType@. ----- 'C.Column' will be fully deprecated in version 0.8.+-- t'C.Column' will be removed in version 0.11.+--+-- (Due to Haddock formatting errors, this documentation previously+-- incorrectly stated that @Field_@ would be removed. It won't be!) {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-}@@ -20,12 +26,16 @@ Field, FieldNullable, Nullability(..),- -- * Coercing fields+ -- * Casting fields+ C.unsafeCast,+ unsafeCastSqlType, unsafeCoerceField, -- * Working with @NULL@ -- | Instead of working with @NULL@ you are recommended to use -- "Opaleye.MaybeFields" instead. Opaleye.Field.null,+ typedNull,+ untypedNull, isNull, matchNullable, fromNullable,@@ -33,78 +43,83 @@ maybeToNullable, ) where -import qualified Opaleye.Column as C+import Prelude hiding (null)++import Opaleye.Internal.Column+ (Field_(Column), FieldNullable, Field, Nullability(NonNullable, Nullable))+import qualified Opaleye.Internal.Column as C import qualified Opaleye.Internal.PGTypesExternal as T+import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ --- | The name @Column@ will be replaced by @Field@ in version 0.8.--- The @Field_@, @Field@ and @FieldNullable@ types exist to help--- smooth the transition. We recommend that you use @Field_@, @Field@--- or @FieldNullable@ instead of @Column@ everywhere that it is--- sufficient.-type family Field_ (a :: Nullability) b+import Data.Proxy (Proxy(Proxy)) -data Nullability = NonNullable | Nullable+-- FIXME Put Nullspec (or sqltype?) constraint on this -type instance Field_ 'NonNullable a = C.Column a-type instance Field_ 'Nullable a = C.Column (C.Nullable a)+-- | A @NULL@ of any type. This will change to become 'typedNull' in+-- a future version.+null :: FieldNullable a+null = Column (HPQ.ConstExpr HPQ.NullLit) -type FieldNullable a = Field_ 'Nullable a-type Field a = Field_ 'NonNullable a+-- | Cast a column to any other type, as long as it has an instance of+-- 'T.IsSqlType'. Should be used in preference to 'C.unsafeCast'.+unsafeCastSqlType :: forall a b n. (T.IsSqlType b) => Field_ n a -> Field_ n b+unsafeCastSqlType = C.unsafeCast (T.showSqlType @b Proxy) --- | A NULL of any type-null :: FieldNullable a-null = C.null+-- | Same as 'null', but with an explicit type @CAST@. This can help+-- in situations when PostgreSQL can't figure out the type of a+-- @NULL@. In a future major version this will replace @null@.+typedNull :: T.IsSqlType a => FieldNullable a+typedNull = unsafeCastSqlType null +-- | A @NULL@ of any type with no @CAST@ supplied. Use this in+-- preference to 'null' if you really don't want a type cast applied+-- to your @NULL@.+untypedNull :: FieldNullable a+untypedNull = null+ -- | @TRUE@ if the value of the field is @NULL@, @FALSE@ otherwise. isNull :: FieldNullable a -> Field T.PGBool-isNull = C.isNull+isNull = C.unOp HPQ.OpIsNull -- | 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)+matchNullable :: Field b -- ^- -> Field_ 'Nullable a+ -> (Field a -> Field b) -- ^- -> Field_ 'NonNullable b-matchNullable = C.matchNullable+ -> FieldNullable a+ -- ^ ͘+ -> Field b+matchNullable replacement f x = C.unsafeIfThenElse (isNull x) replacement+ (f (unsafeCoerceField x)) --- | If the @Field 'Nullable a@ is NULL then return the provided--- @Field 'NonNullable a@ otherwise return the underlying @Field--- 'NonNullable a@.+-- | If the @FieldNullable a@ is NULL then return the provided+-- @Field a@ otherwise return the underlying @Field+-- 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+fromNullable :: Field a -- ^- -> Field_ 'NonNullable a-fromNullable = C.fromNullable+ -> FieldNullable a+ -- ^ ͘+ -> Field a+fromNullable = flip matchNullable id -- | 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 :: Field a -> FieldNullable 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+maybeToNullable :: Maybe (Field a)+ -> FieldNullable a+maybeToNullable = maybe null toNullable -unsafeCoerceField :: C.Column a -> C.Column b+unsafeCoerceField :: Field_ n a -> Field_ n' b unsafeCoerceField = C.unsafeCoerceColumn
src/Opaleye/FunctionalJoin.hs view
@@ -1,22 +1,12 @@--- | Alternative APIs to inner, left, right, and full outer joins.--- See "Opaleye.Join" for details on the best way to do joins in+-- | Full outer joins.+-- See "Opaleye.Join" for details on the best way to do other joins in -- Opaleye. -{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}- module Opaleye.FunctionalJoin ( -- * Full outer join fullJoinF,- -- ** Deprecated- joinF,- leftJoinF,- rightJoinF, ) where -import Control.Applicative ((<$>), (<*>))-import Control.Arrow ((<<<))- import qualified Data.Profunctor.Product.Default as D import qualified Data.Profunctor.Product as PP @@ -29,84 +19,6 @@ import qualified Opaleye.Select as S import qualified Opaleye.SqlTypes as T import qualified Opaleye.Operators as O---- | Use 'Opaleye.Operators.where_' and @do@ notation instead. Will--- be deprecated in 0.8.-joinF :: (fieldsL -> fieldsR -> fieldsResult)- -- ^ Calculate result fields from input fields- -> (fieldsL -> fieldsR -> F.Field T.SqlBool)- -- ^ Condition on which to join- -> S.Select fieldsL- -- ^ Left query- -> S.Select fieldsR- -- ^ Right query- -> S.Select fieldsResult-joinF f cond l r =- fmap (uncurry f) (O.keepWhen (uncurry cond) <<< ((,) <$> l <*> r))---- | Use 'Opaleye.Join.optional' instead. Will be deprecated in 0.8.-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- -> (fieldsL -> fieldsResult)- -- ^ Calculate result row from input row when there are /no/- -- rows in the right query satisfying the join condition- -> (fieldsL -> fieldsR -> F.Field T.SqlBool)- -- ^ Condition on which to join- -> S.Select fieldsL- -- ^ Left query- -> S.Select fieldsR- -- ^ Right query- -> S.Select fieldsResult-leftJoinF f fL cond l r = fmap ret j- where a1 = fmap (\x -> (x, T.sqlBool True))- j = J.leftJoinExplicit D.def- D.def- (PP.p2 (IJ.NullMaker id, nullmakerBool))- l- (a1 r)- (\(l', (r', _)) -> cond l' r')-- ret (lr, (rr, rc)) = O.ifThenElseMany (C.isNull rc) (fL lr) (f lr rr)-- nullmakerBool :: IJ.NullMaker (F.Field T.SqlBool)- (F.FieldNullable T.SqlBool)- nullmakerBool = D.def---- | Use 'Opaleye.Join.optional' instead. Will be deprecated in 0.8.-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- -> (fieldsR -> fieldsResult)- -- ^ Calculate result row from input row when there are /no/- -- rows in the left query satisfying the join condition- -> (fieldsL -> fieldsR -> F.Field T.SqlBool)- -- ^ Condition on which to join- -> S.Select fieldsL- -- ^ Left query- -> S.Select fieldsR- -- ^ Right query- -> S.Select fieldsResult-rightJoinF f fR cond l r = fmap ret j- where a1 = fmap (\x -> (x, T.sqlBool True))- j = J.rightJoinExplicit D.def- D.def- (PP.p2 (IJ.NullMaker id, nullmakerBool))- (a1 l)- r- (\((l', _), r') -> cond l' r')-- ret ((lr, lc), rr) = O.ifThenElseMany (C.isNull lc) (fR rr) (f lr rr)-- nullmakerBool :: IJ.NullMaker (F.Field T.SqlBool)- (F.FieldNullable T.SqlBool)- nullmakerBool = D.def fullJoinF :: (D.Default IO.IfPP fieldsResult fieldsResult, D.Default IU.Unpackspec fieldsL fieldsL,
+ src/Opaleye/Inferrable.hs view
@@ -0,0 +1,9 @@+module Opaleye.Inferrable+ ( Inferrable,+ inferrableDef,+ inferrable,+ runInferrable,+ )+where++import Opaleye.Internal.Inferrable
src/Opaleye/Internal/Aggregate.hs view
@@ -1,16 +1,21 @@ {-# LANGUAGE TupleSections #-} module Opaleye.Internal.Aggregate where -import Control.Applicative (Applicative, pure, (<*>))+import Control.Applicative (liftA2)+import Data.Foldable (toList)+import Data.Traversable (for) import qualified Data.Profunctor as P import qualified Data.Profunctor.Product as PP +import qualified Opaleye.Field as F+import qualified Opaleye.Internal.Column as C+import qualified Opaleye.Internal.Order as O import qualified Opaleye.Internal.PackMap as PM import qualified Opaleye.Internal.PrimQuery as PQ import qualified Opaleye.Internal.Tag as T-import qualified Opaleye.Internal.Column as C-import qualified Opaleye.Internal.Order as O+import qualified Opaleye.Internal.Unpackspec as U+import qualified Opaleye.SqlTypes as T import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ @@ -28,63 +33,89 @@ takes a list of @a@ and returns a single value of type @b@. -} newtype Aggregator a b =- Aggregator (PM.PackMap (Maybe (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct),- HPQ.PrimExpr)- HPQ.PrimExpr- a b)+ Aggregator (PM.PackMap HPQ.Aggregate HPQ.PrimExpr a b) -makeAggr' :: Maybe HPQ.AggrOp -> Aggregator (C.Column a) (C.Column b)-makeAggr' mAggrOp = Aggregator (PM.PackMap- (\f (C.Column e) -> fmap C.Column (f (fmap (, [], HPQ.AggrAll) mAggrOp, e))))+makeAggr' :: Maybe HPQ.AggrOp -> Aggregator (C.Field_ n a) (C.Field_ n' b)+makeAggr' mAggrOp = P.dimap C.unColumn C.Column $ Aggregator (PM.PackMap+ (\f e -> f (aggr e)))+ where+ aggr = case mAggrOp of+ Nothing -> HPQ.GroupBy+ Just op -> \e -> HPQ.Aggregate (HPQ.Aggr op [e] [] HPQ.AggrAll [] Nothing) -makeAggr :: HPQ.AggrOp -> Aggregator (C.Column a) (C.Column b)+makeAggr :: HPQ.AggrOp -> Aggregator (C.Field_ n a) (C.Field_ n' b) makeAggr = makeAggr' . Just +makeAggrExplicit :: U.Unpackspec a a' -> HPQ.AggrOp -> Aggregator a (C.Field_ n b)+makeAggrExplicit unpackspec op =+ C.Column <$> Aggregator (PM.PackMap (\f e -> f (aggr e)))+ where+ aggr a = HPQ.Aggregate (HPQ.Aggr op exprs [] HPQ.AggrAll [] Nothing)+ where+ exprs = U.collectPEs unpackspec a++ -- | Order the values within each aggregation in `Aggregator` using -- the given ordering. This is only relevant for aggregations that -- depend on the order they get their elements, like -- `Opaleye.Aggregate.arrayAgg` and `Opaleye.Aggregate.stringAgg`. -- -- You can either apply it to an aggregation of multiple columns, in--- which case it will apply to all aggregation functions in there, or you--- can apply it to a single column, and then compose the aggregations--- afterwards. Examples:+-- which case it will apply to all aggregation functions in there ----- > x :: Aggregator (Column a, Column b) (Column (PGArray a), Column (PGArray a))--- > x = (,) <$> orderAggregate (asc snd) (lmap fst arrayAggGrouped)--- > <*> orderAggregate (desc snd) (lmap fst arrayAggGrouped)+-- Example: --+-- > x :: Aggregator (Column a, Column b) (Column (PGArray a), Column (PGArray b))+-- > x = orderAggregate (asc snd) $ p2 (arrayAgg, arrayAgg)+-- -- This will generate: -- -- @--- SELECT array_agg(a ORDER BY b ASC), array_agg(a ORDER BY b DESC)+-- SELECT array_agg(a ORDER BY b ASC), array_agg(b ORDER BY b ASC) -- FROM (SELECT a, b FROM ...) -- @ ----- Or:+-- Or you can apply it to a single column, and then compose the aggregations+-- afterwards. ----- > x :: Aggregator (Column a, Column b) (Column (PGArray a), Column (PGArray b))--- > x = orderAggregate (asc snd) $ p2 (arrayAggGrouped, arrayAggGrouped)+-- Example: --+-- > x :: Aggregator (Column a, Column b) (Column (PGArray a), Column (PGArray a))+-- > x = (,) <$> orderAggregate (asc snd) (lmap fst arrayAgg)+-- > <*> orderAggregate (desc snd) (lmap fst arrayAgg)+-- -- This will generate: -- -- @--- SELECT array_agg(a ORDER BY b ASC), array_agg(b ORDER BY b ASC)+-- SELECT array_agg(a ORDER BY b ASC), array_agg(a ORDER BY b DESC) -- FROM (SELECT a, b FROM ...) -- @ orderAggregate :: O.Order a -> Aggregator a b -> Aggregator a b orderAggregate o (Aggregator (PM.PackMap pm)) = Aggregator (PM.PackMap- (\f c -> pm (f . P.first' (fmap ((\f' (a,b,c') -> (a,f' b,c')) (const $ O.orderExprs c o)))) c))+ (\f c -> pm (f . setOrder (O.orderExprs c o)) c))+ where+ setOrder _ (HPQ.GroupBy e) = HPQ.GroupBy e+ setOrder order (HPQ.Aggregate aggr) =+ HPQ.Aggregate aggr+ { HPQ.aggrOrder = order+ } runAggregator :: Applicative f => Aggregator a b- -> ((Maybe (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct), HPQ.PrimExpr)- -> f HPQ.PrimExpr)+ -> (HPQ.Aggregate -> f HPQ.PrimExpr) -> a -> f b runAggregator (Aggregator a) = PM.traversePM a +-- For rel8.+--+-- Like https://www.stackage.org/haddock/lts-19.10/base-4.15.1.0/Control-Arrow.html#t:ArrowApply+aggregatorApply :: Aggregator (Aggregator a b, a) b+aggregatorApply = Aggregator $ PM.PackMap $ \f (agg, a) ->+ case agg of+ Aggregator (PM.PackMap inner) -> inner f a+ -- In Postgres (and, I believe, standard SQL) "aggregate functions are -- not allowed in FROM clause of their own query level". There -- doesn't seem to be any fundamental reason for this, but we are@@ -98,36 +129,76 @@ -- https://github.com/tomjaguarpaw/haskell-opaleye/pull/460#issuecomment-626716160 -- -- Instead of detecting when we are aggregating over a field from a--- previous query we just create new names for all field before we+-- previous query we just create new names for all fields before we -- aggregate. On the other hand, referring to a field from a previous -- query in an ORDER BY expression is totally fine! aggregateU :: Aggregator a b- -> (a, PQ.PrimQuery, T.Tag) -> (b, PQ.PrimQuery, T.Tag)-aggregateU agg (c0, primQ, t0) = (c1, primQ', T.next t0)- where (c1, projPEs_inners) =+ -> (a, T.Tag) -> (b, PQ.PrimQuery -> PQ.PrimQuery)+aggregateU agg (c0, t0) = (c1, primQ')+ where projPEs_inners :: PQ.Bindings HPQ.Aggregate+ (c1, projPEs_inners) = PM.run (runAggregator agg (extractAggregateFields t0) c0) - projPEs = map fst projPEs_inners- inners = map snd projPEs_inners+ projPEs = projPEs_inners - primQ' = PQ.Aggregate projPEs (PQ.Rebind True inners primQ)+ primQ' = PQ.Aggregate projPEs extractAggregateFields :: T.Tag- -> (m, HPQ.PrimExpr)- -> PM.PM [((HPQ.Symbol,- (m, HPQ.Symbol)),- (HPQ.Symbol, HPQ.PrimExpr))]- HPQ.PrimExpr-extractAggregateFields tag (m, pe) = do+ -> HPQ.Aggregate+ -> PM.PM (PQ.Bindings HPQ.Aggregate) HPQ.PrimExpr+extractAggregateFields tag agg = do i <- PM.new+ let sinner = HPQ.Symbol ("result" ++ i) tag - let souter = HPQ.Symbol ("result" ++ i) tag- sinner = HPQ.Symbol ("inner" ++ i) tag+ PM.write (sinner, agg) - PM.write ((souter, (m, sinner)), (sinner, pe))+ pure (HPQ.AttrExpr sinner) - pure (HPQ.AttrExpr souter)+unsafeMax :: Aggregator (C.Field a) (C.Field a)+unsafeMax = makeAggr HPQ.AggrMax++unsafeMin :: Aggregator (C.Field a) (C.Field a)+unsafeMin = makeAggr HPQ.AggrMin++unsafeAvg :: Aggregator (C.Field a) (C.Field a)+unsafeAvg = makeAggr HPQ.AggrAvg++unsafeSum :: Aggregator (C.Field a) (C.Field a)+unsafeSum = makeAggr HPQ.AggrSum++-- | Aggregate only rows matching the given predicate+filterWhereInternal+ :: (F.FieldNullable T.SqlBool -> b -> mb)+ -> (a -> F.Field T.SqlBool)+ -> Aggregator a b+ -> Aggregator a mb+filterWhereInternal maybeField predicate aggregator =+ case liftA2 maybeField true aggregator of+ Aggregator (PM.PackMap pm) ->+ Aggregator (PM.PackMap (\f c -> pm (f . setFilter c) c))+ where+ true = P.lmap (const (T.sqlBool True)) (makeAggr HPQ.AggrBoolAnd)+ setFilter _ (HPQ.GroupBy e) = HPQ.GroupBy e+ setFilter row (HPQ.Aggregate aggr) =+ HPQ.Aggregate aggr+ { HPQ.aggrFilter = aggrFilter'+ }+ where+ C.Column cond' = predicate row+ aggrFilter' = Just $ case HPQ.aggrFilter aggr of+ Nothing -> cond'+ Just cond -> HPQ.BinExpr HPQ.OpAnd cond cond'++withinGroup :: O.Order a -> Aggregator a b -> Aggregator a b+withinGroup o (Aggregator (PM.PackMap pm)) = Aggregator (PM.PackMap+ (\f c -> pm (f . setOrder (O.orderExprs c o)) c))+ where+ setOrder _ (HPQ.GroupBy e) = HPQ.GroupBy e+ setOrder order (HPQ.Aggregate aggr) =+ HPQ.Aggregate aggr+ { HPQ.aggrGroup = order+ } -- { Boilerplate instances
src/Opaleye/Internal/Binary.hs view
@@ -1,8 +1,8 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-}+{-# OPTIONS_HADDOCK not-home #-} module Opaleye.Internal.Binary where -import Opaleye.Internal.Column (Column(Column), unColumn)+import Opaleye.Internal.Column (Field_(Column), unColumn) import qualified Opaleye.Internal.Tag as T import qualified Opaleye.Internal.PackMap as PM import qualified Opaleye.Internal.QueryArr as Q@@ -15,7 +15,6 @@ import qualified Data.Profunctor.Product as PP import Data.Profunctor.Product.Default (Default, def) -import Control.Applicative (Applicative, pure, (<*>)) import Control.Arrow ((***)) extractBinaryFields :: T.Tag -> (HPQ.PrimExpr, HPQ.PrimExpr)@@ -23,36 +22,39 @@ HPQ.PrimExpr extractBinaryFields = PM.extractAttr "binary" -newtype Binaryspec columns columns' =+newtype Binaryspec fields fields' = Binaryspec (PM.PackMap (HPQ.PrimExpr, HPQ.PrimExpr) HPQ.PrimExpr- (columns, columns) columns')+ (fields, fields) fields') runBinaryspec :: Applicative f => Binaryspec columns columns' -> ((HPQ.PrimExpr, HPQ.PrimExpr) -> f HPQ.PrimExpr) -> (columns, columns) -> f columns' runBinaryspec (Binaryspec b) = PM.traversePM b -binaryspecColumn :: Binaryspec (Column a) (Column a)-binaryspecColumn = Binaryspec (PM.iso (mapBoth unColumn) Column)- where mapBoth f (s, t) = (f s, f t)+binaryspecColumn :: Binaryspec (Field_ n a) (Field_ n a)+binaryspecColumn = dimap unColumn Column (Binaryspec (PM.PackMap id)) sameTypeBinOpHelper :: PQ.BinOp -> Binaryspec columns columns' -> Q.Query columns -> Q.Query columns -> Q.Query columns'-sameTypeBinOpHelper binop binaryspec q1 q2 = Q.productQueryArr q where- q ((), startTag) = (newColumns, newPrimQuery, T.next endTag)- where (columns1, primQuery1, midTag) = Q.runSimpleQueryArr q1 ((), startTag)- (columns2, primQuery2, endTag) = Q.runSimpleQueryArr q2 ((), midTag)+sameTypeBinOpHelper binop binaryspec q1 q2 = Q.productQueryArr $ do+ (columns1, primQuery1) <- Q.runSimpleSelect q1+ (columns2, primQuery2) <- Q.runSimpleSelect q2 - (newColumns, pes) =+ endTag <- T.fresh++ let (newColumns, pes) = PM.run (runBinaryspec binaryspec (extractBinaryFields endTag) (columns1, columns2)) - newPrimQuery = PQ.Binary binop+ newPrimQuery = PQ.Binary binop ( PQ.Rebind False (map (fmap fst) pes) primQuery1 , PQ.Rebind False (map (fmap snd) pes) primQuery2 ) -instance Default Binaryspec (Column a) (Column a) where+ pure (newColumns, newPrimQuery)+++instance Default Binaryspec (Field_ n a) (Field_ n a) where def = binaryspecColumn -- {
src/Opaleye/Internal/Column.hs view
@@ -1,4 +1,8 @@+{-# OPTIONS_HADDOCK not-home #-}+ {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-} module Opaleye.Internal.Column where @@ -6,73 +10,82 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ --- | A column of a @Query@, of type @pgType@. For example 'Column'--- @SqlInt4@ is an @int4@ column and a 'Column' @SqlText@ is a @text@+data Nullability = NonNullable | Nullable++-- | A field of a @Select@, of type @sqlType@. For example a @Field+-- SqlInt4@ is an @int4@ column and a @Field SqlText@ is a @text@ -- column.------ The name @Column@ will be replaced by @Field@ in version 0.8.--- There already exists a @Field@ type family to help smooth the--- transition. We recommend that you use @Field_@, @Field@ or--- @FieldNullable@ instead of @Column@ everywhere that it is--- sufficient.-newtype Column pgType = Column HPQ.PrimExpr+newtype Field_ (n :: Nullability) sqlType = Column HPQ.PrimExpr +type Field = Field_ NonNullable+type FieldNullable = Field_ 'Nullable+ -- | Only used within a 'Column', to indicate that it can be @NULL@.--- For example, a 'Column' ('Nullable' @SqlText@) can be @NULL@ but a+-- For example, a @'Column' ('Nullable' SqlText)@ can be @NULL@ but a -- 'Column' @SqlText@ cannot.-data Nullable a = Nullable+data Nullable a = Nullable_ -unColumn :: Column a -> HPQ.PrimExpr+-- | Do not use. Use 'Field' instead. Will be removed in a later+-- version.+type family Column a where+ Column (Nullable a) = FieldNullable a+ Column a = Field a++unColumn :: Field_ n a -> HPQ.PrimExpr unColumn (Column e) = e -- | Treat a 'Column' as though it were of a different type. If such -- a treatment is not valid then Postgres may fail with an error at -- SQL run time.-unsafeCoerceColumn :: Column a -> Column b+unsafeCoerceColumn :: Field_ n a -> Field_ n' b unsafeCoerceColumn (Column e) = Column e -- | Cast a column to any other type. Implements Postgres's @::@ or -- @CAST( ... AS ... )@ operations. This is safe for some -- conversions, such as uuid to text.-unsafeCast :: String -> Column a -> Column b+unsafeCast :: String -> Field_ n a -> Field_ n b unsafeCast = mapColumn . HPQ.CastExpr where- mapColumn :: (HPQ.PrimExpr -> HPQ.PrimExpr) -> Column c -> Column a+ mapColumn :: (HPQ.PrimExpr -> HPQ.PrimExpr) -> Field_ n c -> Field_ n' a mapColumn primExpr c = Column (primExpr (unColumn c)) -unsafeCompositeField :: Column a -> String -> Column b+unsafeCompositeField :: Field_ n a -> String -> Field_ n' b unsafeCompositeField (Column e) fieldName = Column (HPQ.CompositeExpr e fieldName) -binOp :: HPQ.BinOp -> Column a -> Column b -> Column c+unsafeFromNullable :: Field_ n a+ -> Field_ n' a+unsafeFromNullable (Column e) = Column e++binOp :: HPQ.BinOp -> Field_ n a -> Field_ n' b -> Field_ n'' c binOp op (Column e) (Column e') = Column (HPQ.BinExpr op e e') -unOp :: HPQ.UnOp -> Column a -> Column b+unOp :: HPQ.UnOp -> Field_ n a -> Field_ n' b unOp op (Column e) = Column (HPQ.UnExpr op e) --- For import order reasons we can't make the return type SqlBool-unsafeCase_ :: [(Column pgBool, Column a)] -> Column a -> Column a+-- For import order reasons we can't make the argument type SqlBool+unsafeCase_ :: [(Field_ n pgBool, Field_ n' a)] -> Field_ n' a -> Field_ n' a unsafeCase_ alts (Column otherwise_) = Column (HPQ.CaseExpr (unColumns alts) otherwise_) where unColumns = map (\(Column e, Column e') -> (e, e')) -unsafeIfThenElse :: Column pgBool -> Column a -> Column a -> Column a+unsafeIfThenElse :: Field_ n' pgBool -> Field_ n a -> Field_ n a -> Field_ n a unsafeIfThenElse cond t f = unsafeCase_ [(cond, t)] f -unsafeGt :: Column a -> Column a -> Column pgBool+unsafeGt :: Field_ n a -> Field_ n a -> Field_ n' pgBool unsafeGt = binOp (HPQ.:>) -unsafeEq :: Column a -> Column a -> Column pgBool+unsafeEq :: Field_ n a -> Field_ n a -> Field_ n' pgBool unsafeEq = binOp (HPQ.:==) class SqlNum a where- pgFromInteger :: Integer -> Column a+ pgFromInteger :: Integer -> Field a pgFromInteger = sqlFromInteger - sqlFromInteger :: Integer -> Column a+ sqlFromInteger :: Integer -> Field a type PGNum = SqlNum -instance SqlNum a => Num (Column a) where+instance SqlNum a => Num (Field a) where fromInteger = pgFromInteger (*) = binOp (HPQ.:*) (+) = binOp (HPQ.:+)@@ -86,14 +99,14 @@ signum c = unsafeCase_ [(c `unsafeGt` 0, 1), (c `unsafeEq` 0, 0)] (-1) class SqlFractional a where- pgFromRational :: Rational -> Column a+ pgFromRational :: Rational -> Field a pgFromRational = sqlFromRational - sqlFromRational :: Rational -> Column a+ sqlFromRational :: Rational -> Field a type PGFractional = SqlFractional -instance (SqlNum a, SqlFractional a) => Fractional (Column a) where+instance (SqlNum a, SqlFractional a) => Fractional (Field a) where fromRational = sqlFromRational (/) = binOp (HPQ.:/) @@ -103,12 +116,12 @@ type PGIntegral = SqlIntegral class SqlString a where- pgFromString :: String -> Column a+ pgFromString :: String -> Field a pgFromString = sqlFromString - sqlFromString :: String -> Column a+ sqlFromString :: String -> Field a type PGString = SqlString -instance SqlString a => IsString (Column a) where+instance SqlString a => IsString (Field a) where fromString = sqlFromString
src/Opaleye/Internal/Constant.hs view
@@ -1,9 +1,11 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}+{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE DataKinds #-}+ module Opaleye.Internal.Constant where -import Opaleye.Column (Column)-import qualified Opaleye.Column as C+import Opaleye.Field (Field)+import qualified Opaleye.Field as F import qualified Opaleye.SqlTypes as T import qualified Data.Aeson as Ae@@ -15,154 +17,155 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.Scientific as Sci import qualified Data.Time.Compat as Time-import qualified Data.UUID as UUID+import qualified Data.UUID.Types as UUID import qualified Data.Profunctor.Product as PP import Data.Profunctor.Product (empty, (***!), (+++!)) import qualified Data.Profunctor.Product.Default as D import qualified Data.Profunctor as P -import Control.Applicative (Applicative, pure, (<*>))-import Data.Functor ((<$>))- import qualified Database.PostgreSQL.Simple.Range as R+import Database.PostgreSQL.Simple.Newtypes ( Aeson, getAeson ) toFields :: D.Default ToFields haskells fields => haskells -> fields toFields = constantExplicit D.def -{-# DEPRECATED constant "Use 'toFields' instead. Will be removed in version 0.8." #-}-constant :: D.Default ToFields haskells fields- => haskells -> fields-constant = constantExplicit D.def-+-- | A way of turning Haskell values of type @haskells@ into SQL+-- fields. Use it with 'Opaleye.ToFields.toFields'. newtype ToFields haskells fields = ToFields { constantExplicit :: haskells -> fields } -{-# DEPRECATED Constant "Use 'ToFields' instead. Will be removed in version 0.8." #-}-type Constant = ToFields--instance D.Default ToFields haskell (Column sql)- => D.Default ToFields (Maybe haskell) (Column (C.Nullable sql)) where- def = ToFields (C.maybeToNullable . fmap f)+instance D.Default ToFields haskell (F.Field sql)+ => D.Default ToFields (Maybe haskell) (F.FieldNullable sql) where+ def = ToFields (F.maybeToNullable . fmap f) where ToFields f = D.def toToFields :: (haskells -> fields) -> ToFields haskells fields toToFields = ToFields -instance D.Default ToFields (Column a) (Column a) where+instance D.Default ToFields (Field a) (Field a) where def = toToFields id -instance D.Default ToFields String (Column T.SqlText) where+instance D.Default ToFields String (Field T.SqlText) where def = toToFields T.sqlString -instance D.Default ToFields LBS.ByteString (Column T.SqlBytea) where+instance D.Default ToFields LBS.ByteString (Field T.SqlBytea) where def = toToFields T.sqlLazyByteString -instance D.Default ToFields SBS.ByteString (Column T.SqlBytea) where+instance D.Default ToFields SBS.ByteString (Field T.SqlBytea) where def = toToFields T.sqlStrictByteString -instance D.Default ToFields ST.Text (Column T.SqlText) where+instance D.Default ToFields ST.Text (Field T.SqlText) where def = toToFields T.sqlStrictText -instance D.Default ToFields LT.Text (Column T.SqlText) where+instance D.Default ToFields LT.Text (Field T.SqlText) where def = toToFields T.sqlLazyText -instance D.Default ToFields String (Column T.SqlVarcharN) where+instance D.Default ToFields String (Field T.SqlVarcharN) where def = toToFields T.sqlStringVarcharN -instance D.Default ToFields ST.Text (Column T.SqlVarcharN) where+instance D.Default ToFields ST.Text (Field T.SqlVarcharN) where def = toToFields T.sqlStrictTextVarcharN -instance D.Default ToFields LT.Text (Column T.SqlVarcharN) where+instance D.Default ToFields LT.Text (Field T.SqlVarcharN) where def = toToFields T.sqlLazyTextVarcharN -instance D.Default ToFields Sci.Scientific (Column T.SqlNumeric) where+instance D.Default ToFields Sci.Scientific (Field T.SqlNumeric) where def = toToFields T.sqlNumeric -instance D.Default ToFields Int (Column T.SqlInt4) where+instance D.Default ToFields Int.Int16 (Field T.SqlInt2) where+ def = toToFields $ T.sqlInt2 . fromIntegral++instance D.Default ToFields Int (Field T.SqlInt4) where def = toToFields T.sqlInt4 -instance D.Default ToFields Int.Int32 (Column T.SqlInt4) where+instance D.Default ToFields Int.Int32 (Field T.SqlInt4) where def = toToFields $ T.sqlInt4 . fromIntegral -instance D.Default ToFields Int.Int64 (Column T.SqlInt8) where+instance D.Default ToFields Int.Int64 (Field T.SqlInt8) where def = toToFields T.sqlInt8 -instance D.Default ToFields Double (Column T.SqlFloat8) where+instance D.Default ToFields Double (Field T.SqlFloat8) where def = toToFields T.sqlDouble -instance D.Default ToFields Bool (Column T.SqlBool) where+instance D.Default ToFields Bool (Field T.SqlBool) where def = toToFields T.sqlBool -instance D.Default ToFields UUID.UUID (Column T.SqlUuid) where+instance D.Default ToFields UUID.UUID (Field T.SqlUuid) where def = toToFields T.sqlUUID -instance D.Default ToFields Time.Day (Column T.SqlDate) where+instance D.Default ToFields Time.Day (Field T.SqlDate) where def = toToFields T.sqlDay -instance D.Default ToFields Time.UTCTime (Column T.SqlTimestamptz) where+instance D.Default ToFields Time.UTCTime (Field T.SqlTimestamptz) where def = toToFields T.sqlUTCTime -instance D.Default ToFields Time.LocalTime (Column T.SqlTimestamp) where+instance D.Default ToFields Time.LocalTime (Field T.SqlTimestamp) where def = toToFields T.sqlLocalTime -instance D.Default ToFields Time.ZonedTime (Column T.SqlTimestamptz) where+instance D.Default ToFields Time.ZonedTime (Field T.SqlTimestamptz) where def = toToFields T.sqlZonedTime -instance D.Default ToFields Time.TimeOfDay (Column T.SqlTime) where+instance D.Default ToFields Time.TimeOfDay (Field T.SqlTime) where def = toToFields T.sqlTimeOfDay -instance D.Default ToFields Time.CalendarDiffTime (Column T.SqlInterval) where+instance D.Default ToFields Time.CalendarDiffTime (Field T.SqlInterval) where def = toToFields T.sqlInterval -instance D.Default ToFields (CI.CI ST.Text) (Column T.SqlCitext) where+instance D.Default ToFields (CI.CI ST.Text) (Field T.SqlCitext) where def = toToFields T.sqlCiStrictText -instance D.Default ToFields (CI.CI LT.Text) (Column T.SqlCitext) where+instance D.Default ToFields (CI.CI LT.Text) (Field T.SqlCitext) where def = toToFields T.sqlCiLazyText -instance D.Default ToFields SBS.ByteString (Column T.SqlJson) where+instance D.Default ToFields SBS.ByteString (Field T.SqlJson) where def = toToFields T.sqlStrictJSON -instance D.Default ToFields LBS.ByteString (Column T.SqlJson) where+instance D.Default ToFields LBS.ByteString (Field T.SqlJson) where def = toToFields T.sqlLazyJSON -instance D.Default ToFields Ae.Value (Column T.SqlJson) where+instance D.Default ToFields Ae.Value (Field T.SqlJson) where def = toToFields T.sqlValueJSON -instance D.Default ToFields SBS.ByteString (Column T.SqlJsonb) where+instance D.Default ToFields SBS.ByteString (Field T.SqlJsonb) where def = toToFields T.sqlStrictJSONB -instance D.Default ToFields LBS.ByteString (Column T.SqlJsonb) where+instance D.Default ToFields LBS.ByteString (Field T.SqlJsonb) where def = toToFields T.sqlLazyJSONB -instance D.Default ToFields Ae.Value (Column T.SqlJsonb) where+instance (Ae.ToJSON a) => D.Default ToFields (Aeson a) (Field T.SqlJson) where+ def = toToFields $ T.sqlValueJSON . getAeson++instance D.Default ToFields Ae.Value (Field T.SqlJsonb) where def = toToFields T.sqlValueJSONB -instance D.Default ToFields haskell (Column sql) => D.Default ToFields (Maybe haskell) (Maybe (Column sql)) where+instance D.Default ToFields haskell (F.Field_ n sql) => D.Default ToFields (Maybe haskell) (Maybe (F.Field_ n sql)) where def = toToFields (toFields <$>) -instance (D.Default ToFields a (Column b), T.IsSqlType b)- => D.Default ToFields [a] (Column (T.SqlArray b)) where+instance (Ae.ToJSON a) => D.Default ToFields (Aeson a) (F.Field T.SqlJsonb) where+ def = toToFields $ T.sqlValueJSONB . getAeson++instance (D.Default ToFields a (F.Field_ n b), T.IsSqlType b)+ => D.Default ToFields [a] (F.Field (T.SqlArray_ n b)) where def = toToFields (T.sqlArray (constantExplicit D.def)) -instance D.Default ToFields (R.PGRange Int.Int) (Column (T.SqlRange T.SqlInt4)) where+instance D.Default ToFields (R.PGRange Int.Int) (F.Field (T.SqlRange T.SqlInt4)) where def = toToFields $ \(R.PGRange a b) -> T.sqlRange T.sqlInt4 a b -instance D.Default ToFields (R.PGRange Int.Int64) (Column (T.SqlRange T.SqlInt8)) where+instance D.Default ToFields (R.PGRange Int.Int64) (F.Field (T.SqlRange T.SqlInt8)) where def = toToFields $ \(R.PGRange a b) -> T.sqlRange T.sqlInt8 a b -instance D.Default ToFields (R.PGRange Sci.Scientific) (Column (T.SqlRange T.SqlNumeric)) where+instance D.Default ToFields (R.PGRange Sci.Scientific) (F.Field (T.SqlRange T.SqlNumeric)) where def = toToFields $ \(R.PGRange a b) -> T.sqlRange T.sqlNumeric a b -instance D.Default ToFields (R.PGRange Time.LocalTime) (Column (T.SqlRange T.SqlTimestamp)) where+instance D.Default ToFields (R.PGRange Time.LocalTime) (F.Field (T.SqlRange T.SqlTimestamp)) where def = toToFields $ \(R.PGRange a b) -> T.sqlRange T.sqlLocalTime a b -instance D.Default ToFields (R.PGRange Time.UTCTime) (Column (T.SqlRange T.SqlTimestamptz)) where+instance D.Default ToFields (R.PGRange Time.UTCTime) (F.Field (T.SqlRange T.SqlTimestamptz)) where def = toToFields $ \(R.PGRange a b) -> T.sqlRange T.sqlUTCTime a b -instance D.Default ToFields (R.PGRange Time.Day) (Column (T.SqlRange T.SqlDate)) where+instance D.Default ToFields (R.PGRange Time.Day) (F.Field (T.SqlRange T.SqlDate)) where def = toToFields $ \(R.PGRange a b) -> T.sqlRange T.sqlDay a b -- { Boilerplate instances
src/Opaleye/Internal/Distinct.hs view
@@ -1,33 +1,32 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_HADDOCK not-home #-} module Opaleye.Internal.Distinct where import qualified Opaleye.Internal.MaybeFields as M import Opaleye.Select (Select)-import Opaleye.Column (Column)-import Opaleye.Aggregate (Aggregator, groupBy, aggregate)--import Control.Applicative (Applicative, pure, (<*>))+import Opaleye.Field (Field_)+import Opaleye.Aggregate (Aggregator, groupBy, aggregateExplicit) import qualified Data.Profunctor as P import qualified Data.Profunctor.Product as PP import Data.Profunctor.Product.Default (Default, def)+import Opaleye.Internal.Unpackspec (Unpackspec) -- We implement distinct simply by grouping by all columns. We could -- instead implement it as SQL's DISTINCT but implementing it in terms -- of something else that we already have is easier at this point. -distinctExplicit :: Distinctspec fields fields'+distinctExplicit :: Unpackspec fields fields+ -> Distinctspec fields fields' -> Select fields -> Select fields'-distinctExplicit (Distinctspec agg) = aggregate agg+distinctExplicit u (Distinctspec agg) = aggregateExplicit u agg newtype Distinctspec a b = Distinctspec (Aggregator a b) -instance Default Distinctspec (Column a) (Column a) where+instance Default Distinctspec (Field_ n a) (Field_ n a) where def = Distinctspec groupBy -distinctspecField :: Distinctspec (Column a) (Column a)+distinctspecField :: Distinctspec (Field_ n a) (Field_ n a) distinctspecField = def distinctspecMaybeFields :: M.WithNulls Distinctspec a b
src/Opaleye/Internal/HaskellDB/PrimQuery.hs view
@@ -2,6 +2,8 @@ -- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net -- License : BSD-style +{-# LANGUAGE DeriveTraversable #-}+ module Opaleye.Internal.HaskellDB.PrimQuery where import qualified Opaleye.Internal.Tag as T@@ -21,8 +23,10 @@ | BaseTableAttrExpr Attribute | CompositeExpr PrimExpr Attribute -- ^ Composite Type Query | BinExpr BinOp PrimExpr PrimExpr+ | AnyExpr BinOp PrimExpr PrimExpr -- ^ <expr> <op> ANY(<expr>) | UnExpr UnOp PrimExpr- | AggrExpr AggrDistinct AggrOp PrimExpr [OrderExpr]+ | AggrExpr (Aggr' PrimExpr)+ | WndwExpr WndwOp Partition | ConstExpr Literal | CaseExpr [(PrimExpr,PrimExpr)] PrimExpr | ListExpr (NEL.NonEmpty PrimExpr)@@ -79,16 +83,33 @@ data AggrOp = AggrCount | AggrSum | AggrAvg | AggrMin | AggrMax | AggrStdDev | AggrStdDevP | AggrVar | AggrVarP | AggrBoolOr | AggrBoolAnd | AggrArr | JsonArr- | AggrStringAggr PrimExpr+ | AggrStringAggr | AggrOther String deriving (Show,Read) data AggrDistinct = AggrDistinct | AggrAll deriving (Eq,Show,Read) -data OrderExpr = OrderExpr OrderOp PrimExpr- deriving (Show,Read)+type Aggregate = Aggregate' PrimExpr +data Aggregate' a = GroupBy a | Aggregate (Aggr' a)+ deriving (Functor, Foldable, Traversable, Show, Read)++data Aggr' a = Aggr+ { aggrOp :: !AggrOp+ , aggrExprs :: ![a]+ , aggrOrder :: ![OrderExpr' a]+ , aggrDistinct :: !AggrDistinct+ , aggrGroup :: ![OrderExpr' a]+ , aggrFilter :: !(Maybe PrimExpr)+ }+ deriving (Functor, Foldable, Traversable, Show, Read)++type OrderExpr = OrderExpr' PrimExpr++data OrderExpr' a = OrderExpr OrderOp a+ deriving (Functor, Foldable, Traversable, Show, Read)+ data OrderNulls = NullsFirst | NullsLast deriving (Show,Read) @@ -101,3 +122,24 @@ data BoundExpr = Inclusive PrimExpr | Exclusive PrimExpr | PosInfinity | NegInfinity deriving (Show,Read)++data WndwOp+ = WndwRowNumber+ | WndwRank+ | WndwDenseRank+ | WndwPercentRank+ | WndwCumeDist+ | WndwNtile PrimExpr+ | WndwLag PrimExpr PrimExpr PrimExpr+ | WndwLead PrimExpr PrimExpr PrimExpr+ | WndwFirstValue PrimExpr+ | WndwLastValue PrimExpr+ | WndwNthValue PrimExpr PrimExpr+ | WndwAggregate AggrOp [PrimExpr]+ deriving (Show,Read)++data Partition = Partition+ { partitionBy :: [PrimExpr]+ , orderBy :: [OrderExpr]+ }+ deriving (Read, Show)
src/Opaleye/Internal/HaskellDB/Sql.hs view
@@ -31,6 +31,13 @@ , sqlOrderNulls :: SqlOrderNulls } deriving Show ++data SqlPartition = SqlPartition+ { sqlPartitionBy :: Maybe (NEL.NonEmpty SqlExpr)+ , sqlOrderBy :: Maybe (NEL.NonEmpty (SqlExpr, SqlOrder))+ }+ deriving Show+ data SqlRangeBound = Inclusive SqlExpr | Exclusive SqlExpr | PosInfinity | NegInfinity deriving Show @@ -41,11 +48,13 @@ data SqlExpr = ColumnSqlExpr SqlColumn | CompositeSqlExpr SqlExpr String | BinSqlExpr String SqlExpr SqlExpr+ | AnySqlExpr String SqlExpr SqlExpr | SubscriptSqlExpr SqlExpr SqlExpr | PrefixSqlExpr String SqlExpr | PostfixSqlExpr String SqlExpr | FunSqlExpr String [SqlExpr]- | AggrFunSqlExpr String [SqlExpr] [(SqlExpr, SqlOrder)] SqlDistinct -- ^ Aggregate functions separate from normal functions.+ | AggrFunSqlExpr String [SqlExpr] [(SqlExpr, SqlOrder)] SqlDistinct [(SqlExpr, SqlOrder)] (Maybe SqlExpr) -- ^ Aggregate functions separate from normal functions.+ | WndwFunSqlExpr String [SqlExpr] SqlPartition | ConstSqlExpr String | CaseSqlExpr (NEL.NonEmpty (SqlExpr,SqlExpr)) SqlExpr | ListSqlExpr (NEL.NonEmpty SqlExpr)@@ -64,6 +73,8 @@ -- | Data type for SQL DELETE statements. data SqlDelete = SqlDelete SqlTable [SqlExpr] +{-# DEPRECATED DoNothing "Use 'doNothing' instead. @DoNothing@ will be removed in version 0.11" #-}+-- It won't be removed, it will just be made internal data OnConflict = DoNothing -- ^ @ON CONFLICT DO NOTHING@
src/Opaleye/Internal/HaskellDB/Sql/Default.hs view
@@ -2,9 +2,9 @@ -- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net -- License : BSD-style -module Opaleye.Internal.HaskellDB.Sql.Default where+{-# LANGUAGE LambdaCase #-} -import Control.Applicative ((<$>))+module Opaleye.Internal.HaskellDB.Sql.Default where import Opaleye.Internal.HaskellDB.PrimQuery import qualified Opaleye.Internal.HaskellDB.PrimQuery as PQ@@ -50,6 +50,13 @@ PQ.NullsLast -> Sql.SqlNullsLast +toSqlPartition :: SqlGenerator -> Partition -> SqlPartition+toSqlPartition gen (Partition partition order) = SqlPartition+ { sqlPartitionBy = NEL.nonEmpty (map (sqlExpr gen) partition)+ , sqlOrderBy = NEL.nonEmpty (map (toSqlOrder gen) order)+ }++ toSqlColumn :: Attribute -> SqlColumn toSqlColumn = SqlColumn @@ -117,28 +124,29 @@ (leftE, paren rightE) _ -> (paren leftE, paren rightE) in BinSqlExpr (showBinOp op) expL expR+ AnyExpr op e1 e2 ->+ let leftE = sqlExpr gen e1+ rightE = sqlExpr gen e2+ in AnySqlExpr (showBinOp op) (ParensSqlExpr leftE) rightE UnExpr op e -> let (op',t) = sqlUnOp op e' = sqlExpr gen e in case t of UnOpFun -> FunSqlExpr op' [e'] UnOpPrefix -> PrefixSqlExpr op' (ParensSqlExpr e') UnOpPostfix -> PostfixSqlExpr op' (ParensSqlExpr e')- -- TODO: The current arrangement whereby the delimeter parameter- -- of string_agg is in the AggrStringAggr constructor, but the- -- parameter being aggregated is not, seems unsatisfactory- -- because it leads to a non-uniformity of treatment, as seen- -- below. Perhaps we should have just `AggrExpr AggrOp` and- -- always put the `PrimExpr` in the `AggrOp`.- AggrExpr distinct op e ord -> let op' = showAggrOp op- e' = sqlExpr gen e- ord' = toSqlOrder gen <$> ord- distinct' = case distinct of- AggrDistinct -> SqlDistinct- AggrAll -> SqlNotDistinct- moreAggrFunParams = case op of- AggrStringAggr primE -> [sqlExpr gen primE]- _ -> []- in AggrFunSqlExpr op' (e' : moreAggrFunParams) ord' distinct'+ AggrExpr (Aggr op e ord distinct group mfilter) ->+ let+ (op', e') = showAggrOp gen op e+ ord' = toSqlOrder gen <$> ord+ distinct' = case distinct of+ AggrDistinct -> SqlDistinct+ AggrAll -> SqlNotDistinct+ group' = toSqlOrder gen <$> group+ mfilter' = sqlExpr gen <$> mfilter+ in AggrFunSqlExpr op' e' ord' distinct' group' mfilter'+ WndwExpr op window -> let (op', e') = showWndwOp gen op+ window' = toSqlPartition gen window+ in WndwFunSqlExpr op' e' window' ConstExpr l -> ConstSqlExpr (sqlLiteral gen l) CaseExpr cs e -> let cs' = [(sqlExpr gen c, sqlExpr gen x)| (c,x) <- cs] e' = sqlExpr gen e@@ -214,22 +222,43 @@ sqlUnOp (UnOpOther s) = (s, UnOpFun) -showAggrOp :: AggrOp -> String-showAggrOp AggrCount = "COUNT"-showAggrOp AggrSum = "SUM"-showAggrOp AggrAvg = "AVG"-showAggrOp AggrMin = "MIN"-showAggrOp AggrMax = "MAX"-showAggrOp AggrStdDev = "StdDev"-showAggrOp AggrStdDevP = "StdDevP"-showAggrOp AggrVar = "Var"-showAggrOp AggrVarP = "VarP"-showAggrOp AggrBoolAnd = "BOOL_AND"-showAggrOp AggrBoolOr = "BOOL_OR"-showAggrOp AggrArr = "ARRAY_AGG"-showAggrOp JsonArr = "JSON_AGG"-showAggrOp (AggrStringAggr _) = "STRING_AGG"-showAggrOp (AggrOther s) = s+showAggrOp :: SqlGenerator -> AggrOp -> [PrimExpr] -> (String, [SqlExpr])+showAggrOp gen op args = (showAggrOpFunction op, map (sqlExpr gen) args)+++showAggrOpFunction :: AggrOp -> String+showAggrOpFunction = \case+ AggrCount -> "COUNT"+ AggrSum -> "SUM"+ AggrAvg -> "AVG"+ AggrMin -> "MIN"+ AggrMax -> "MAX"+ AggrStdDev -> "StdDev"+ AggrStdDevP -> "StdDevP"+ AggrVar -> "Var"+ AggrVarP -> "VarP"+ AggrBoolAnd -> "BOOL_AND"+ AggrBoolOr -> "BOOL_OR"+ AggrArr -> "ARRAY_AGG"+ JsonArr -> "JSON_AGG"+ AggrStringAggr -> "STRING_AGG"+ AggrOther s -> s+++showWndwOp :: SqlGenerator -> WndwOp -> (String, [SqlExpr])+showWndwOp gen op = case op of+ WndwRowNumber -> ("ROW_NUMBER", [])+ WndwRank -> ("RANK", [])+ WndwDenseRank -> ("DENSE_RANK", [])+ WndwPercentRank -> ("PERCENT_RANK", [])+ WndwCumeDist -> ("CUME_DIST", [])+ WndwNtile e -> ("NTILE", [sqlExpr gen e])+ WndwLag e offset def -> ("LAG", map (sqlExpr gen) [e, offset, def])+ WndwLead e offset def -> ("LEAD", map (sqlExpr gen) [e, offset, def])+ WndwFirstValue e -> ("FIRST_VALUE", [sqlExpr gen e])+ WndwLastValue e -> ("LAST_VALUE", [sqlExpr gen e])+ WndwNthValue e n -> ("NTH_VALUE", map (sqlExpr gen) [e, n])+ WndwAggregate op' arg -> showAggrOp gen op' arg defaultSqlLiteral :: SqlGenerator -> Literal -> String
src/Opaleye/Internal/HaskellDB/Sql/Print.hs view
@@ -24,7 +24,7 @@ import Opaleye.Internal.HaskellDB.Sql (SqlColumn(..), SqlDelete(..), SqlExpr(..), SqlOrder(..), SqlInsert(..), SqlUpdate(..), SqlTable(..), SqlRangeBound(..),- OnConflict(..))+ SqlPartition(..), OnConflict(..)) import qualified Opaleye.Internal.HaskellDB.Sql as Sql import Data.List (intersperse)@@ -55,6 +55,22 @@ ppGroupAttrs :: [SqlExpr] -> Doc ppGroupAttrs = commaV (ppSqlExpr . deliteral) +ppWindowExpr :: String -> [SqlExpr] -> SqlPartition -> Doc+ppWindowExpr f es partition = text f <> parens (commaH ppSqlExpr es) <+> text "OVER" <+> parens (ppSqlPartition partition)++ppSqlPartition :: SqlPartition -> Doc+ppSqlPartition partition =+ ppPartitionBy (sqlPartitionBy partition) <+>+ ppOrderBy (maybe [] NEL.toList (sqlOrderBy partition))++ppPartitionBy :: Maybe (NEL.NonEmpty SqlExpr) -> Doc+ppPartitionBy Nothing = empty+ppPartitionBy (Just es) =+ text "PARTITION BY" <+> ppPartitionAttrs (NEL.toList es)+ where+ ppPartitionAttrs :: [SqlExpr] -> Doc+ ppPartitionAttrs = commaH (ppSqlExpr . deliteral)+ ppOrderBy :: [(SqlExpr,SqlOrder)] -> Doc ppOrderBy [] = empty ppOrderBy ord = text "ORDER BY" <+> commaV ppOrd ord@@ -165,6 +181,7 @@ ParensSqlExpr e -> parens (ppSqlExpr e) SubscriptSqlExpr e1 e2 -> ppSqlExpr e1 <> brackets (ppSqlExpr e2) BinSqlExpr op e1 e2 -> ppSqlExpr e1 <+> text op <+> ppSqlExpr e2+ AnySqlExpr op e1 e2 -> ppSqlExpr e1 <+> text op <+> text "ANY" <+> parens (ppSqlExpr e2) PrefixSqlExpr op e -> text op <+> ppSqlExpr e PostfixSqlExpr op e -> ppSqlExpr e <+> text op FunSqlExpr f es -> text f <> parens (commaH ppSqlExpr es)@@ -176,7 +193,17 @@ DefaultSqlExpr -> text "DEFAULT" ArraySqlExpr es -> text "ARRAY" <> brackets (commaH ppSqlExpr es) RangeSqlExpr t s e -> ppRange t s e- AggrFunSqlExpr f es ord distinct -> text f <> parens (ppSqlDistinct distinct <+> commaH ppSqlExpr es <+> ppOrderBy ord)+ AggrFunSqlExpr f es ord distinct group mfilter ->+ text f <> args <+> within <+> filter+ where+ args = parens (ppSqlDistinct distinct <+> commaH ppSqlExpr es <+> ppOrderBy ord)+ within = case group of+ [] -> empty+ _ -> text "WITHIN GROUP" <+> parens (ppOrderBy group)+ filter = case mfilter of+ Nothing -> mempty+ Just e -> text "FILTER" <+> parens (text "WHERE" <+> ppSqlExpr e)+ WndwFunSqlExpr f es window -> ppWindowExpr f es window CaseSqlExpr cs el -> text "CASE" <+> vcat (toList (fmap ppWhen cs)) <+> text "ELSE" <+> ppSqlExpr el <+> text "END" where ppWhen (w,t) = text "WHEN" <+> ppSqlExpr w
src/Opaleye/Internal/Inferrable.hs view
@@ -1,12 +1,11 @@ {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-} module Opaleye.Internal.Inferrable where -import qualified Opaleye.Column as C+import qualified Opaleye.Field as F import Opaleye.Internal.RunQuery (FromField, FromFields) import qualified Opaleye.Internal.RunQuery as RQ import qualified Opaleye.SqlTypes as T@@ -23,9 +22,9 @@ import qualified Data.Text as ST import qualified Data.Time.Compat as Time import Data.Typeable (Typeable)-import Data.UUID (UUID)+import Data.UUID.Types (UUID) import qualified Database.PostgreSQL.Simple.Range as R-import GHC.Int (Int32, Int64)+import GHC.Int (Int16, Int32, Int64) -- | Despite its name, 'Inferrable' doesn't provide any inferability -- improvements itself, it's just a conveniently-named newtype wrapper@@ -34,55 +33,67 @@ -- FromFields --- OVERLAPPABLE is pretty grim, but it will go away when we switch to Field-instance {-# OVERLAPPABLE #-}+instance D.Default (Inferrable FromField) a b- => D.Default (Inferrable FromFields) (C.Column a) b where- def = Inferrable (RQ.queryRunner (runInferrable D.def))+ => D.Default (Inferrable FromFields) (F.Field a) b where+ def = Inferrable (RQ.fromFields (runInferrable D.def)) instance (D.Default (Inferrable FromField) a b, Maybe b ~ maybe_b)- => D.Default (Inferrable FromFields) (C.Column (C.Nullable a)) maybe_b where- def = Inferrable (RQ.queryRunner (RQ.queryRunnerColumnNullable (runInferrable D.def)))+ => D.Default (Inferrable FromFields) (F.FieldNullable a) maybe_b where+ def = Inferrable (RQ.fromFieldsNullable (runInferrable D.def)) +inferrable :: p a b -> Inferrable p a b+inferrable = Inferrable++inferrableDef :: D.Default p a b => Inferrable p a b+inferrableDef = inferrable D.def+ -- FromField +instance int16 ~ Int16 => D.Default (Inferrable FromField) T.SqlInt2 int16 where+ def = inferrableDef+ instance int ~ Int => D.Default (Inferrable FromField) T.SqlInt4 int where- def = Inferrable D.def+ def = inferrableDef instance int64 ~ Int64 => D.Default (Inferrable FromField) T.SqlInt8 int64 where- def = Inferrable D.def+ def = inferrableDef instance text ~ ST.Text => D.Default (Inferrable FromField) T.SqlText text where- def = Inferrable D.def+ def = inferrableDef instance varchar ~ ST.Text => D.Default (Inferrable FromField) T.SqlVarcharN varchar where- def = Inferrable D.def+ def = inferrableDef instance (Typeable h, D.Default (Inferrable FromField) f h, hs ~ [h]) => D.Default (Inferrable FromField) (T.SqlArray f) hs where def = Inferrable (RQ.fromFieldArray (runInferrable D.def)) +instance (Typeable h, D.Default (Inferrable FromField) f h, hs ~ [Maybe h])+ => D.Default (Inferrable FromField) (T.SqlArray_ F.Nullable f) hs where+ def = Inferrable (RQ.fromFieldArrayNullable (runInferrable D.def))+ instance double ~ Double => D.Default (Inferrable FromField) T.SqlFloat8 double where- def = Inferrable D.def+ def = inferrableDef instance scientific ~ Sci.Scientific => D.Default (Inferrable FromField) T.SqlNumeric scientific where- def = Inferrable D.def+ def = inferrableDef instance bool ~ Bool => D.Default (Inferrable FromField) T.SqlBool bool where- def = Inferrable D.def+ def = inferrableDef instance uuid ~ UUID => D.Default (Inferrable FromField) T.SqlUuid uuid where- def = Inferrable D.def+ def = inferrableDef instance bytestring ~ SBS.ByteString => D.Default (Inferrable FromField) T.SqlBytea bytestring where- def = Inferrable D.def+ def = inferrableDef instance day ~ Time.Day => D.Default (Inferrable FromField) T.SqlDate day where- def = Inferrable D.def+ def = inferrableDef -- I'm not certain what we should map timestamptz to. The -- postgresql-simple types it maps to are ZonedTime and UTCTime, but@@ -91,50 +102,50 @@ --instance utctime ~ Time.UTCTime -- => D.Default (Inferrable FromField) T.SqlTimestamptz utctime where--- def = Inferrable D.def+-- def = inferrableDef instance localtime ~ Time.LocalTime => D.Default (Inferrable FromField) T.SqlTimestamp localtime where- def = Inferrable D.def+ def = inferrableDef instance timeofday ~ Time.TimeOfDay => D.Default (Inferrable FromField) T.SqlTime timeofday where- def = Inferrable D.def+ def = inferrableDef instance calendardifftime ~ Time.CalendarDiffTime => D.Default (Inferrable FromField) T.SqlInterval calendardifftime where- def = Inferrable D.def+ def = inferrableDef instance cttext ~ CI.CI ST.Text => D.Default (Inferrable FromField) T.SqlCitext cttext where- def = Inferrable D.def+ def = inferrableDef -- It's not clear what to map JSON types to {--instance QueryRunnerColumnDefault T.PGJson String where- defaultFromField = fieldParserQueryRunnerColumn jsonFieldParser+instance DefaultFromField T.PGJson String where+ defaultFromField = fromPGSFieldParser jsonFieldParser -instance QueryRunnerColumnDefault T.PGJson Ae.Value where+instance DefaultFromField T.PGJson Ae.Value where defaultFromField = fromPGSFromField -instance QueryRunnerColumnDefault T.PGJsonb String where- defaultFromField = fieldParserQueryRunnerColumn jsonbFieldParser+instance DefaultFromField T.PGJsonb String where+ defaultFromField = fromPGSFieldParser jsonbFieldParser -instance QueryRunnerColumnDefault T.PGJsonb Ae.Value where+instance DefaultFromField T.PGJsonb Ae.Value where defaultFromField = fromPGSFromField -instance QueryRunnerColumnDefault T.PGTimestamptz Time.UTCTime where+instance DefaultFromField T.PGTimestamptz Time.UTCTime where defaultFromField = fromPGSFromField -instance QueryRunnerColumnDefault T.PGTimestamptz Time.ZonedTime where+instance DefaultFromField T.PGTimestamptz Time.ZonedTime where defaultFromField = fromPGSFromField -} -- ToFields {- The instance for arrays would clash with String. String is going to- be use far more, so to get arrays you'll have to explicitly use+ be used far more, so to get arrays you'll have to explicitly use `sqlArray`. instance (D.Default (Inferrable ToFields) a (C.Column b),@@ -145,109 +156,109 @@ (runInferrable D.def)))) -} -instance C.Column a ~ columnA- => D.Default (Inferrable ToFields) (C.Column a) columnA where- def = Inferrable D.def+instance F.Field a ~ fieldA+ => D.Default (Inferrable ToFields) (F.Field a) fieldA where+ def = inferrableDef -instance C.Column T.SqlText ~ cSqlText+instance F.Field T.SqlText ~ cSqlText => D.Default (Inferrable ToFields) String cSqlText where- def = Inferrable D.def+ def = inferrableDef -instance C.Column T.SqlBytea ~ cSqlBytea+instance F.Field T.SqlBytea ~ cSqlBytea => D.Default (Inferrable ToFields) LBS.ByteString cSqlBytea where- def = Inferrable D.def+ def = inferrableDef -instance C.Column T.SqlBytea ~ cSqlBytea+instance F.Field T.SqlBytea ~ cSqlBytea => D.Default (Inferrable ToFields) SBS.ByteString cSqlBytea where- def = Inferrable D.def+ def = inferrableDef -instance C.Column T.SqlText ~ cSqlText+instance F.Field T.SqlText ~ cSqlText => D.Default (Inferrable ToFields) ST.Text cSqlText where- def = Inferrable D.def+ def = inferrableDef -instance C.Column T.SqlText ~ cSqlText+instance F.Field T.SqlText ~ cSqlText => D.Default (Inferrable ToFields) LT.Text cSqlText where- def = Inferrable D.def+ def = inferrableDef -instance C.Column T.SqlNumeric ~ cSqlNumeric+instance F.Field T.SqlNumeric ~ cSqlNumeric => D.Default (Inferrable ToFields) Sci.Scientific cSqlNumeric where- def = Inferrable D.def+ def = inferrableDef -instance C.Column T.SqlInt4 ~ cSqlInt4+instance F.Field T.SqlInt4 ~ cSqlInt4 => D.Default (Inferrable ToFields) Int cSqlInt4 where- def = Inferrable D.def+ def = inferrableDef -instance C.Column T.SqlInt4 ~ cSqlInt4+instance F.Field T.SqlInt4 ~ cSqlInt4 => D.Default (Inferrable ToFields) Int32 cSqlInt4 where- def = Inferrable D.def+ def = inferrableDef -instance C.Column T.SqlInt8 ~ cSqlInt8+instance F.Field T.SqlInt8 ~ cSqlInt8 => D.Default (Inferrable ToFields) Int64 cSqlInt8 where- def = Inferrable D.def+ def = inferrableDef -instance C.Column T.SqlFloat8 ~ cSqlFloat8+instance F.Field T.SqlFloat8 ~ cSqlFloat8 => D.Default (Inferrable ToFields) Double cSqlFloat8 where- def = Inferrable D.def+ def = inferrableDef -instance C.Column T.SqlBool ~ cSqlBool+instance F.Field T.SqlBool ~ cSqlBool => D.Default (Inferrable ToFields) Bool cSqlBool where- def = Inferrable D.def+ def = inferrableDef -instance C.Column T.SqlUuid ~ cSqlUuid+instance F.Field T.SqlUuid ~ cSqlUuid => D.Default (Inferrable ToFields) UUID cSqlUuid where- def = Inferrable D.def+ def = inferrableDef -instance C.Column T.SqlDate ~ cSqlDate+instance F.Field T.SqlDate ~ cSqlDate => D.Default (Inferrable ToFields) Time.Day cSqlDate where- def = Inferrable D.def+ def = inferrableDef -instance C.Column T.SqlTimestamptz ~ cSqlTimestamptz+instance F.Field T.SqlTimestamptz ~ cSqlTimestamptz => D.Default (Inferrable ToFields) Time.UTCTime cSqlTimestamptz where- def = Inferrable D.def+ def = inferrableDef -instance C.Column T.SqlTimestamptz ~ cSqlTimestamptz+instance F.Field T.SqlTimestamptz ~ cSqlTimestamptz => D.Default (Inferrable ToFields) Time.ZonedTime cSqlTimestamptz where- def = Inferrable D.def+ def = inferrableDef -instance C.Column T.SqlTime ~ cSqlTime+instance F.Field T.SqlTime ~ cSqlTime => D.Default (Inferrable ToFields) Time.TimeOfDay cSqlTime where- def = Inferrable D.def+ def = inferrableDef -instance C.Column T.SqlInterval ~ cSqlInterval+instance F.Field T.SqlInterval ~ cSqlInterval => D.Default (Inferrable ToFields) Time.CalendarDiffTime cSqlInterval where- def = Inferrable D.def+ def = inferrableDef -instance C.Column T.SqlCitext ~ cSqlCitext+instance F.Field T.SqlCitext ~ cSqlCitext => D.Default (Inferrable ToFields) (CI.CI ST.Text) cSqlCitext where- def = Inferrable D.def+ def = inferrableDef -instance C.Column T.SqlCitext ~ cSqlCitext+instance F.Field T.SqlCitext ~ cSqlCitext => D.Default (Inferrable ToFields) (CI.CI LT.Text) cSqlCitext where- def = Inferrable D.def+ def = inferrableDef -instance C.Column (T.SqlRange T.SqlInt4) ~ cRangeInt4+instance F.Field (T.SqlRange T.SqlInt4) ~ cRangeInt4 => D.Default (Inferrable ToFields) (R.PGRange Int) cRangeInt4 where- def = Inferrable D.def+ def = inferrableDef -instance C.Column (T.SqlRange T.SqlInt8) ~ cRangeInt8+instance F.Field (T.SqlRange T.SqlInt8) ~ cRangeInt8 => D.Default (Inferrable ToFields) (R.PGRange Int64) cRangeInt8 where- def = Inferrable D.def+ def = inferrableDef -instance C.Column (T.SqlRange T.SqlNumeric) ~ cRangeScientific+instance F.Field (T.SqlRange T.SqlNumeric) ~ cRangeScientific => D.Default (Inferrable ToFields) (R.PGRange Sci.Scientific) cRangeScientific where- def = Inferrable D.def+ def = inferrableDef -instance C.Column (T.SqlRange T.SqlTimestamp) ~ cRangeTimestamp+instance F.Field (T.SqlRange T.SqlTimestamp) ~ cRangeTimestamp => D.Default (Inferrable ToFields) (R.PGRange Time.LocalTime) cRangeTimestamp where- def = Inferrable D.def+ def = inferrableDef -instance C.Column (T.SqlRange T.SqlTimestamptz) ~ cRangeTimestamptz+instance F.Field (T.SqlRange T.SqlTimestamptz) ~ cRangeTimestamptz => D.Default (Inferrable ToFields) (R.PGRange Time.UTCTime) cRangeTimestamptz where- def = Inferrable D.def+ def = inferrableDef -instance C.Column (T.SqlRange T.SqlDate) ~ cRangeDate+instance F.Field (T.SqlRange T.SqlDate) ~ cRangeDate => D.Default (Inferrable ToFields) (R.PGRange Time.Day) cRangeDate where- def = Inferrable D.def+ def = inferrableDef {- It's not clear if Aeson Value should map to JSON or JSONB.
src/Opaleye/Internal/JSONBuildObjectFields.hs view
@@ -5,10 +5,10 @@ ) where -import Opaleye.Internal.Column (Column (Column))+import Opaleye.Internal.Column (Field_(Column))+import Opaleye.Field (Field) import Opaleye.Internal.HaskellDB.PrimQuery (Literal (StringLit), PrimExpr (ConstExpr, FunExpr)) import Opaleye.Internal.PGTypesExternal (SqlJson)-import Data.Semigroup -- | Combine @JSONBuildObjectFields@ using @('<>')@ newtype JSONBuildObjectFields@@ -24,10 +24,10 @@ mempty = JSONBuildObjectFields mempty mappend = (<>) --- | Given a label and a column, generates a pair for use with @jsonBuildObject@+-- | Given a label and a field, generates a pair for use with @jsonBuildObject@ jsonBuildObjectField :: String -- ^ Field name- -> Column a+ -> Field_ n a -- ^ Field value -> JSONBuildObjectFields jsonBuildObjectField f (Column v) = JSONBuildObjectFields [(f, v)]@@ -35,7 +35,7 @@ -- | Create an 'SqlJson' object from a collection of fields. -- -- Note: This is implemented as a variadic function in postgres, and as such, is limited to 50 arguments, or 25 key-value pairs.-jsonBuildObject :: JSONBuildObjectFields -> Column SqlJson+jsonBuildObject :: JSONBuildObjectFields -> Field SqlJson jsonBuildObject (JSONBuildObjectFields jbofs) = Column $ FunExpr "json_build_object" args where args = concatMap mapLabelsToPrimExpr jbofs
src/Opaleye/Internal/Join.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Arrows #-} @@ -8,20 +7,18 @@ import qualified Opaleye.Internal.PackMap as PM import qualified Opaleye.Internal.Tag as T import qualified Opaleye.Internal.Unpackspec as U-import Opaleye.Internal.Column (Column(Column), Nullable)+import Opaleye.Internal.Column (Field_(Column), FieldNullable) import qualified Opaleye.Internal.QueryArr as Q import qualified Opaleye.Internal.Operators as Op import qualified Opaleye.Internal.PrimQuery as PQ import qualified Opaleye.Internal.PGTypesExternal as T import qualified Opaleye.Internal.Rebind as Rebind import qualified Opaleye.SqlTypes as T-import qualified Opaleye.Column as C+import qualified Opaleye.Field as C import Opaleye.Field (Field)-import qualified Opaleye.Internal.Map as Map import Opaleye.Internal.MaybeFields (MaybeFields(MaybeFields), mfPresent, mfFields) import qualified Opaleye.Select as S-import qualified Opaleye.Internal.TypeFamilies as TF import qualified Control.Applicative as A import qualified Control.Arrow@@ -35,10 +32,10 @@ toNullable :: NullMaker a b -> a -> b toNullable (NullMaker f) = f -instance D.Default NullMaker (Column a) (Column (Nullable a)) where+instance D.Default NullMaker (Field a) (FieldNullable a) where def = NullMaker C.toNullable -instance D.Default NullMaker (Column (Nullable a)) (Column (Nullable a)) where+instance D.Default NullMaker (FieldNullable a) (FieldNullable a) where def = NullMaker id joinExplicit :: U.Unpackspec columnsA columnsA@@ -47,42 +44,44 @@ -> (columnsB -> returnedColumnsB) -> PQ.JoinType -> Q.Query columnsA -> Q.Query columnsB- -> ((columnsA, columnsB) -> Column T.PGBool)+ -> ((columnsA, columnsB) -> Field T.PGBool) -> Q.Query (returnedColumnsA, returnedColumnsB) joinExplicit uA uB returnColumnsA returnColumnsB joinType- qA qB cond = Q.productQueryArr q where- q ((), startTag) = ((nullableColumnsA, nullableColumnsB), primQueryR, T.next endTag)- where (columnsA, primQueryA, midTag) = Q.runSimpleQueryArr qA ((), startTag)- (columnsB, primQueryB, endTag) = Q.runSimpleQueryArr qB ((), midTag)+ qA qB cond = Q.productQueryArr $ do+ (columnsA, primQueryA) <- Q.runSimpleSelect qA+ (columnsB, primQueryB) <- Q.runSimpleSelect qB - (newColumnsA, ljPEsA) =+ endTag <- T.fresh++ let (newColumnsA, ljPEsA) = PM.run (U.runUnpackspec uA (extractLeftJoinFields 1 endTag) columnsA)- (newColumnsB, ljPEsB) =+ (newColumnsB, ljPEsB) = PM.run (U.runUnpackspec uB (extractLeftJoinFields 2 endTag) columnsB) - nullableColumnsA = returnColumnsA newColumnsA- nullableColumnsB = returnColumnsB newColumnsB+ nullableColumnsA = returnColumnsA newColumnsA+ nullableColumnsB = returnColumnsB newColumnsB - Column cond' = cond (columnsA, columnsB)- primQueryR = PQ.Join joinType cond'+ Column cond' = cond (columnsA, columnsB)+ primQueryR = PQ.Join joinType cond' (PQ.NonLateral, (PQ.Rebind True ljPEsA primQueryA)) (PQ.NonLateral, (PQ.Rebind True ljPEsB primQueryB)) + pure ((nullableColumnsA, nullableColumnsB), primQueryR)++ leftJoinAExplicit :: U.Unpackspec a a -> NullMaker a nullableA -> Q.Query a- -> Q.QueryArr (a -> Column T.PGBool) nullableA+ -> Q.QueryArr (a -> Field T.PGBool) nullableA leftJoinAExplicit uA nullmaker rq =- Q.leftJoinQueryArr $ \(p, t1) ->- let (newColumnsR, right, tag') = flip Q.runSimpleQueryArr ((), t1) $ proc () -> do+ Q.leftJoinQueryArr' $ do+ (newColumnsR, right) <- Q.runSimpleSelect $ proc () -> do a <- rq -< () Rebind.rebindExplicit uA -< a- renamedNullable = toNullable nullmaker newColumnsR- Column cond = p newColumnsR- in ( renamedNullable- , cond- , right- , tag')+ pure $ \p ->+ let renamedNullable = toNullable nullmaker newColumnsR+ Column cond = p newColumnsR+ in (renamedNullable, cond, right) optionalRestrict :: D.Default U.Unpackspec a a => S.Select a@@ -94,7 +93,7 @@ -> S.SelectArr (a -> Field T.SqlBool) (MaybeFields a) optionalRestrictExplicit uA q = dimap (. snd) (\(nonNullIfPresent, rest) ->- let present = Op.not (C.isNull (C.unsafeCoerceColumn nonNullIfPresent))+ let present = Op.not (C.isNull (C.unsafeCoerceField nonNullIfPresent)) in MaybeFields { mfPresent = present , mfFields = rest }) $@@ -135,35 +134,3 @@ instance PP.ProductProfunctor NullMaker where purePP = pure (****) = (<*>)------{-# DEPRECATED Nulled "Will be removed in version 0.8" #-}-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)
src/Opaleye/Internal/Lateral.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE FlexibleContexts #-}- module Opaleye.Internal.Lateral ( lateral , viaLateral
src/Opaleye/Internal/Locking.hs view
@@ -21,4 +21,6 @@ -- enforce those restrictions through its type system so it's very -- easy to create queries that fail at run time using this operation. forUpdate :: Q.Select a -> Q.Select a-forUpdate = Q.mapPrimQuery PQ.ForUpdate+forUpdate s = Q.productQueryArr $ do+ (a, query) <- Q.runSimpleSelect s+ pure (a, PQ.ForUpdate query)
src/Opaleye/Internal/Manipulation.hs view
@@ -1,13 +1,10 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-} module Opaleye.Internal.Manipulation where import qualified Control.Applicative as A -import Opaleye.Internal.Column (Column(Column))+import Opaleye.Internal.Column (Field_(Column), Field) 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@@ -32,9 +29,8 @@ 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+-- | Represents a @RETURNING@ statement for a manipulation query.+data Returning fields haskells where Count :: Returning a Int64 ReturningExplicit@@ -97,7 +93,7 @@ (fromString (arrangeInsertManyReturningSql u t columns' r onConflict))- where IRQ.QueryRunner u _ _ = qr+ where IRQ.FromFields 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@@ -123,15 +119,18 @@ -- -instance D.Default Updater (Column a) (Column a) where+instance D.Default Updater (Field_ n a) (Field_ n a) where def = Updater id -instance D.Default Updater (Column a) (Maybe (Column a)) where+instance D.Default Updater (Field_ n a) (Maybe (Field_ n a)) where def = Updater Just +instance D.Default Updater (Field_ n a) () where+ def = Updater (const ())+ arrangeDeleteReturning :: U.Unpackspec columnsReturned ignored -> T.Table columnsW columnsR- -> (columnsR -> Column SqlBool)+ -> (columnsR -> Field SqlBool) -> (columnsR -> columnsReturned) -> Sql.Returning HSql.SqlDelete -- this implementation was copied, it does not make sense yet@@ -144,7 +143,7 @@ arrangeDeleteReturningSql :: U.Unpackspec columnsReturned ignored -> T.Table columnsW columnsR- -> (columnsR -> Column SqlBool)+ -> (columnsR -> Field SqlBool) -> (columnsR -> columnsReturned) -> String arrangeDeleteReturningSql =@@ -156,7 +155,7 @@ -- ^ -> T.Table a columnsR -- ^ Table to delete rows from- -> (columnsR -> Column SqlBool)+ -> (columnsR -> Field SqlBool) -- ^ Predicate function @f@ to choose which rows to delete. -- 'runDeleteReturning' will delete rows for which @f@ returns @TRUE@ -- and leave unchanged rows for@@ -169,65 +168,24 @@ runDeleteReturningExplicit :: RS.FromFields columnsReturned haskells -> PGS.Connection -> T.Table a columnsR- -> (columnsR -> Column SqlBool)+ -> (columnsR -> Field SqlBool) -> (columnsR -> columnsReturned) -> IO [haskells] runDeleteReturningExplicit qr conn t cond r = PGS.queryWith_ parser conn (fromString (arrangeDeleteReturningSql u t cond r))- where IRQ.QueryRunner u _ _ = qr+ where IRQ.FromFields u _ _ = qr parser = IRQ.prepareRowParser qr (r v) TI.View v = TI.tableColumnsView (TI.tableColumns t) -arrangeDelete :: T.Table a columnsR -> (columnsR -> Column SqlBool) -> HSql.SqlDelete+arrangeDelete :: T.Table a columnsR -> (columnsR -> Field 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 t) -runInsert :: PGS.Connection -> T.Table fields fields' -> fields -> IO Int64-runInsert conn = PGS.execute_ conn . fromString .: arrangeInsertSql--runInsertReturning :: (D.Default RS.FromFields fieldsReturned haskells)- => PGS.Connection- -> T.Table fieldsW fieldsR- -> fieldsW- -> (fieldsR -> fieldsReturned)- -> IO [haskells]-runInsertReturning = runInsertReturningExplicit D.def--runInsertReturningExplicit :: RS.FromFields columnsReturned haskells- -> PGS.Connection- -> T.Table columnsW columnsR- -> columnsW- -> (columnsR -> columnsReturned)- -> IO [haskells]-runInsertReturningExplicit qr conn t =- runInsertManyReturningExplicitI qr conn t . return--runInsertManyReturningExplicitI :: RS.FromFields columnsReturned haskells- -> PGS.Connection- -> T.Table columnsW columnsR- -> [columnsW]- -> (columnsR -> columnsReturned)- -> IO [haskells]-runInsertManyReturningExplicitI qr conn t columns f =- runInsertManyReturningExplicit qr conn t columns f Nothing--arrangeInsert :: T.Table columns a -> columns -> HSql.SqlInsert-arrangeInsert t c = arrangeInsertManyI t (return c)--arrangeInsertSql :: T.Table columns a -> columns -> String-arrangeInsertSql = show . HPrint.ppInsert .: arrangeInsert--arrangeInsertManyI :: T.Table columns a -> NEL.NonEmpty columns -> HSql.SqlInsert-arrangeInsertManyI t columns = arrangeInsertMany t columns Nothing--arrangeInsertManySqlI :: T.Table columns a -> NEL.NonEmpty columns -> String-arrangeInsertManySqlI t c = arrangeInsertManySql t c Nothing- arrangeUpdate :: T.Table columnsW columnsR- -> (columnsR -> columnsW) -> (columnsR -> Column SqlBool)+ -> (columnsR -> columnsW) -> (columnsR -> Field SqlBool) -> HSql.SqlUpdate arrangeUpdate t update cond = SG.sqlUpdate SD.defaultSqlGenerator@@ -238,33 +196,17 @@ Column condExpr = cond tableCols arrangeUpdateSql :: T.Table columnsW columnsR- -> (columnsR -> columnsW) -> (columnsR -> Column SqlBool)+ -> (columnsR -> columnsW) -> (columnsR -> Field SqlBool) -> String arrangeUpdateSql = show . HPrint.ppUpdate .:. arrangeUpdate -arrangeDeleteSql :: T.Table a columnsR -> (columnsR -> Column SqlBool) -> String+arrangeDeleteSql :: T.Table a columnsR -> (columnsR -> Field SqlBool) -> String arrangeDeleteSql = show . HPrint.ppDelete .: arrangeDelete -arrangeInsertManyReturningI :: U.Unpackspec columnsReturned ignored- -> T.Table columnsW columnsR- -> NEL.NonEmpty columnsW- -> (columnsR -> columnsReturned)- -> Sql.Returning HSql.SqlInsert-arrangeInsertManyReturningI unpackspec t columns returningf =- arrangeInsertManyReturning unpackspec t columns returningf Nothing--arrangeInsertManyReturningSqlI :: U.Unpackspec columnsReturned ignored- -> T.Table columnsW columnsR- -> NEL.NonEmpty columnsW- -> (columnsR -> columnsReturned)- -> String-arrangeInsertManyReturningSqlI u t c r =- arrangeInsertManyReturningSql u t c r Nothing- arrangeUpdateReturning :: U.Unpackspec columnsReturned ignored -> T.Table columnsW columnsR -> (columnsR -> columnsW)- -> (columnsR -> Column SqlBool)+ -> (columnsR -> Field SqlBool) -> (columnsR -> columnsReturned) -> Sql.Returning HSql.SqlUpdate arrangeUpdateReturning unpackspec t updatef cond returningf =@@ -277,7 +219,7 @@ arrangeUpdateReturningSql :: U.Unpackspec columnsReturned ignored -> T.Table columnsW columnsR -> (columnsR -> columnsW)- -> (columnsR -> Column SqlBool)+ -> (columnsR -> Field SqlBool) -> (columnsR -> columnsReturned) -> String arrangeUpdateReturningSql =
src/Opaleye/Internal/MaybeFields.hs view
@@ -1,16 +1,14 @@+{-# OPTIONS_HADDOCK not-home #-}+ {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Arrows #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Opaleye.Internal.MaybeFields where -import Control.Applicative hiding (optional) import Control.Arrow (returnA, (<<<), (>>>)) import qualified Opaleye.Internal.Binary as B@@ -32,7 +30,7 @@ ifExplict, IfPP, EqPP(EqPP)) import qualified Opaleye.Internal.Lateral import qualified Opaleye.SqlTypes-import Opaleye.SqlTypes (SqlBool, IsSqlType, SqlInt4)+import Opaleye.SqlTypes (SqlBool, IsSqlType) import Control.Monad (replicateM_) @@ -42,7 +40,9 @@ import qualified Database.PostgreSQL.Simple.FromRow as PGSR --- | The Opaleye analogue of 'Data.Maybe.Maybe'+-- | The Opaleye analogue of 'Data.Maybe.Maybe'. A value of type+-- @MaybeFields a@ either contains a value of type @a@, or it contains+-- nothing. data MaybeFields fields = MaybeFields { mfPresent :: Opaleye.Column.Column Opaleye.SqlTypes.SqlBool@@ -105,13 +105,20 @@ fromMaybeFields :: PP.Default IfPP b b => b -> MaybeFields b -> b fromMaybeFields = fromMaybeFieldsExplicit PP.def --- | The Opaleye analogue of 'Data.Maybe.maybeToList'+-- | The Opaleye analogue of 'Data.Maybe.maybeToList'. Unless you are+-- using arrow notation you'll probably find 'catMaybeFields' easier+-- to use. maybeFieldsToSelect :: SelectArr (MaybeFields a) a maybeFieldsToSelect = proc mf -> do restrict -< mfPresent mf returnA -< mfFields mf --- | The Opaleye analogue of 'Data.Maybe.catMaybes'+-- | The Opaleye analogue of 'Data.Maybe.catMaybes'. Most commonly+-- you will want to use this at type+--+-- @+-- catMaybeFields :: Select (MaybeFields a) -> Select a+-- @ catMaybeFields :: SelectArr i (MaybeFields a) -> SelectArr i a catMaybeFields = (>>> maybeFieldsToSelect) @@ -133,20 +140,28 @@ where a `implies` b = Opaleye.Internal.Operators.not a .|| b +isJustAnd ::+ MaybeFields a ->+ (a -> Opaleye.Field.Field SqlBool) ->+ Opaleye.Field.Field SqlBool+isJustAnd ma cond = matchMaybe ma $ \case+ Nothing -> Opaleye.SqlTypes.sqlBool False+ Just a -> cond a+ optional :: SelectArr i a -> SelectArr i (MaybeFields a) optional = Opaleye.Internal.Lateral.laterally (optionalInternal (MaybeFields . isNotNull)) where isNotNull = Opaleye.Internal.Operators.not . Opaleye.Field.isNull -optionalInternal :: (Field (Opaleye.Column.Nullable SqlBool) -> a -> r) -> Select a -> Select r-optionalInternal f query = IQ.leftJoinQueryArr $ \arg ->+optionalInternal :: (Opaleye.Field.FieldNullable SqlBool -> a -> r) -> Select a -> Select r+optionalInternal f query = IQ.leftJoinQueryArr' $ do -- This is basically a left join on TRUE, but Shane (@duairc) -- wrote it to ensure that we don't need an Unpackspec a a.- let (r, right, tag') = flip IQ.runSimpleQueryArr arg $ proc () -> do+ let true = HPQ.ConstExpr (HPQ.BoolLit True)+ (r, right) <- IQ.runSimpleSelect $ proc () -> do a <- query -< ()- true_ <- Rebind.rebind -< Opaleye.Column.toNullable (IC.Column true)+ true_ <- Rebind.rebind -< Opaleye.Field.toNullable (IC.Column true) returnA -< f true_ a- true = HPQ.ConstExpr (HPQ.BoolLit True)- in (r, true, right, tag')+ pure $ \() -> (r, true, right) -- | An example to demonstrate how the functionality of (lateral)@@ -173,9 +188,25 @@ restrict -< cond a returnA -< a +-- | Convert @NULL@ to 'nothingFields' and non-@NULL@ to a 'justFields'+nullableToMaybeFields :: Opaleye.Field.FieldNullable a -> MaybeFields (Field a)+nullableToMaybeFields x = MaybeFields+ { mfPresent = Opaleye.Internal.Operators.not (Opaleye.Field.isNull x)+ , mfFields = unsafeFromNonNull x+ }+ where unsafeFromNonNull :: Opaleye.Field.FieldNullable a -> Field a+ unsafeFromNonNull = Opaleye.Field.unsafeCoerceField++-- | Convert 'nothingFields' to @NULL@ to a 'justFields' to non-@NULL@+maybeFieldsToNullable :: MaybeFields (Field a) -> Opaleye.Field.FieldNullable a+maybeFieldsToNullable x =+ IC.unsafeIfThenElse (mfPresent x)+ (Opaleye.Field.toNullable (mfFields x))+ Opaleye.Field.null+ fromFieldsMaybeFields :: RQ.FromFields fields haskells -> RQ.FromFields (MaybeFields fields) (Maybe haskells)-fromFieldsMaybeFields (RQ.QueryRunner u p c) = RQ.QueryRunner u' p' c'+fromFieldsMaybeFields (RQ.FromFields u p c) = RQ.FromFields u' p' c' where u' = () <$ productProfunctorMaybeFields U.unpackspecField u p' = \mf -> do@@ -245,7 +276,7 @@ newtype WithNulls p a b = WithNulls (p (MaybeFields a) b) --- | This is only safe if d is OK with having nulls passed through it+-- | This is only safe if @b@ is OK with having nulls passed through it -- when they claim to be non-null. mapMaybeFieldsWithNulls :: PP.ProductProfunctor p => p (Field SqlBool) (Field SqlBool)@@ -255,18 +286,15 @@ MaybeFields <$> P.lmap mfPresent (withNullsField b) <*> P.lmap mfFields d --- | This is only safe if d is OK with having nulls passed through it+-- | This is only safe if @col@ is OK with having nulls passed through it -- when they claim to be non-null. withNullsField :: (IsSqlType a, P.Profunctor p)- => p (IC.Column a) (IC.Column a)- -> WithNulls p (IC.Column a) (IC.Column a)+ => p (IC.Field_ n a) (IC.Field_ n a)+ -> WithNulls p (IC.Field_ n a) (IC.Field_ n a) withNullsField col = result where result = WithNulls (P.lmap (\(MaybeFields b c) -> ifExplict PP.def b c nullC) col)- nullC = IC.Column (V.nullPE (columnProxy result))-- columnProxy :: f (IC.Column sqlType) -> Maybe sqlType- columnProxy _ = Nothing+ nullC = V.nullFields V.nullspecField binaryspecMaybeFields :: WithNulls B.Binaryspec a b@@ -317,8 +345,8 @@ => PP.Default EqPP (MaybeFields a) (MaybeFields b) where def = eqPPMaybeFields PP.def -instance (P.Profunctor p, IsSqlType a, PP.Default p (IC.Column a) (IC.Column a))- => PP.Default (WithNulls p) (IC.Column a) (IC.Column a) where+instance (P.Profunctor p, IsSqlType a, PP.Default p (IC.Field_ n a) (IC.Field_ n a))+ => PP.Default (WithNulls p) (IC.Field_ n a) (IC.Field_ n a) where def = withNullsField PP.def instance PP.Default (WithNulls B.Binaryspec) a b
src/Opaleye/Internal/Operators.hs view
@@ -1,35 +1,37 @@+{-# OPTIONS_HADDOCK not-home #-}+ {-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} module Opaleye.Internal.Operators where -import Opaleye.Internal.Column (Column(Column))+import Control.Applicative (liftA2)++import Opaleye.Internal.Column (Field_(Column)) import qualified Opaleye.Internal.Column as C+import qualified Opaleye.Internal.PackMap as PM import qualified Opaleye.Internal.PrimQuery as PQ import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ import qualified Opaleye.Internal.QueryArr as QA-import qualified Opaleye.Internal.Table as Table-import qualified Opaleye.Internal.TableMaker as TM import qualified Opaleye.Internal.Tag as Tag-import qualified Opaleye.Internal.Unpackspec as U import qualified Opaleye.Internal.PGTypesExternal as T import qualified Opaleye.Field as F+import Opaleye.Field (Field) import qualified Opaleye.Select as S -import Data.Profunctor (Profunctor, dimap, lmap, rmap)+import Data.Profunctor (Profunctor, dimap) import Data.Profunctor.Product (ProductProfunctor, empty, (***!)) import qualified Data.Profunctor.Product.Default as D restrict :: S.SelectArr (F.Field T.SqlBool) ()-restrict = QA.QueryArr f where+restrict = QA.selectArr f where -- A where clause can always refer to columns defined by the query -- it references so needs no special treatment on LATERAL.- f (Column predicate, t0) = ((), \_ -> PQ.restrict predicate, t0)+ f = pure (\(Column predicate) -> ((), PQ.aRestrict predicate)) infix 4 .== (.==) :: forall columns. D.Default EqPP columns columns- => columns -> columns -> Column T.PGBool+ => columns -> columns -> Field T.PGBool (.==) = eqExplicit (D.def :: EqPP columns columns) infixr 2 .||@@ -40,75 +42,66 @@ infixr 3 .&& -- | Boolean and-(.&&) :: Column T.PGBool -> Column T.PGBool -> Column T.PGBool+(.&&) :: Field T.PGBool -> Field T.PGBool -> Field T.PGBool (.&&) = C.binOp HPQ.OpAnd not :: F.Field T.SqlBool -> F.Field T.SqlBool not = C.unOp HPQ.OpNot -newtype EqPP a b = EqPP (a -> a -> Column T.PGBool)+newtype EqPP a b = EqPP (a -> a -> Field T.PGBool) -eqPPField :: EqPP (Column a) ignored+eqPPField :: EqPP (Field a) ignored eqPPField = EqPP C.unsafeEq -eqExplicit :: EqPP columns a -> columns -> columns -> Column T.PGBool+eqExplicit :: EqPP columns a -> columns -> columns -> Field T.PGBool eqExplicit (EqPP f) = f -instance D.Default EqPP (Column a) (Column a) where+instance D.Default EqPP (Field a) (Field a) where def = eqPPField -newtype IfPP a b = IfPP (Column T.PGBool -> a -> a -> b)+newtype IfPP a b = IfPP (Field T.PGBool -> a -> a -> b) ifExplict :: IfPP columns columns'- -> Column T.PGBool+ -> Field T.PGBool -> columns -> columns -> columns' ifExplict (IfPP f) = f -ifPPField :: IfPP (Column a) (Column a)+ifPPField :: IfPP (Field_ n a) (Field_ n a) ifPPField = D.def -instance D.Default IfPP (Column a) (Column a) where+instance D.Default IfPP (Field_ n a) (Field_ n a) where def = IfPP C.unsafeIfThenElse --- This seems to be the only place we use ViewColumnMaker now.-data RelExprMaker a b =- forall c. RelExprMaker {- relExprVCM :: TM.ViewColumnMaker a c- , relExprCM :: U.Unpackspec c b- }+newtype RelExprPP a b = RelExprPP (Tag.Tag -> PM.PM [HPQ.Symbol] b) -relExprColumn :: RelExprMaker String (Column a)-relExprColumn = RelExprMaker TM.tableColumn U.unpackspecField -instance D.Default RelExprMaker String (Column a) where+runRelExprPP :: RelExprPP a b -> Tag.Tag -> (b, [HPQ.Symbol])+runRelExprPP (RelExprPP m) = PM.run . m+++instance D.Default RelExprPP (Field_ n a) (Field_ n a) where def = relExprColumn -runRelExprMaker :: RelExprMaker strings columns- -> Tag.Tag- -> strings- -> (columns, [(HPQ.Symbol, HPQ.PrimExpr)])-runRelExprMaker rem_ tag =- case rem_ of RelExprMaker vcm cm -> Table.runColumnMaker cm tag- . TM.runViewColumnMaker vcm -relationValuedExprExplicit :: RelExprMaker strings columns- -> strings+relExprColumn :: RelExprPP (Field_ n a) (Field_ n a)+relExprColumn = RelExprPP $ fmap Column . PM.extract "relExpr"+++relationValuedExprExplicit :: RelExprPP columns columns -> (a -> HPQ.PrimExpr) -> QA.QueryArr a columns-relationValuedExprExplicit rem_ strings pe =- QA.productQueryArr $ \(a, tag) ->- let (primExprs, projcols) = runRelExprMaker rem_ tag strings- primQ :: PQ.PrimQuery- primQ = PQ.RelExpr (pe a) projcols- in (primExprs, primQ, Tag.next tag)+relationValuedExprExplicit relExprPP pe =+ QA.productQueryArr' $ do+ (columns, symbols) <- runRelExprPP relExprPP <$> Tag.fresh+ pure $ \a -> (columns, PQ.RelExpr (pe a) symbols) -relationValuedExpr :: D.Default RelExprMaker strings columns- => strings- -> (a -> HPQ.PrimExpr)++relationValuedExpr :: D.Default RelExprPP columns columns+ => (a -> HPQ.PrimExpr) -> QA.QueryArr a columns relationValuedExpr = relationValuedExprExplicit D.def @@ -122,16 +115,13 @@ EqPP f ***! EqPP f' = EqPP (\a a' -> f (fst a) (fst a') .&& f' (snd a) (snd a')) -instance Profunctor RelExprMaker where- dimap f g (RelExprMaker a b) = RelExprMaker (lmap f a) (rmap g b)+instance Profunctor RelExprPP where+ dimap _ f (RelExprPP m) = RelExprPP (fmap (fmap f) m) -instance ProductProfunctor RelExprMaker where- empty = RelExprMaker empty empty- f ***! g = case f of RelExprMaker vcmf cmf ->- case g of RelExprMaker vcmg cmg ->- h vcmf vcmg cmf cmg- where h vcmg vcmf cmg cmf = RelExprMaker (vcmg ***! vcmf)- (cmg ***! cmf)+instance ProductProfunctor RelExprPP where+ empty = RelExprPP (pure (pure ()))+ RelExprPP f ***! RelExprPP g =+ RelExprPP $ liftA2 (liftA2 (,)) f g instance Profunctor IfPP where dimap f g (IfPP h) = IfPP (\b a a' -> g (h b (f a) (f a')))
src/Opaleye/Internal/Optimize.hs view
@@ -8,23 +8,24 @@ import Opaleye.Internal.Helpers ((.:)) import qualified Data.List.NonEmpty as NEL-import Data.Semigroup ((<>)) -import Control.Applicative ((<$>), (<*>), liftA2, pure)+import Control.Applicative (liftA2) import Control.Arrow (first) optimize :: PQ.PrimQuery' a -> PQ.PrimQuery' a-optimize = mergeProduct . removeUnit+optimize = PQ.foldPrimQuery (noSingletonProduct+ `PQ.composePrimQueryFold` mergeProduct+ `PQ.composePrimQueryFold` removeUnit) -removeUnit :: PQ.PrimQuery' a -> PQ.PrimQuery' a-removeUnit = PQ.foldPrimQuery PQ.primQueryFoldDefault { PQ.product = product }+removeUnit :: PQ.PrimQueryFoldP a (PQ.PrimQuery' a) (PQ.PrimQuery' a)+removeUnit = PQ.primQueryFoldDefault { PQ.product = product } where product pqs = PQ.Product pqs' where pqs' = case NEL.nonEmpty (NEL.filter (not . PQ.isUnit . snd) pqs) of Nothing -> return (pure PQ.Unit) Just xs -> xs -mergeProduct :: PQ.PrimQuery' a -> PQ.PrimQuery' a-mergeProduct = PQ.foldPrimQuery PQ.primQueryFoldDefault { PQ.product = product }+mergeProduct :: PQ.PrimQueryFoldP a (PQ.PrimQuery' a) (PQ.PrimQuery' a)+mergeProduct = PQ.primQueryFoldDefault { PQ.product = product } where product pqs pes = PQ.Product pqs' (pes ++ pes') where pqs' = pqs >>= queries queries (lat, PQ.Product qs _) = fmap (first (lat <>)) qs@@ -33,6 +34,12 @@ conds (_lat, PQ.Product _ cs) = cs conds _ = [] +noSingletonProduct :: PQ.PrimQueryFoldP a (PQ.PrimQuery' a) (PQ.PrimQuery' a)+noSingletonProduct = PQ.primQueryFoldDefault { PQ.product = product }+ where product pqs conds = case (NEL.uncons pqs, conds) of+ (((PQ.NonLateral, x), Nothing), []) -> x+ _ -> PQ.Product pqs conds+ removeEmpty :: PQ.PrimQuery' a -> Maybe (PQ.PrimQuery' b) removeEmpty = PQ.foldPrimQuery PQ.PrimQueryFold { PQ.unit = return PQ.Unit@@ -45,6 +52,7 @@ \x y -> PQ.Product <$> sequenceOf (traverse._2) x <*> pure y , PQ.aggregate = fmap . PQ.Aggregate+ , PQ.window = fmap . PQ.Window , PQ.distinctOnOrderBy = \mDistinctOns -> fmap . PQ.DistinctOnOrderBy mDistinctOns , PQ.limit = fmap . PQ.Limit , PQ.join = \jt pe pq1 pq2 -> PQ.Join jt pe <$> sequence pq1 <*> sequence pq2@@ -64,6 +72,7 @@ , PQ.relExpr = return .: PQ.RelExpr , PQ.rebind = \b -> fmap . PQ.Rebind b , PQ.forUpdate = fmap PQ.ForUpdate+ , PQ.with = \recursive materialized name cols -> liftA2 (PQ.With recursive materialized name cols) } where -- If only the first argument is Just, do n1 on it -- If only the second argument is Just, do n2 on it
src/Opaleye/Internal/Order.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_HADDOCK not-home #-}+ module Opaleye.Internal.Order where import Data.Function (on)@@ -8,11 +10,10 @@ import qualified Data.Profunctor as P import qualified Data.Semigroup as S import qualified Data.Void as Void-import qualified Opaleye.Column as C+import qualified Opaleye.Field as F import qualified Opaleye.Internal.Column as IC import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ import qualified Opaleye.Internal.PrimQuery as PQ-import qualified Opaleye.Internal.Tag as T import qualified Opaleye.Internal.Unpackspec as U {-|@@ -23,9 +24,9 @@ used, and so on. -} --- Like the (columns -> RowParser haskells) field of QueryRunner this+-- Like the (columns -> RowParser haskells) field of FromFields this -- type is "too big". We never actually look at the 'a' (in the--- QueryRunner case the 'colums') except to check the "structure".+-- FromFields case the 'columns') except to check the "structure". -- This is so we can support a SumProfunctor instance. newtype Order a = Order (a -> [(HPQ.OrderOp, HPQ.PrimExpr)]) @@ -48,55 +49,45 @@ lose f = C.contramap f (Order Void.absurd) choose f (Order o) (Order o') = C.contramap f (Order (either o o')) -order :: HPQ.OrderOp -> (a -> C.Column b) -> Order a+order :: HPQ.OrderOp -> (a -> F.Field_ n b) -> Order a order op f = Order (fmap (\column -> [(op, IC.unColumn column)]) f) -orderByU :: Order a -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag)-orderByU os (columns, primQ, t) = (columns, primQ', t)+orderByU :: Order a -> (a, PQ.PrimQuery) -> (a, PQ.PrimQuery)+orderByU os (columns, primQ) = (columns, primQ') where primQ' = PQ.DistinctOnOrderBy Nothing oExprs primQ oExprs = orderExprs columns os orderExprs :: a -> Order a -> [HPQ.OrderExpr] orderExprs x (Order os) = map (uncurry HPQ.OrderExpr) (os x) -limit' :: Int -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag)-limit' n (x, q, t) = (x, PQ.Limit (PQ.LimitOp n) q, t)+limit' :: HPQ.PrimExpr -> (a, PQ.PrimQuery) -> (a, PQ.PrimQuery)+limit' n (x, q) = (x, PQ.Limit (PQ.LimitOp n) q) -offset' :: Int -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag)-offset' n (x, q, t) = (x, PQ.Limit (PQ.OffsetOp n) q, t)+offset' :: HPQ.PrimExpr -> (a, PQ.PrimQuery) -> (a, PQ.PrimQuery)+offset' n (x, q) = (x, PQ.Limit (PQ.OffsetOp n) q) distinctOn :: U.Unpackspec b b -> (a -> b)- -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag)+ -> (a, PQ.PrimQuery) -> (a, PQ.PrimQuery) distinctOn ups proj = distinctOnBy ups proj M.mempty -distinctOnCorrect :: U.Unpackspec b b -> (a -> b)- -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag)-distinctOnCorrect ups proj = distinctOnByCorrect ups proj M.mempty- distinctOnBy :: U.Unpackspec b b -> (a -> b) -> Order a- -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag)-distinctOnBy ups proj ord (cols, pq, t) = (cols, pqOut, t)- where pqOut = case U.collectPEs ups (proj cols) of- x:xs -> PQ.DistinctOnOrderBy (Just $ x NL.:| xs) (orderExprs cols ord) pq- [] -> pq--distinctOnByCorrect :: U.Unpackspec b b -> (a -> b) -> Order a- -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag)-distinctOnByCorrect ups proj ord (cols, pq, t) = (cols, pqOut, t)- where pqOut = case U.collectPEs ups (proj cols) of- x:xs -> PQ.DistinctOnOrderBy (Just $ x NL.:| xs) oexprs pq- [] -> PQ.Limit (PQ.LimitOp 1) (PQ.DistinctOnOrderBy Nothing oexprs pq)+ -> (a, PQ.PrimQuery) -> (a, PQ.PrimQuery)+distinctOnBy ups proj ord (cols, pq) = (cols, pqOut)+ where pqOut = case NL.nonEmpty (U.collectPEs ups (proj cols)) of+ Just xs -> PQ.DistinctOnOrderBy (Just xs) oexprs pq+ Nothing -> PQ.Limit (PQ.LimitOp one) (PQ.DistinctOnOrderBy Nothing oexprs pq) oexprs = orderExprs cols ord+ one = HPQ.ConstExpr (HPQ.IntegerLit 1) -- | Order the results of a given query exactly, as determined by the given list--- of input columns. Note that this list does not have to contain an entry for+-- of input fields. Note that this list does not have to contain an entry for -- every result in your query: you may exactly order only a subset of results, -- if you wish. Rows that are not ordered according to the input list are -- returned /after/ the ordered results, in the usual order the database would -- return them (e.g. sorted by primary key). Exactly-ordered results always come -- first in a result set. Entries in the input list that are /not/ present in -- result of a query are ignored.-exact :: [IC.Column b] -> (a -> IC.Column b) -> Order a+exact :: [IC.Field_ n b] -> (a -> IC.Field_ n b) -> Order a exact xs k = maybe M.mempty go (NL.nonEmpty xs) where -- Create an equality AST node, between two columns, essentially -- stating "(column = value)" syntactically.
src/Opaleye/Internal/PGTypes.hs view
@@ -1,9 +1,10 @@+{-# OPTIONS_HADDOCK not-home #-}+ {-# LANGUAGE ScopedTypeVariables #-} module Opaleye.Internal.PGTypes where -import Opaleye.Internal.Column (Column(Column))-import qualified Opaleye.Internal.Column as C+import Opaleye.Internal.Column (Field, Field_(Column)) import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ import Data.Proxy (Proxy(..))@@ -14,17 +15,19 @@ import qualified Data.ByteString as SByteString import qualified Data.ByteString.Lazy as LByteString import qualified Data.Time.Format.ISO8601.Compat as Time+import Text.PrettyPrint.HughesPJ ((<>), doubleQuotes, render, text)+import Prelude hiding ((<>)) -unsafePgFormatTime :: Time.ISO8601 t => HPQ.Name -> t -> Column c+unsafePgFormatTime :: Time.ISO8601 t => HPQ.Name -> t -> Field c unsafePgFormatTime typeName = castToType typeName . format where format = quote . Time.iso8601Show quote s = "'" ++ s ++ "'" -literalColumn :: forall a. IsSqlType a => HPQ.Literal -> Column a+literalColumn :: forall a. IsSqlType a => HPQ.Literal -> Field a literalColumn = Column . HPQ.CastExpr (showSqlType (Proxy :: Proxy a)) . HPQ.ConstExpr -castToType :: HPQ.Name -> String -> Column c+castToType :: HPQ.Name -> String -> Field_ n c castToType typeName = Column . HPQ.CastExpr typeName . HPQ.ConstExpr . HPQ.OtherLit @@ -34,10 +37,24 @@ lazyDecodeUtf8 :: LByteString.ByteString -> String lazyDecodeUtf8 = LText.unpack . LTextEncoding.decodeUtf8 +-- | Render the name of a type with a schema+--+-- @+-- > putStrLn (sqlTypeWithSchema "my_schema" "my_type")+-- "my_schema"."my_type"+-- @+--+-- @+-- instance 'IsSqlType' SqlMyTypeWithSchema where+-- 'showSqlType' = \\_ -> sqlTypeWithSchema "my_schema" "my_type"+-- @+sqlTypeWithSchema :: String -> String -> String+sqlTypeWithSchema schema type_ =+ render (doubleQuotes (text schema)+ <> text "."+ <> doubleQuotes (text type_))+ class IsSqlType sqlType where showSqlType :: proxy sqlType -> String {-# MINIMAL showSqlType #-}--instance IsSqlType a => IsSqlType (C.Nullable a) where- showSqlType _ = showSqlType (Proxy :: Proxy a)
src/Opaleye/Internal/PGTypesExternal.hs view
@@ -1,11 +1,14 @@+{-# OPTIONS_HADDOCK not-home #-}+ {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-} module Opaleye.Internal.PGTypesExternal (module Opaleye.Internal.PGTypesExternal, IsSqlType(..)) where -import Opaleye.Internal.Column (Column)+import Opaleye.Internal.Column (Field_, Field) import qualified Opaleye.Internal.Column as C import qualified Opaleye.Internal.PGTypes as IPT import Opaleye.Internal.PGTypes (IsSqlType(..))@@ -21,16 +24,18 @@ import qualified Data.ByteString.Lazy as LByteString import Data.Scientific as Sci import qualified Data.Time.Compat as Time-import qualified Data.Time.Format.ISO8601.Compat as Time.Format.ISO8601-import qualified Data.UUID as UUID+import qualified Data.UUID.Types as UUID -import Data.Int (Int64)+import Data.Int (Int16, Int64) import qualified Database.PostgreSQL.Simple.Range as R instance C.SqlNum SqlFloat8 where sqlFromInteger = pgDouble . fromInteger +instance C.SqlNum SqlInt2 where+ sqlFromInteger = pgInt2 . fromInteger+ instance C.SqlNum SqlInt4 where sqlFromInteger = pgInt4 . fromInteger @@ -59,73 +64,76 @@ -- * Creating SQL values -pgString :: String -> Column PGText+pgString :: String -> Field PGText pgString = IPT.literalColumn . HPQ.StringLit -pgLazyByteString :: LByteString.ByteString -> Column PGBytea+pgLazyByteString :: LByteString.ByteString -> Field PGBytea pgLazyByteString = IPT.literalColumn . HPQ.ByteStringLit . LByteString.toStrict -pgStrictByteString :: SByteString.ByteString -> Column PGBytea+pgStrictByteString :: SByteString.ByteString -> Field PGBytea pgStrictByteString = IPT.literalColumn . HPQ.ByteStringLit -pgStrictText :: SText.Text -> Column PGText+pgStrictText :: SText.Text -> Field PGText pgStrictText = IPT.literalColumn . HPQ.StringLit . SText.unpack -pgLazyText :: LText.Text -> Column PGText+pgLazyText :: LText.Text -> Field PGText pgLazyText = IPT.literalColumn . HPQ.StringLit . LText.unpack -sqlStringVarcharN :: String -> Column SqlVarcharN+sqlStringVarcharN :: String -> Field SqlVarcharN sqlStringVarcharN = IPT.literalColumn . HPQ.StringLit -sqlStrictTextVarcharN :: SText.Text -> Column SqlVarcharN+sqlStrictTextVarcharN :: SText.Text -> Field SqlVarcharN sqlStrictTextVarcharN = IPT.literalColumn . HPQ.StringLit . SText.unpack -sqlLazyTextVarcharN :: LText.Text -> Column SqlVarcharN+sqlLazyTextVarcharN :: LText.Text -> Field SqlVarcharN sqlLazyTextVarcharN = IPT.literalColumn . HPQ.StringLit . LText.unpack -pgNumeric :: Sci.Scientific -> Column PGNumeric+pgNumeric :: Sci.Scientific -> Field PGNumeric pgNumeric = IPT.literalColumn . HPQ.NumericLit -pgInt4 :: Int -> Column PGInt4+pgInt2 :: Int16 -> Field PGInt2+pgInt2 = IPT.literalColumn . HPQ.IntegerLit . fromIntegral++pgInt4 :: Int -> Field PGInt4 pgInt4 = IPT.literalColumn . HPQ.IntegerLit . fromIntegral -pgInt8 :: Int64 -> Column PGInt8+pgInt8 :: Int64 -> Field PGInt8 pgInt8 = IPT.literalColumn . HPQ.IntegerLit . fromIntegral -pgDouble :: Double -> Column PGFloat8+pgDouble :: Double -> Field PGFloat8 pgDouble = IPT.literalColumn . HPQ.DoubleLit -pgBool :: Bool -> Column PGBool+pgBool :: Bool -> Field PGBool pgBool = IPT.literalColumn . HPQ.BoolLit -pgUUID :: UUID.UUID -> Column PGUuid+pgUUID :: UUID.UUID -> Field PGUuid pgUUID = IPT.literalColumn . HPQ.StringLit . UUID.toString -pgDay :: Time.Day -> Column PGDate+pgDay :: Time.Day -> Field PGDate pgDay = IPT.unsafePgFormatTime "date" -pgUTCTime :: Time.UTCTime -> Column PGTimestamptz+pgUTCTime :: Time.UTCTime -> Field PGTimestamptz pgUTCTime = IPT.unsafePgFormatTime "timestamptz" -pgLocalTime :: Time.LocalTime -> Column PGTimestamp+pgLocalTime :: Time.LocalTime -> Field PGTimestamp pgLocalTime = IPT.unsafePgFormatTime "timestamp" -pgZonedTime :: Time.ZonedTime -> Column PGTimestamptz+pgZonedTime :: Time.ZonedTime -> Field PGTimestamptz pgZonedTime = IPT.unsafePgFormatTime "timestamptz" -pgTimeOfDay :: Time.TimeOfDay -> Column PGTime+pgTimeOfDay :: Time.TimeOfDay -> Field PGTime pgTimeOfDay = IPT.unsafePgFormatTime "time" -- "We recommend not using the type time with time zone" -- http://www.postgresql.org/docs/8.3/static/datatype-datetime.html -sqlInterval :: Time.CalendarDiffTime -> Column PGInterval+sqlInterval :: Time.CalendarDiffTime -> Field PGInterval sqlInterval = IPT.unsafePgFormatTime "interval" -pgCiStrictText :: CI.CI SText.Text -> Column PGCitext+pgCiStrictText :: CI.CI SText.Text -> Field PGCitext pgCiStrictText = IPT.literalColumn . HPQ.StringLit . SText.unpack . CI.original -pgCiLazyText :: CI.CI LText.Text -> Column PGCitext+pgCiLazyText :: CI.CI LText.Text -> Field PGCitext pgCiLazyText = IPT.literalColumn . HPQ.StringLit . LText.unpack . CI.original -- No CI String instance since postgresql-simple doesn't define@@ -133,16 +141,16 @@ -- The json data type was introduced in PostgreSQL version 9.2 -- JSON values must be SQL string quoted-pgJSON :: String -> Column PGJson+pgJSON :: String -> Field PGJson pgJSON = IPT.castToType "json" . HSD.quote -pgStrictJSON :: SByteString.ByteString -> Column PGJson+pgStrictJSON :: SByteString.ByteString -> Field PGJson pgStrictJSON = pgJSON . IPT.strictDecodeUtf8 -pgLazyJSON :: LByteString.ByteString -> Column PGJson+pgLazyJSON :: LByteString.ByteString -> Field PGJson pgLazyJSON = pgJSON . IPT.lazyDecodeUtf8 -pgValueJSON :: Ae.ToJSON a => a -> Column PGJson+pgValueJSON :: Ae.ToJSON a => a -> Field PGJson pgValueJSON = pgLazyJSON . Ae.encode -- The jsonb data type was introduced in PostgreSQL version 9.4@@ -150,29 +158,29 @@ -- -- TODO: We need to add literal JSON and JSONB types so we can say -- `castToTypeTyped JSONB` rather than `castToType "jsonb"`.-pgJSONB :: String -> Column PGJsonb+pgJSONB :: String -> Field PGJsonb pgJSONB = IPT.castToType "jsonb" . HSD.quote -pgStrictJSONB :: SByteString.ByteString -> Column PGJsonb+pgStrictJSONB :: SByteString.ByteString -> Field PGJsonb pgStrictJSONB = pgJSONB . IPT.strictDecodeUtf8 -pgLazyJSONB :: LByteString.ByteString -> Column PGJsonb+pgLazyJSONB :: LByteString.ByteString -> Field PGJsonb pgLazyJSONB = pgJSONB . IPT.lazyDecodeUtf8 -pgValueJSONB :: Ae.ToJSON a => a -> Column PGJsonb+pgValueJSONB :: Ae.ToJSON a => a -> Field PGJsonb pgValueJSONB = pgLazyJSONB . Ae.encode -pgArray :: forall a b. IsSqlType b- => (a -> C.Column b) -> [a] -> C.Column (PGArray b)+pgArray :: forall a b n. IsSqlType b+ => (a -> Field_ n b) -> [a] -> Field (SqlArray_ n b) pgArray pgEl xs = C.unsafeCast arrayTy $ C.Column (HPQ.ArrayExpr (map oneEl xs)) where oneEl = C.unColumn . pgEl- arrayTy = showSqlType ([] :: [PGArray b])+ arrayTy = showSqlType ([] :: [SqlArray_ n b]) -pgRange :: forall a b. IsRangeType b- => (a -> C.Column b) -> R.RangeBound a -> R.RangeBound a- -> C.Column (PGRange b)+pgRange :: forall a b n n'. IsRangeType b+ => (a -> Field_ n b) -> R.RangeBound a -> R.RangeBound a+ -> Field_ n' (SqlRange b) pgRange pgEl start end = C.Column (HPQ.RangeExpr (showRangeType ([] :: [b])) (oneEl start) (oneEl end)) where oneEl (R.Inclusive a) = HPQ.Inclusive . C.unColumn $ pgEl a@@ -214,7 +222,7 @@ showSqlType _ = "citext" instance IsSqlType SqlBytea where showSqlType _ = "bytea"-instance IsSqlType a => IsSqlType (SqlArray a) where+instance IsSqlType a => IsSqlType (SqlArray_ n a) where showSqlType _ = showSqlType ([] :: [a]) ++ "[]" instance IsSqlType SqlJson where showSqlType _ = "json"@@ -279,7 +287,8 @@ data SqlTimestamptz data SqlUuid data SqlCitext-data SqlArray a+data SqlArray_ (n :: C.Nullability) a+type SqlArray = SqlArray_ C.NonNullable data SqlBytea data SqlJson data SqlJsonb
src/Opaleye/Internal/PackMap.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TupleSections #-} module Opaleye.Internal.PackMap where @@ -6,7 +7,8 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ -import Control.Applicative (Applicative, pure, (<*>), liftA2)+import Control.Applicative (liftA2)+import Control.Arrow (first, second) import qualified Control.Monad.Trans.State as State import Data.Profunctor (Profunctor, dimap, rmap) import Data.Profunctor.Product (ProductProfunctor)@@ -43,7 +45,7 @@ newtype PackMap a b s t = PackMap (forall f. Applicative f => (a -> f b) -> s -> f t) --- | Replaces the targeted occurences of @a@ in @s@ with @b@ (changing+-- | Replaces the targeted occurrences of @a@ in @s@ with @b@ (changing -- the @s@ to a @t@ in the process). This can be done via an -- 'Applicative' action. --@@ -55,7 +57,7 @@ -- | Modify the targeted occurrences of @a@ in @s@ with @b@ (changing -- the @s@ to a @t@ in the process). ----- 'overPM' is just like @over@ from the @lens@ pacakge.+-- 'overPM' is just like @over@ from the @lens@ package. overPM :: PackMap a b s t -> (a -> b) -> s -> t overPM p f = I.runIdentity . traversePM p (I.Identity . f) @@ -90,7 +92,7 @@ -- function and the unique 'T.Tag' that is used as part of our -- @QueryArr@. ----- Add the fresh name and the input value it refers to to the list in+-- Add the fresh name and the input value it refers to the list in -- the state parameter. extractAttrPE :: (primExpr -> String -> String) -> T.Tag@@ -109,6 +111,21 @@ -> primExpr -> PM [(HPQ.Symbol, primExpr)] HPQ.PrimExpr extractAttr s = extractAttrPE (const (s ++))++isoState ::+ Functor m =>+ (s1 -> s2) ->+ (s2 -> s1) ->+ State.StateT s1 m a ->+ State.StateT s2 m a+isoState to from =+ State.StateT . ((fmap . second) to .) . (. from) . State.runStateT++extract :: String -> T.Tag -> PM [HPQ.Symbol] HPQ.PrimExpr+extract s t = isoState to from (extractAttr s t ())+ where+ to = (first . fmap) fst+ from = (first . fmap) (\x -> (x, ())) -- }
src/Opaleye/Internal/PrimQuery.hs view
@@ -1,14 +1,17 @@+{-# LANGUAGE LambdaCase #-}+ module Opaleye.Internal.PrimQuery where import Prelude hiding (product) import qualified Data.List.NonEmpty as NEL-import Data.Semigroup (Semigroup, (<>)) import qualified Opaleye.Internal.HaskellDB.Sql as HSql import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ import Opaleye.Internal.HaskellDB.PrimQuery (Symbol) -data LimitOp = LimitOp Int | OffsetOp Int | LimitOffsetOp Int Int+data LimitOp = LimitOp HPQ.PrimExpr+ | OffsetOp HPQ.PrimExpr+ | LimitOffsetOp HPQ.PrimExpr HPQ.PrimExpr deriving Show data BinOp = Except@@ -45,8 +48,80 @@ mappend = (<>) mempty = NonLateral +data Recursive = NonRecursive | Recursive+ deriving Show++data Materialized = Materialized | NotMaterialized+ deriving Show++aLeftJoin :: HPQ.PrimExpr -> PrimQuery -> PrimQueryArr+aLeftJoin cond primQuery' = PrimQueryArr $ \lat primQueryL ->+ Join LeftJoin cond (NonLateral, primQueryL) (lat, primQuery')++aProduct :: PrimQuery -> PrimQueryArr+aProduct pq = PrimQueryArr (\lat primQuery -> times lat primQuery pq)++aSemijoin :: SemijoinType -> PrimQuery -> PrimQueryArr+aSemijoin joint existsQ = PrimQueryArr $ \_ primQ -> Semijoin joint primQ existsQ++aRebind :: Bindings HPQ.PrimExpr -> PrimQueryArr+aRebind bindings = PrimQueryArr $ \_ -> Rebind True bindings++aRebindNoStar :: Bindings HPQ.PrimExpr -> PrimQueryArr+aRebindNoStar bindings = PrimQueryArr $ \_ -> Rebind False bindings++aRestrict :: HPQ.PrimExpr -> PrimQueryArr+aRestrict predicate = PrimQueryArr $ \_ -> restrict predicate++aLabel :: String -> PrimQueryArr+aLabel l = PrimQueryArr $ \_ primQ -> Label l primQ++-- The function 'Lateral -> PrimQuery -> PrimQuery' represents a+-- select arrow in the following way:+--+-- Lateral+-- -- ^ Whether to join me laterally+-- -> PrimQuery+-- -- ^ The query that I will be joined after. If I refer to columns+-- -- in here in a way that is only valid when I am joined laterally,+-- -- then Lateral must be passed in as the argument above.+-- -> PrimQuery+-- -- ^ The result after joining me+--+-- It is *always* valid to pass Lateral as the first argument. So why+-- wouldn't we do that? Because we don't want to generate lateral+-- subqueries if they are not needed; it might have performance+-- implications. Even though there is good evidence that it *doesn't*+-- have performance implications+-- (https://github.com/tomjaguarpaw/haskell-opaleye/pull/480) we still+-- want to be cautious.+--+-- Not every function of type `Lateral -> PrimQuery -> PrimQuery` is+-- valid to be a PrimQuery. I think the condition that they must+-- satisfy for validity is+--+-- q == lateral (aProduct (toPrimQuery q)+--+-- where == is observable equivalence, i.e. both queries must give the+-- same results when combined with other queries and then run.+newtype PrimQueryArr =+ PrimQueryArr { runPrimQueryArr :: Lateral -> PrimQuery -> PrimQuery }++instance Semigroup PrimQueryArr where+ PrimQueryArr f1 <> PrimQueryArr f2 = PrimQueryArr (\lat -> f2 lat . f1 lat)++instance Monoid PrimQueryArr where+ mappend = (<>)+ mempty = PrimQueryArr (\_ -> id)++lateral :: PrimQueryArr -> PrimQueryArr+lateral (PrimQueryArr pq) = PrimQueryArr (\_ -> pq Lateral)++toPrimQuery :: PrimQueryArr -> PrimQuery+toPrimQuery (PrimQueryArr f) = f NonLateral Unit+ -- We use a 'NEL.NonEmpty' for Product because otherwise we'd have to check--- for emptiness explicity in the SQL generation phase.+-- for emptiness explicitly in the SQL generation phase. -- The type parameter 'a' is used to control whether the 'Empty' -- constructor can appear. If 'a' = '()' then it can appear. If 'a'@@ -54,16 +129,15 @@ -- convenient to allow 'Empty', but it is hard to represent 'Empty' in -- SQL so we remove it in 'Optimize' and set 'a = Void'. data PrimQuery' a = Unit+ -- Remove the Empty constructor in 0.10 | Empty a | BaseTable TableIdentifier (Bindings HPQ.PrimExpr) | Product (NEL.NonEmpty (Lateral, PrimQuery' a)) [HPQ.PrimExpr] -- | The subqueries to take the product of and the -- restrictions to apply- | Aggregate (Bindings (Maybe (HPQ.AggrOp,- [HPQ.OrderExpr],- HPQ.AggrDistinct),- HPQ.Symbol))+ | Aggregate (Bindings HPQ.Aggregate) (PrimQuery' a)+ | Window (Bindings (HPQ.WndwOp, HPQ.Partition)) (PrimQuery' a) -- | Represents both @DISTINCT ON@ and @ORDER BY@ -- clauses. In order to represent valid SQL only, -- @DISTINCT ON@ expressions are always@@ -84,7 +158,7 @@ | Binary BinOp (PrimQuery' a, PrimQuery' a) | Label String (PrimQuery' a)- | RelExpr HPQ.PrimExpr (Bindings HPQ.PrimExpr)+ | RelExpr HPQ.PrimExpr [Symbol] | Rebind Bool (Bindings HPQ.PrimExpr) (PrimQuery' a)@@ -93,42 +167,45 @@ -- ForUpdate in the future -- -- https://www.postgresql.org/docs/current/sql-select.html#SQL-FOR-UPDATE-SHARE+ | With Recursive (Maybe Materialized) Symbol [Symbol] (PrimQuery' a) (PrimQuery' a) deriving Show type PrimQuery = PrimQuery' ()-type PrimQueryFold = PrimQueryFold' ()+type PrimQueryFold p = PrimQueryFold' () p -data PrimQueryFold' a p = PrimQueryFold- { unit :: p- , empty :: a -> p- , baseTable :: TableIdentifier -> Bindings HPQ.PrimExpr -> p- , product :: NEL.NonEmpty (Lateral, p) -> [HPQ.PrimExpr] -> p- , aggregate :: Bindings (Maybe- (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct),- HPQ.Symbol)- -> p+type PrimQueryFold' a p = PrimQueryFoldP a p p++data PrimQueryFoldP a p p' = PrimQueryFold+ { unit :: p'+ , empty :: a -> p'+ , baseTable :: TableIdentifier -> Bindings HPQ.PrimExpr -> p'+ , product :: NEL.NonEmpty (Lateral, p) -> [HPQ.PrimExpr] -> p'+ , aggregate :: Bindings HPQ.Aggregate -> p+ -> p'+ , window :: Bindings (HPQ.WndwOp, HPQ.Partition) -> p -> p' , distinctOnOrderBy :: Maybe (NEL.NonEmpty HPQ.PrimExpr) -> [HPQ.OrderExpr] -> p- -> p- , limit :: LimitOp -> p -> p+ -> p'+ , limit :: LimitOp -> p -> p' , join :: JoinType -> HPQ.PrimExpr -> (Lateral, p) -> (Lateral, p)- -> p- , semijoin :: SemijoinType -> p -> p -> p- , exists :: Symbol -> p -> p- , values :: [Symbol] -> NEL.NonEmpty [HPQ.PrimExpr] -> p+ -> p'+ , semijoin :: SemijoinType -> p -> p -> p'+ , exists :: Symbol -> p -> p'+ , values :: [Symbol] -> NEL.NonEmpty [HPQ.PrimExpr] -> p' , binary :: BinOp -> (p, p)- -> p- , label :: String -> p -> p- , relExpr :: HPQ.PrimExpr -> Bindings HPQ.PrimExpr -> p+ -> p'+ , label :: String -> p -> p'+ , relExpr :: HPQ.PrimExpr -> [Symbol] -> p' -- ^ A relation-valued expression- , rebind :: Bool -> Bindings HPQ.PrimExpr -> p -> p- , forUpdate :: p -> p+ , rebind :: Bool -> Bindings HPQ.PrimExpr -> p -> p'+ , forUpdate :: p -> p'+ , with :: Recursive -> Maybe Materialized -> Symbol -> [Symbol] -> p -> p -> p' } @@ -139,6 +216,7 @@ , baseTable = BaseTable , product = Product , aggregate = Aggregate+ , window = Window , distinctOnOrderBy = DistinctOnOrderBy , limit = Limit , join = Join@@ -150,28 +228,71 @@ , exists = Exists , rebind = Rebind , forUpdate = ForUpdate+ , with = With } +dimapPrimQueryFold :: (q -> p)+ -> (p' -> q')+ -> PrimQueryFoldP a p p'+ -> PrimQueryFoldP a q q'+dimapPrimQueryFold self g f = PrimQueryFold+ { unit = g (unit f)+ , empty = g . empty f+ , baseTable = \ti bs -> g (baseTable f ti bs)+ , product = \ps conds -> g (product f ((fmap . fmap) self ps) conds)+ , aggregate = \b p -> g (aggregate f b (self p))+ , window = \b p -> g (window f b (self p))+ , distinctOnOrderBy = \m os p -> g (distinctOnOrderBy f m os (self p))+ , limit = \l p -> g (limit f l (self p))+ , join = \j pe lp lp' -> g (join f j pe (fmap self lp) (fmap self lp'))+ , semijoin = \j p1 p2 -> g (semijoin f j (self p1) (self p2))+ , exists = \s p -> g (exists f s (self p))+ , values = \ss nel -> g (values f ss nel)+ , binary = \bo (p1, p2) -> g (binary f bo (self p1, self p2))+ , label = \l p -> g (label f l (self p))+ , relExpr = \pe bs -> g (relExpr f pe bs)+ , rebind = \s bs p -> g (rebind f s bs (self p))+ , forUpdate = \p -> g (forUpdate f (self p))+ , with = \r m s ss p1 p2 -> g (with f r m s ss (self p1) (self p2))+ }++applyPrimQueryFoldF ::+ PrimQueryFoldP a (PrimQuery' a) p -> PrimQuery' a -> p+applyPrimQueryFoldF f = \case+ Unit -> unit f+ Empty a -> empty f a+ BaseTable ti syms -> baseTable f ti syms+ Product qs pes -> product f qs pes+ Aggregate aggrs q -> aggregate f aggrs q+ Window wndws q -> window f wndws q+ DistinctOnOrderBy dxs oxs q -> distinctOnOrderBy f dxs oxs q+ Limit op q -> limit f op q+ Join j cond q1 q2 -> join f j cond q1 q2+ Semijoin j q1 q2 -> semijoin f j q1 q2+ Values ss pes -> values f ss pes+ Binary binop (q1, q2) -> binary f binop (q1, q2)+ Label l pq -> label f l pq+ RelExpr pe syms -> relExpr f pe syms+ Exists s q -> exists f s q+ Rebind star pes q -> rebind f star pes q+ ForUpdate q -> forUpdate f q+ With recursive materialized name cols a b -> with f recursive materialized name cols a b++primQueryFoldF ::+ PrimQueryFoldP a p p' -> (PrimQuery' a -> p) -> PrimQuery' a -> p'+primQueryFoldF g self = applyPrimQueryFoldF (dimapPrimQueryFold self id g)+ foldPrimQuery :: PrimQueryFold' a p -> PrimQuery' a -> p-foldPrimQuery f = fix fold- where fold self primQ = case primQ of- Unit -> unit f- Empty a -> empty f a- BaseTable ti syms -> baseTable f ti syms- Product qs pes -> product f (fmap (fmap self) qs) pes- Aggregate aggrs q -> aggregate f aggrs (self q)- DistinctOnOrderBy dxs oxs q -> distinctOnOrderBy f dxs oxs (self q)- Limit op q -> limit f op (self q)- Join j cond q1 q2 -> join f j cond (fmap self q1) (fmap self q2)- Semijoin j q1 q2 -> semijoin f j (self q1) (self q2)- Values ss pes -> values f ss pes- Binary binop (q1, q2) -> binary f binop (self q1, self q2)- Label l pq -> label f l (self pq)- RelExpr pe syms -> relExpr f pe syms- Exists s q -> exists f s (self q)- Rebind star pes q -> rebind f star pes (self q)- ForUpdate q -> forUpdate f (self q)- fix g = let x = g x in x+foldPrimQuery f = fix (primQueryFoldF f)+ where fix g = let x = g x in x++-- Would be nice to show that this is associative+composePrimQueryFold ::+ PrimQueryFoldP a (PrimQuery' a) q ->+ PrimQueryFoldP a p (PrimQuery' a) ->+ PrimQueryFoldP a p q+composePrimQueryFold = fmapPrimQueryFold . applyPrimQueryFoldF+ where fmapPrimQueryFold = dimapPrimQueryFold id times :: Lateral -> PrimQuery -> PrimQuery -> PrimQuery times lat q q' = Product (pure q NEL.:| [(lat, q')]) []
src/Opaleye/Internal/Print.hs view
@@ -13,8 +13,9 @@ SelectValues, SelectBinary, SelectLabel,- SelectExists),- From, Join, Semijoin, Values, Binary, Label, Exists)+ SelectExists,+ SelectWith),+ From, Join, Semijoin, Values, Binary, Label, Exists, With) import qualified Opaleye.Internal.PrimQuery as PQ import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ@@ -25,13 +26,21 @@ import qualified Opaleye.Internal.Tag as T import Text.PrettyPrint.HughesPJ (Doc, ($$), (<+>), text, empty,- parens)+ parens, doubleQuotes) import qualified Data.Char import qualified Data.List.NonEmpty as NEL import qualified Data.Text as ST -type TableAlias = String+data TableAlias = TableAlias String (Maybe [HSql.SqlColumn]) +ppTableAlias :: TableAlias -> Doc+ppTableAlias (TableAlias table columns) =+ text "AS" <+>+ doubleQuotes (text table) <+>+ foldMap (parens . HPrint.commaH (doubleQuotes . unColumn)) columns+ where+ unColumn (HSql.SqlColumn col) = text col+ ppSql :: Select -> Doc ppSql (SelectFrom s) = ppSelectFrom s ppSql (Table table) = HPrint.ppTable table@@ -42,6 +51,7 @@ ppSql (SelectBinary v) = ppSelectBinary v ppSql (SelectLabel v) = ppSelectLabel v ppSql (SelectExists v) = ppSelectExists v+ppSql (SelectWith r) = ppWith r ppDistinctOn :: Maybe (NEL.NonEmpty HSql.SqlExpr) -> Doc ppDistinctOn = maybe mempty $ \nel ->@@ -64,18 +74,20 @@ ppSelectJoin :: Join -> Doc ppSelectJoin j = text "SELECT *" $$ text "FROM"- $$ ppTable_tableAlias (1, s1)+ $$ ppTable_tableAlias (1, alias s1) $$ ppJoinType (Sql.jJoinType j)- $$ ppTable_tableAlias (2, s2)+ $$ ppTable_tableAlias (2, alias s2) $$ text "ON" $$ HPrint.ppSqlExpr (Sql.jCond j)- where (s1, s2) = Sql.jTables j+ where+ (s1, s2) = Sql.jTables j+ alias (a, b) = (a, b, Nothing) ppSelectSemijoin :: Semijoin -> Doc ppSelectSemijoin v = text "SELECT *" $$ text "FROM"- $$ ppTable (tableAlias 1 (Sql.sjTable v))+ $$ ppTable (tableAlias 1 (Sql.sjTable v) Nothing) $$ case Sql.sjType v of Sql.Semi -> text "WHERE EXISTS" Sql.Anti -> text "WHERE NOT EXISTS"@@ -106,8 +118,29 @@ ppSelectExists :: Exists -> Doc ppSelectExists e = text "SELECT EXISTS"- <+> ppTable (Sql.sqlSymbol (Sql.existsBinding e), Sql.existsTable e)+ <+> ppTable (alias, Sql.existsTable e)+ where+ alias = TableAlias (Sql.sqlSymbol (Sql.existsBinding e)) Nothing +ppRecursive :: Sql.Recursive -> Doc+ppRecursive Sql.Recursive = text "RECURSIVE"+ppRecursive Sql.NonRecursive = mempty++ppMaterialized :: Sql.Materialized -> Doc+ppMaterialized Sql.Materialized = text "MATERIALIZED"+ppMaterialized Sql.NotMaterialized = text "NOT MATERIALIZED"++ppWith :: With -> Doc+ppWith w+ = text "WITH" <+> ppRecursive (Sql.wRecursive w)+ <+> HPrint.ppTable (Sql.wTable w)+ <+> parens (HPrint.commaV unColumn (Sql.wCols w))+ <+> text "AS"+ <+> foldMap ppMaterialized (Sql.wMaterialized w)+ $$ parens (ppSql (Sql.wWith w))+ $$ ppSql (Sql.wSelect w)+ where unColumn (HSql.SqlColumn col) = text col+ ppJoinType :: Sql.JoinType -> Doc ppJoinType Sql.LeftJoin = text "LEFT OUTER JOIN" ppJoinType Sql.RightJoin = text "RIGHT OUTER JOIN"@@ -124,19 +157,21 @@ nameAs (expr, name) = HPrint.ppSqlExpr expr `ppAs` fmap unColumn name where unColumn (HSql.SqlColumn s) = s -ppTables :: [(Sql.Lateral, Select)] -> Doc+ppTables :: [(Sql.Lateral, Select, Maybe [HSql.SqlColumn])] -> Doc ppTables [] = empty ppTables ts = text "FROM" <+> HPrint.commaV ppTable_tableAlias (zip [1..] ts) -ppTable_tableAlias :: (Int, (Sql.Lateral, Select)) -> Doc-ppTable_tableAlias (i, (lat, select)) =- lateral lat $ ppTable (tableAlias i select)+ppTable_tableAlias :: (Int, (Sql.Lateral, Select, Maybe [HSql.SqlColumn])) -> Doc+ppTable_tableAlias (i, (lat, select, columns)) =+ lateral lat $ ppTable (tableAlias i select columns) where lateral = \case Sql.NonLateral -> id Sql.Lateral -> (text "LATERAL" $$) -tableAlias :: Int -> Select -> (TableAlias, Select)-tableAlias i select = ("T" ++ show i, select)+tableAlias :: Int -> Select -> Maybe [HSql.SqlColumn] -> (TableAlias, Select)+tableAlias i select columns = (alias, select)+ where+ alias = TableAlias ("T" ++ show i) columns -- TODO: duplication with ppSql ppTable :: (TableAlias, Select) -> Doc@@ -150,27 +185,32 @@ SelectBinary slb -> parens (ppSelectBinary slb) SelectLabel sll -> parens (ppSelectLabel sll) SelectExists saj -> parens (ppSelectExists saj)- `ppAs`- Just alias+ SelectWith w -> parens (ppWith w)+ <+> ppTableAlias alias ppGroupBy :: Maybe (NEL.NonEmpty HSql.SqlExpr) -> Doc ppGroupBy Nothing = empty ppGroupBy (Just xs) = HPrint.ppGroupBy (NEL.toList xs) -ppLimit :: Maybe Int -> Doc+ppLimit :: Maybe HSql.SqlExpr -> Doc ppLimit Nothing = empty-ppLimit (Just n) = text ("LIMIT " ++ show n)+ppLimit (Just n) = text "LIMIT" <+> ppSqlExprParens n -ppOffset :: Maybe Int -> Doc+ppOffset :: Maybe HSql.SqlExpr -> Doc ppOffset Nothing = empty-ppOffset (Just n) = text ("OFFSET " ++ show n)+ppOffset (Just n) = text "OFFSET" <+> ppSqlExprParens n +ppSqlExprParens :: HSql.SqlExpr -> Doc+ppSqlExprParens = \case+ HSql.ConstSqlExpr a -> text a+ a -> parens (HPrint.ppSqlExpr a)+ ppFor :: Maybe Sql.LockStrength -> Doc ppFor Nothing = empty ppFor (Just Sql.Update) = text "FOR UPDATE" ppValues :: [[HSql.SqlExpr]] -> Doc-ppValues v = parens (HPrint.ppValues_ v) `ppAs` Just "V"+ppValues v = parens (HPrint.ppValues_ v) <+> ppTableAlias (TableAlias "V" Nothing) ppBinOp :: Sql.BinOp -> Doc ppBinOp o = text $ case o of
src/Opaleye/Internal/QueryArr.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_HADDOCK not-home #-}+ {-# LANGUAGE Arrows #-} {-# LANGUAGE TypeSynonymInstances #-} @@ -16,81 +18,77 @@ import Control.Arrow ((&&&), (***), arr, returnA) import qualified Control.Category as C import Control.Category ((<<<), id)-import Control.Applicative (Applicative, pure, (<*>))-import Data.List.NonEmpty ( NonEmpty((:|)) )+import Control.Monad.Trans.State.Strict (State, evalState, runState, state) import qualified Data.Profunctor as P import qualified Data.Profunctor.Product as PP --- Ideally this should be wrapped in a monad which automatically--- increments the Tag, but I couldn't be bothered to do that.------ The function 'Lateral -> PrimQuery -> PrimQuery' represents a--- select arrow in the following way:------ Lateral--- -- ^ Whether to join me laterally--- -> PrimQuery--- -- ^ The query that I will be joined after. If I refer to columns--- -- in here in a way that is only valid when I am joined laterally,--- -- then Lateral must be passed in as the argument above.--- -> PrimQuery--- -- ^ The result after joining me------ It is *always* valid to pass Lateral as the first argument. So why--- wouldn't we do that? Because we don't want to generate lateral--- subqueries if they are not needed; it might have performance--- implications. Even though there is good evidence that it *doesn't*--- have performance implications--- (https://github.com/tomjaguarpaw/haskell-opaleye/pull/480) we still--- want to be cautious.- -- | A parametrised 'Select'. A @SelectArr a b@ accepts an argument -- of type @a@. -- -- @SelectArr a b@ is analogous to a Haskell function @a -> [b]@.-newtype SelectArr a b = QueryArr ((a, Tag) -> (b, PQ.Lateral -> PQ.PrimQuery -> PQ.PrimQuery, Tag))+newtype SelectArr a b = QueryArr { unQueryArr :: a -> State Tag (b, PQ.PrimQueryArr) } type QueryArr = SelectArr type Query = SelectArr () -productQueryArr :: ((a, Tag) -> (b, PQ.PrimQuery, Tag)) -> QueryArr a b-productQueryArr f = QueryArr g- where g (a0, t0) = (a1, \lat primQuery -> PQ.times lat primQuery primQuery', t1)- where (a1, primQuery', t1) = f (a0, t0)+selectArr :: State Tag (a -> (b, PQ.PrimQueryArr)) -> SelectArr a b+selectArr s = QueryArr (\a -> fmap ($ a) s) -leftJoinQueryArr :: ((a, Tag) -> (b, HPQ.PrimExpr, PQ.PrimQuery, Tag)) -> QueryArr a b-leftJoinQueryArr f = QueryArr g- where g (a0, t0) = (a1, \lat primQueryL ->- PQ.Join PQ.LeftJoin cond (PQ.NonLateral, primQueryL) (lat, primQuery'), t1)- where (a1, cond, primQuery', t1) = f (a0, t0)+productQueryArr :: State Tag (a, PQ.PrimQuery) -> Query a+productQueryArr f = productQueryArr' (fmap const f) -{-# DEPRECATED simpleQueryArr "Use 'productQueryArr' instead. Its name indicates better what it actually does" #-}-simpleQueryArr :: ((a, Tag) -> (b, PQ.PrimQuery, Tag)) -> QueryArr a b-simpleQueryArr = productQueryArr+productQueryArr' :: State Tag (a -> (b, PQ.PrimQuery)) -> QueryArr a b+productQueryArr' f = QueryArr $ \a -> do+ t <- f+ pure $+ let (b, pq) = t a+ in (b, PQ.aProduct pq) -mapPrimQuery :: (PQ.PrimQuery -> PQ.PrimQuery) -> SelectArr a b -> SelectArr a b-mapPrimQuery f sa =- QueryArr ((\(b, pqf, t) -> (b, \lat -> f . pqf lat, t)) . runQueryArr sa)+leftJoinQueryArr' :: State Tag (a -> (b, HPQ.PrimExpr, PQ.PrimQuery)) -> QueryArr a b+leftJoinQueryArr' f = selectArr $ do+ t <- f+ pure $ \a ->+ let (a1, cond, primQuery') = t a+ in (a1, PQ.aLeftJoin cond primQuery') -runQueryArr :: QueryArr a b -> (a, Tag) -> (b, PQ.Lateral -> PQ.PrimQuery -> PQ.PrimQuery, Tag)-runQueryArr (QueryArr f) = f+runSimpleSelect :: Select a -> State Tag (a, PQ.PrimQuery)+runSimpleSelect s = runSimpleQueryArr' s () --- Unit defines no columns so joining it non-LATERAL is OK.-runSimpleQueryArr :: QueryArr a b -> (a, Tag) -> (b, PQ.PrimQuery, Tag)-runSimpleQueryArr f = (\(b, pqf, t) -> (b, pqf PQ.NonLateral PQ.Unit, t)) . runQueryArr f+runSimpleQueryArr' :: QueryArr a b -> a -> State Tag (b, PQ.PrimQuery)+runSimpleQueryArr' f a = do+ (b, pqf) <- unQueryArr f a+ pure (b, PQ.toPrimQuery pqf) +-- This is used by Rel8, but at some point it should switch to+-- runSimpleQueryArr' instead.+runStateQueryArr :: QueryArr a b -> a -> Tag -> (b, PQ.PrimQueryArr, Tag)+runStateQueryArr (QueryArr f) a tag =+ let ((b, pq), tag') = runState (f a) tag+ in (b, pq, tag')++-- This is used by Rel8, but at some point it should switch to+-- selectArr instead.+stateQueryArr :: (a -> Tag -> (b, PQ.PrimQueryArr, Tag)) -> QueryArr a b+stateQueryArr f = QueryArr $ \a -> state $ \tag ->+ let (b, pq, tag') = f a tag+ in ((b, pq), tag')++-- This is used by Rel8, but at some point it should switch to+-- runSimpleSelectStart runSimpleQueryArrStart :: QueryArr a b -> a -> (b, PQ.PrimQuery, Tag)-runSimpleQueryArrStart q a = runSimpleQueryArr q (a, Tag.start)+runSimpleQueryArrStart q a =+ let ((b, pqa), t') = runState (runSimpleQueryArr' q a) Tag.start+ in (b, pqa, t') +runSimpleSelectStart :: Select a -> (a, PQ.PrimQuery)+runSimpleSelectStart = flip evalState Tag.start . runSimpleSelect+ runQueryArrUnpack :: U.Unpackspec a b -> Query a -> ([HPQ.PrimExpr], PQ.PrimQuery, Tag) runQueryArrUnpack unpackspec q = (primExprs, primQ, endTag) where (columns, primQ, endTag) = runSimpleQueryArrStart q () primExprs = U.collectPEs unpackspec columns -first3 :: (a1 -> b) -> (a1, a2, a3) -> (b, a2, a3)-first3 f (a1, a2, a3) = (f a1, a2, a3)- -- | A @SELECT@, i.e. an SQL query which produces a collection of -- rows. --@@ -106,12 +104,9 @@ -- 'Opaleye.Binary.union', 'Opaleye.Binary.intersect' and -- 'Opaleye.Binary.except' to two 'SelectArr's). lateral :: (i -> Select a) -> SelectArr i a-lateral f = QueryArr qa- where- qa (i, tag) = (a, primQueryJoin, tag')- where- (a, primQueryR, tag') = runQueryArr (f i) ((), tag)- primQueryJoin _ = primQueryR PQ.Lateral+lateral f = QueryArr $ \i -> do+ (a, primQueryR) <- unQueryArr (f i) ()+ pure (a, PQ.lateral primQueryR) -- | Convert an arrow argument into a function argument so that it can -- be applied inside @do@-notation rather than arrow notation.@@ -129,21 +124,25 @@ instance C.Category QueryArr where id = arr id- QueryArr f . QueryArr g = QueryArr (\(a, t) ->- let (b, pqf, t') = g (a, t)- (c, pqf', t'') = f (b, t')- in (c, \lat -> pqf' lat . pqf lat, t''))+ QueryArr f . QueryArr g = QueryArr $ \a -> do+ (b, pqf) <- g a+ (c, pqf') <- f b+ pure (c, pqf <> pqf') instance Arr.Arrow QueryArr where- arr f = QueryArr (\(a, t) -> (f a, const id, t))+ arr f = QueryArr (\a -> pure (f a, mempty)) first (QueryArr f) = QueryArr g- where g ((b, d), t0) = first3 (\c -> (c, d)) (f (b, t0))+ where g (b, d) = do+ (c, pq) <- f b+ pure ((c, d), pq) instance Arr.ArrowChoice QueryArr where left (QueryArr f) = QueryArr g- where g (e, t0) = case e of- Left a -> first3 Left (f (a, t0))- Right b -> (Right b, const id, t0)+ where g e = case e of+ Left a -> do+ (r, pq) <- f a+ pure (Left r, pq)+ Right b -> pure (Right b, mempty) instance Arr.ArrowApply QueryArr where app = arrowApply
src/Opaleye/Internal/Rebind.hs view
@@ -1,10 +1,8 @@-{-# LANGUAGE FlexibleContexts #-}- module Opaleye.Internal.Rebind where import Data.Profunctor.Product.Default (Default, def) import Opaleye.Internal.Unpackspec (Unpackspec, runUnpackspec)-import Opaleye.Internal.QueryArr (SelectArr(QueryArr))+import Opaleye.Internal.QueryArr (selectArr, SelectArr) import qualified Opaleye.Internal.PackMap as PM import qualified Opaleye.Internal.PrimQuery as PQ import qualified Opaleye.Internal.Tag as Tag@@ -13,6 +11,18 @@ rebind = rebindExplicit def rebindExplicit :: Unpackspec a b -> SelectArr a b-rebindExplicit u = QueryArr (\(a, tag) ->- let (b, bindings) = PM.run (runUnpackspec u (PM.extractAttr "rebind" tag) a)- in (b, \_ -> PQ.Rebind True bindings, Tag.next tag))+rebindExplicit = rebindExplicitPrefix "rebind"++rebindExplicitPrefix :: String -> Unpackspec a b -> SelectArr a b+rebindExplicitPrefix prefix u = selectArr $ do+ tag <- Tag.fresh+ pure $ \a ->+ let (b, bindings) = PM.run (runUnpackspec u (PM.extractAttr prefix tag) a)+ in (b, PQ.aRebind bindings)++rebindExplicitPrefixNoStar :: String -> Unpackspec a b -> SelectArr a b+rebindExplicitPrefixNoStar prefix u = selectArr $ do+ tag <- Tag.fresh+ pure $ \a ->+ let (b, bindings) = PM.run (runUnpackspec u (PM.extractAttr prefix tag) a)+ in (b, PQ.aRebindNoStar bindings)
src/Opaleye/Internal/RunQuery.hs view
@@ -1,25 +1,27 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}+{-# OPTIONS_HADDOCK not-home #-}+ {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-} module Opaleye.Internal.RunQuery where import Control.Applicative- (Applicative, pure, (<$>), (*>), (<*>), liftA2)+ (liftA2) import qualified Database.PostgreSQL.Simple as PGS 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, pgArrayFieldParser)+ (FieldParser, fromField, pgArrayFieldParser, optionalField) import Database.PostgreSQL.Simple.FromRow (fromRow, fieldWith) import Database.PostgreSQL.Simple.Types (fromPGArray, Only(..))+import Database.PostgreSQL.Simple.Newtypes ( Aeson ) -import Opaleye.Column (Column)-import Opaleye.Internal.Column (Nullable)+import Opaleye.Internal.Column (Field_, Field, FieldNullable,+ Nullability(Nullable, NonNullable)) import qualified Opaleye.Internal.PackMap as PackMap import qualified Opaleye.Internal.QueryArr as Q-import qualified Opaleye.Column as C import qualified Opaleye.Internal.Unpackspec as U import qualified Opaleye.Internal.PGTypesExternal as T import qualified Opaleye.Internal.PGTypes as IPT (strictDecodeUtf8)@@ -42,8 +44,8 @@ import qualified Data.Time.Compat as Time import qualified Data.Scientific as Sci import qualified Data.String as String-import Data.UUID (UUID)-import GHC.Int (Int32, Int64)+import Data.UUID.Types (UUID)+import GHC.Int (Int16, Int32, Int64) -- { Only needed for postgresql-simple FieldParsers @@ -73,30 +75,28 @@ -- be that we can't add nullability to a RowParser, only to a -- FieldParser, so we have to have some type that we know contains -- just a FieldParser.-data FromField pgType haskellType =- QueryRunnerColumn (U.Unpackspec (Column pgType) ()) (FieldParser haskellType) -instance Functor (FromField u) where- fmap f ~(QueryRunnerColumn u fp) = QueryRunnerColumn u ((fmap . fmap . fmap) f fp)+newtype FromField sqlType haskellType = FromField (FieldParser haskellType) -type QueryRunnerColumn = FromField+instance Functor (FromField u) where+ fmap f (FromField fp) = FromField ((fmap . fmap . fmap) f fp) -- | A 'FromFields' -- specifies how to convert Postgres values (@fields@) -- into Haskell values (@haskells@). Most likely you will never need--- to create on of these or handle one directly. It will be provided+-- to create one of these or handle one directly. It will be provided -- for you by the 'D.Default' 'FromFields' instance. -- -- \"'FromFields' @fields@ @haskells@\" corresponds to -- postgresql-simple's \"'RowParser' @haskells@\". \"'Default'--- 'FromFields' @columns@ @haskells@\" corresponds to+-- 'FromFields' @fields@ @haskells@\" corresponds to -- postgresql-simple's \"@FromRow@ @haskells@\".-data FromFields columns haskells =- QueryRunner (U.Unpackspec columns ())- (columns -> RowParser haskells)+data FromFields fields haskells =+ FromFields (U.Unpackspec fields ())+ (fields -> RowParser haskells) -- We never actually look at the columns except to see -- its "type" in the case of a sum profunctor- (columns -> Int)+ (fields -> Int) -- How many columns have we requested? If we -- asked for zero columns then the SQL generator will -- have to put a dummy 0 into the SELECT statement,@@ -110,46 +110,35 @@ -- SqlInt4)' has no columns when it is Nothing and one -- column when it is Just. -type QueryRunner = FromFields--fieldQueryRunnerColumn :: PGS.FromField haskell => FromField pgType haskell-fieldQueryRunnerColumn = fromPGSFromField- fromPGSFromField :: PGS.FromField haskell => FromField pgType haskell-fromPGSFromField = fieldParserQueryRunnerColumn fromField--fieldParserQueryRunnerColumn :: FieldParser haskell -> FromField pgType haskell-fieldParserQueryRunnerColumn = fromPGSFieldParser+fromPGSFromField = fromPGSFieldParser fromField fromPGSFieldParser :: FieldParser haskell -> FromField pgType haskell-fromPGSFieldParser = QueryRunnerColumn (P.rmap (const ()) U.unpackspecField)+fromPGSFieldParser = FromField -queryRunner :: FromField a b -> FromFields (Column a) b-queryRunner qrc = QueryRunner u (const (fieldWith fp)) (const 1)- where QueryRunnerColumn u fp = qrc+fromFields :: FromField a b -> FromFields (Field a) b+fromFields (FromField fp) = fieldParserFromFields fp -queryRunnerColumnNullable :: FromField a b- -> FromField (Nullable a) (Maybe b)-queryRunnerColumnNullable qr =- QueryRunnerColumn (P.lmap C.unsafeCoerceColumn u) (fromField' fp)- where QueryRunnerColumn u fp = qr- fromField' :: FieldParser a -> FieldParser (Maybe a)- fromField' _ _ Nothing = pure Nothing- fromField' fp' f bs = fmap Just (fp' f bs)+fieldParserFromFields :: FieldParser haskells -> FromFields (Field_ n a) haskells+fieldParserFromFields fp = FromFields (P.rmap (const ()) U.unpackspecField) (const (fieldWith fp)) (const 1) +fromFieldsNullable :: FromField a b -> FromFields (FieldNullable a) (Maybe b)+fromFieldsNullable (FromField fp) = fieldParserFromFields (optionalField fp)+ unsafeFromFieldRaw :: FromField a (PGS.Field, Maybe SBS.ByteString)-unsafeFromFieldRaw = fieldParserQueryRunnerColumn (\f mdata -> pure (f, mdata))+unsafeFromFieldRaw = fromPGSFieldParser (\f mdata -> pure (f, mdata)) -- { Instances for automatic derivation instance DefaultFromField a b =>- DefaultFromField (Nullable a) (Maybe b) where- defaultFromField = queryRunnerColumnNullable defaultFromField+ D.Default FromFields (Field a) b where+ def = fromFields defaultFromField instance DefaultFromField a b =>- D.Default FromFields (Column a) b where- def = queryRunner defaultFromField+ D.Default FromFields (FieldNullable a) (Maybe b)+ where def = fromFieldsNullable defaultFromField + -- } -- { Instances that must be provided once for each type. Instances@@ -181,17 +170,9 @@ -- 3. If you have a more complicated case, but not a 'PGS.FromField' instance, -- write a 'FieldParser' for your type and use 'fromPGSFieldParser'. -- You can also add a 'FromField' instance using this.-{-# DEPRECATED queryRunnerColumnDefault "Use defaultFromField instead. It will be removed in 0.8" #-} class DefaultFromField sqlType haskellType where- queryRunnerColumnDefault :: FromField sqlType haskellType- queryRunnerColumnDefault = defaultFromField defaultFromField :: FromField sqlType haskellType- defaultFromField = queryRunnerColumnDefault - {-# MINIMAL queryRunnerColumnDefault | defaultFromField #-}--type QueryRunnerColumnDefault = DefaultFromField- instance DefaultFromField sqlType haskellType => D.Default FromField sqlType haskellType where def = defaultFromField@@ -199,6 +180,9 @@ instance DefaultFromField T.SqlNumeric Sci.Scientific where defaultFromField = fromPGSFromField +instance DefaultFromField T.SqlInt2 Int16 where+ defaultFromField = fromPGSFromField+ instance DefaultFromField T.SqlInt4 Int where defaultFromField = fromPGSFromField @@ -266,96 +250,102 @@ defaultFromField = fromPGSFromField instance DefaultFromField T.SqlJson String where- defaultFromField = fieldParserQueryRunnerColumn jsonFieldParser+ defaultFromField = fromPGSFieldParser jsonFieldParser instance DefaultFromField T.SqlJson ST.Text where- defaultFromField = fieldParserQueryRunnerColumn jsonFieldTextParser+ defaultFromField = fromPGSFieldParser jsonFieldTextParser instance DefaultFromField T.SqlJson LT.Text where- defaultFromField = fieldParserQueryRunnerColumn jsonFieldLazyTextParser+ defaultFromField = fromPGSFieldParser jsonFieldLazyTextParser instance DefaultFromField T.SqlJson SBS.ByteString where- defaultFromField = fieldParserQueryRunnerColumn jsonFieldByteParser+ defaultFromField = fromPGSFieldParser jsonFieldByteParser instance DefaultFromField T.SqlJson LBS.ByteString where- defaultFromField = fieldParserQueryRunnerColumn jsonFieldLazyByteParser+ defaultFromField = fromPGSFieldParser jsonFieldLazyByteParser instance DefaultFromField T.SqlJson Ae.Value where defaultFromField = fromPGSFromField +instance (Ae.FromJSON a, Typeable a) => DefaultFromField T.SqlJson (Aeson a) where+ defaultFromField = fromPGSFromField+ instance DefaultFromField T.SqlJsonb String where- defaultFromField = fieldParserQueryRunnerColumn jsonbFieldParser+ defaultFromField = fromPGSFieldParser jsonbFieldParser instance DefaultFromField T.SqlJsonb ST.Text where- defaultFromField = fieldParserQueryRunnerColumn jsonbFieldTextParser+ defaultFromField = fromPGSFieldParser jsonbFieldTextParser instance DefaultFromField T.SqlJsonb LT.Text where- defaultFromField = fieldParserQueryRunnerColumn jsonbFieldLazyTextParser+ defaultFromField = fromPGSFieldParser jsonbFieldLazyTextParser instance DefaultFromField T.SqlJsonb SBS.ByteString where- defaultFromField = fieldParserQueryRunnerColumn jsonbFieldByteParser+ defaultFromField = fromPGSFieldParser jsonbFieldByteParser instance DefaultFromField T.SqlJsonb LBS.ByteString where- defaultFromField = fieldParserQueryRunnerColumn jsonbFieldLazyByteParser+ defaultFromField = fromPGSFieldParser jsonbFieldLazyByteParser instance DefaultFromField T.SqlJsonb Ae.Value where defaultFromField = fromPGSFromField --- No CI String instance since postgresql-simple doesn't define FromField (CI String)+instance (Ae.FromJSON a, Typeable a) => DefaultFromField T.SqlJsonb (Aeson a) where+ defaultFromField = fromPGSFromField -arrayColumn :: Column (T.SqlArray a) -> Column a-arrayColumn = C.unsafeCoerceColumn+-- No CI String instance since postgresql-simple doesn't define FromField (CI String) instance (Typeable b, DefaultFromField a b) =>- DefaultFromField (T.SqlArray a) [b] where+ DefaultFromField (T.SqlArray_ NonNullable a) [b] where defaultFromField = fromFieldArray defaultFromField -fromFieldArray :: Typeable h => FromField f h -> FromField (T.SqlArray f) [h]-fromFieldArray q =- QueryRunnerColumn (P.lmap arrayColumn c)- ((fmap . fmap . fmap) fromPGArray (pgArrayFieldParser f))- where QueryRunnerColumn c f = q+fromFieldArray :: Typeable h => FromField f h -> FromField (T.SqlArray_ NonNullable f) [h]+fromFieldArray (FromField f) =+ fmap fromPGArray (FromField (pgArrayFieldParser f)) +fromFieldArrayNullable :: Typeable h => FromField f h -> FromField (T.SqlArray_ 'Nullable f) [Maybe h]+fromFieldArrayNullable (FromField f) =+ fmap fromPGArray (FromField (pgArrayFieldParser (optionalField f)))+ -- } instance (Typeable b, DefaultFromField a b) =>- DefaultFromField (T.PGRange a) (PGSR.PGRange b) where+ DefaultFromField (T.SqlRange a) (PGSR.PGRange b) where defaultFromField = fromFieldRange defaultFromField +instance (Typeable b, DefaultFromField a b) =>+ DefaultFromField (T.SqlArray_ Nullable a) [Maybe b] where+ defaultFromField = fromFieldArrayNullable defaultFromField+ fromFieldRange :: Typeable b => FromField a b- -> FromField (T.PGRange a) (PGSR.PGRange b)-fromFieldRange off =- QueryRunnerColumn (P.lmap C.unsafeCoerceColumn c) (PGSR.fromFieldRange pff)- where QueryRunnerColumn c pff = off+ -> FromField (T.SqlRange a) (PGSR.PGRange b)+fromFieldRange (FromField pff) = FromField (PGSR.fromFieldRange pff) -- Boilerplate instances instance Functor (FromFields c) where- fmap f (QueryRunner u r b) = QueryRunner u ((fmap . fmap) f r) b+ fmap f (FromFields u r b) = FromFields u ((fmap . fmap) f r) b --- TODO: Seems like this one should be simpler! instance Applicative (FromFields c) where- pure = flip (QueryRunner (P.lmap (const ()) PP.empty)) (const 0)+ pure = flip (FromFields (pure ())) (const 0) . 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)+ FromFields uf rf bf <*> FromFields ux rx bx =+ FromFields (uf *> ux) ((<*>) <$> rf <*> rx) (liftA2 (+) bf bx) 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)+ dimap f g (FromFields u r b) =+ FromFields (P.lmap f u) (P.dimap f (fmap g) r) (P.lmap f b) instance PP.ProductProfunctor FromFields where purePP = pure (****) = (<*>) instance PP.SumProfunctor FromFields where- f +++! g = QueryRunner (P.rmap (const ()) (fu PP.+++! gu))+ f +++! g = FromFields (P.rmap (const ()) (fu PP.+++! gu)) (PackMap.eitherFunction fr gr) (either fb gb)- where QueryRunner fu fr fb = f- QueryRunner gu gr gb = g+ where FromFields fu fr fb = f+ FromFields gu gr gb = g -- } @@ -387,15 +377,6 @@ -- Eventually we want to move this to postgresql-simple -- -- https://github.com/tomjaguarpaw/haskell-opaleye/issues/329-jsonFieldTypeParser :: SBS.ByteString -> FieldParser String-jsonFieldTypeParser = (fmap . fmap . fmap . fmap) IPT.strictDecodeUtf8 jsonFieldTypeByteParser--jsonFieldTypeTextParser :: SBS.ByteString -> FieldParser ST.Text-jsonFieldTypeTextParser = (fmap . fmap . fmap . fmap) STE.decodeUtf8 jsonFieldTypeByteParser--jsonFieldTypeLazyTextParser :: SBS.ByteString -> FieldParser LT.Text-jsonFieldTypeLazyTextParser = (fmap . fmap . fmap . fmap) (LTE.decodeUtf8 . LBS.fromStrict) jsonFieldTypeByteParser- jsonFieldTypeByteParser :: SBS.ByteString -> FieldParser SBS.ByteString jsonFieldTypeByteParser jsonTypeName field mData = do ti <- typeInfo field@@ -407,13 +388,26 @@ Just bs -> pure bs _ -> returnError UnexpectedNull field "" +withJsonByteStringParser :: (SBS.ByteString -> b)+ -> SBS.ByteString -> FieldParser b+withJsonByteStringParser f = (fmap . fmap . fmap . fmap) f jsonFieldTypeByteParser++jsonFieldTypeParser :: SBS.ByteString -> FieldParser String+jsonFieldTypeParser = withJsonByteStringParser IPT.strictDecodeUtf8++jsonFieldTypeTextParser :: SBS.ByteString -> FieldParser ST.Text+jsonFieldTypeTextParser = withJsonByteStringParser STE.decodeUtf8++jsonFieldTypeLazyTextParser :: SBS.ByteString -> FieldParser LT.Text+jsonFieldTypeLazyTextParser = withJsonByteStringParser (LTE.decodeUtf8 . LBS.fromStrict)+ jsonFieldTypeLazyByteParser :: SBS.ByteString -> FieldParser LBS.ByteString-jsonFieldTypeLazyByteParser = (fmap . fmap . fmap . fmap) LBS.fromStrict jsonFieldTypeByteParser+jsonFieldTypeLazyByteParser = withJsonByteStringParser LBS.fromStrict -- } prepareRowParser :: FromFields columns haskells -> columns -> RowParser haskells-prepareRowParser (QueryRunner _ rowParser numColumns) cols =+prepareRowParser (FromFields _ rowParser numColumns) cols = if numColumns cols > 0 then rowParser cols else (fromRow :: RowParser (Only Int)) *> rowParser cols@@ -422,14 +416,16 @@ -- SELECT statement, since we can't select zero -- columns. In that case we have to make sure we -- read a single Int.+ --+ -- See: Opaleye.Internal.Sql -- | Cursor within a transaction. data Cursor haskells = EmptyCursor | Cursor (RowParser haskells) PGSC.Cursor prepareQuery :: FromFields fields haskells -> S.Select fields -> (Maybe PGS.Query, RowParser haskells)-prepareQuery qr@(QueryRunner u _ _) q = (sql, parser)+prepareQuery qr@(FromFields u _ _) q = (sql, parser) where sql :: Maybe PGS.Query sql = fmap String.fromString (S.showSqlExplicit u q) -- FIXME: We're doing work twice here- (b, _, _) = Q.runSimpleQueryArrStart q ()+ (b, _) = Q.runSimpleSelectStart q parser = prepareRowParser qr b
src/Opaleye/Internal/RunQueryExternal.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_HADDOCK not-home #-} module Opaleye.Internal.RunQueryExternal (module Opaleye.Internal.RunQueryExternal,@@ -6,35 +6,25 @@ IRQ.Cursor, IRQ.FromFields, IRQ.FromField,- QueryRunner,- IRQ.QueryRunnerColumn,- IRQ.QueryRunnerColumnDefault,- -- * Creating new 'QueryRunnerColumn's- IRQ.fieldQueryRunnerColumn,- IRQ.fieldParserQueryRunnerColumn) where+ ) where -import Control.Applicative (pure, (<$>)) import qualified Database.PostgreSQL.Simple as PGS import qualified Database.PostgreSQL.Simple.Cursor as PGSC -import Opaleye.Column (Column) import qualified Opaleye.Select as S-import Opaleye.Internal.RunQuery (QueryRunner, prepareQuery)+import Opaleye.Internal.RunQuery (prepareQuery) import qualified Opaleye.Internal.RunQuery as IRQ -import qualified Data.Profunctor as P import qualified Data.Profunctor.Product.Default as D -- * Running 'S.Select's -{-# DEPRECATED runQuery "Use 'Opaleye.RunSelect.runSelect' instead. @runQuery@ will be removed in 0.8." #-} runQuery :: D.Default IRQ.FromFields fields haskells => PGS.Connection -> S.Select fields -> IO [haskells] runQuery = runQueryExplicit D.def -{-# DEPRECATED runQueryFold "Use 'Opaleye.RunSelect.runSelectFold' instead. @runQueryFold@ will be removed in 0.8." #-} runQueryFold :: D.Default IRQ.FromFields fields haskells => PGS.Connection@@ -44,19 +34,8 @@ -> IO b runQueryFold = runQueryFoldExplicit D.def --- * Creating new 'QueryRunnerColumn's--{-# DEPRECATED queryRunnerColumn "Use 'Opaleye.RunSelect.unsafeFromField' instead. @queryRunnerColumn@ will be removed in 0.8." #-}-queryRunnerColumn :: (Column a' -> Column a) -> (b -> b')- -> IRQ.FromField a b -> IRQ.FromField a' b'-queryRunnerColumn colF haskellF qrc = IRQ.QueryRunnerColumn (P.lmap colF u)- (fmapFP haskellF fp)- where IRQ.QueryRunnerColumn u fp = qrc- fmapFP = fmap . fmap . fmap- -- * Explicit versions -{-# DEPRECATED runQueryExplicit "Use 'Opaleye.RunSelect.runSelectExplict' instead. Will be removed in 0.8." #-} runQueryExplicit :: IRQ.FromFields fields haskells -> PGS.Connection -> S.Select fields@@ -64,7 +43,6 @@ runQueryExplicit qr conn q = maybe (return []) (PGS.queryWith_ parser conn) sql where (sql, parser) = IRQ.prepareQuery qr q -{-# DEPRECATED runQueryFoldExplicit "Use 'Opaleye.RunSelect.runSelectFoldExplict' instead. Will be deprecated in 0.8." #-} runQueryFoldExplicit :: IRQ.FromFields fields haskells -> PGS.Connection@@ -79,7 +57,6 @@ -- * Cursor interface -{-# DEPRECATED declareCursor "Use 'Opaleye.RunSelect.declareCursor' instead. Will be removed in 0.8." #-} declareCursor :: D.Default IRQ.FromFields fields haskells => PGS.Connection@@ -87,7 +64,6 @@ -> IO (IRQ.Cursor haskells) declareCursor = declareCursorExplicit D.def -{-# DEPRECATED declareCursorExplicit "Use 'Opaleye.RunSelect.declareCursorExplicit' instead. Will be removed in 0.8." #-} declareCursorExplicit :: IRQ.FromFields fields haskells -> PGS.Connection@@ -100,12 +76,10 @@ where (mbQuery, rowParser) = prepareQuery qr q -{-# DEPRECATED closeCursor "Use 'Opaleye.RunSelect.closeCursor' instead. Will be removed in 0.8." #-} closeCursor :: IRQ.Cursor fields -> IO () closeCursor IRQ.EmptyCursor = pure () closeCursor (IRQ.Cursor _ cursor) = PGSC.closeCursor cursor -{-# DEPRECATED foldForward "Use 'Opaleye.RunSelect.foldForward' instead. Will be removed in 0.8." #-} foldForward :: IRQ.Cursor haskells -> Int
src/Opaleye/Internal/Sql.hs view
@@ -1,8 +1,9 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-} module Opaleye.Internal.Sql where -import Prelude hiding (product)+import Prelude hiding (filter, product) import qualified Opaleye.Internal.PrimQuery as PQ @@ -30,6 +31,7 @@ | SelectBinary Binary | SelectLabel Label | SelectExists Exists+ | SelectWith With deriving Show data SelectAttrs =@@ -40,13 +42,13 @@ data From = From { attrs :: SelectAttrs,- tables :: [(Lateral, Select)],+ tables :: [(Lateral, Select, Maybe [HSql.SqlColumn])], criteria :: [HSql.SqlExpr], groupBy :: Maybe (NEL.NonEmpty HSql.SqlExpr), orderBy :: [(HSql.SqlExpr, HSql.SqlOrder)], distinctOn :: Maybe (NEL.NonEmpty HSql.SqlExpr),- limit :: Maybe Int,- offset :: Maybe Int,+ limit :: Maybe HSql.SqlExpr,+ offset :: Maybe HSql.SqlExpr, for :: Maybe LockStrength } deriving Show@@ -80,7 +82,18 @@ data BinOp = Except | ExceptAll | Union | UnionAll | Intersect | IntersectAll deriving Show data Lateral = Lateral | NonLateral deriving Show data LockStrength = Update deriving Show+data Recursive = NonRecursive | Recursive deriving Show+data Materialized = Materialized | NotMaterialized deriving Show+data With = With {+ wTable :: HSql.SqlTable, -- The name of the result, i.e. WITH <name> AS+ wCols :: [HSql.SqlColumn],+ wRecursive :: Recursive,+ wMaterialized :: Maybe Materialized,+ wWith :: Select,+ wSelect :: Select+} deriving Show + data Label = Label { lLabel :: String, lSelect :: Select@@ -100,6 +113,7 @@ , PQ.baseTable = baseTable , PQ.product = product , PQ.aggregate = aggregate+ , PQ.window = window , PQ.distinctOnOrderBy = distinctOnOrderBy , PQ.limit = limit_ , PQ.join = join@@ -111,6 +125,7 @@ , PQ.exists = exists , PQ.rebind = rebind , PQ.forUpdate = forUpdate+ , PQ.with = with } exists :: Symbol -> Select -> Select@@ -129,8 +144,8 @@ empty :: V.Void -> select empty = V.absurd -oneTable :: t -> [(Lateral, t)]-oneTable t = [(NonLateral, t)]+oneTable :: t -> [(Lateral, t, Maybe a)]+oneTable t = [(NonLateral, t, Nothing)] baseTable :: PQ.TableIdentifier -> [(Symbol, HPQ.PrimExpr)] -> Select baseTable ti columns = SelectFrom $@@ -141,19 +156,17 @@ product ss pes = SelectFrom $ newSelect { tables = NEL.toList ss' , criteria = map sqlExpr pes }- where ss' = flip fmap ss $ Arr.first $ \case+ where ss' = flip fmap ss $ (\f (a, b) -> (f a, b, Nothing)) $ \case PQ.Lateral -> Lateral PQ.NonLateral -> NonLateral -aggregate :: [(Symbol,- (Maybe (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct),- HPQ.Symbol))]+aggregate :: PQ.Bindings HPQ.Aggregate -> Select -> Select aggregate aggrs' s = SelectFrom $ newSelect { attrs = SelectAttrs (ensureColumns (map attr aggrs)) , tables = oneTable s- , groupBy = (Just . groupBy') aggrs }+ , groupBy = Just (groupBy' aggrs) } where --- Although in the presence of an aggregation function, --- grouping by an empty list is equivalent to omitting group --- by, the equivalence does not hold in the absence of an@@ -175,26 +188,30 @@ --- "GROUP BY 0" means group by the zeroth column so we --- instead use an expression rather than a constant. handleEmpty :: [HSql.SqlExpr] -> NEL.NonEmpty HSql.SqlExpr- handleEmpty =- M.fromMaybe (return (SP.deliteral (HSql.ConstSqlExpr "0")))- . NEL.nonEmpty+ handleEmpty = ensureColumnsGen SP.deliteral - aggrs = (map . Arr.second . Arr.second) HPQ.AttrExpr aggrs'+ aggrs :: [(Symbol, HPQ.Aggregate)]+ aggrs = aggrs' - groupBy' :: [(symbol, (Maybe aggrOp, HPQ.PrimExpr))]+ groupBy' :: [(symbol, HPQ.Aggregate)] -> NEL.NonEmpty HSql.SqlExpr- groupBy' = handleEmpty- . map sqlExpr- . map expr- . filter (M.isNothing . aggrOp)- attr = sqlBinding . Arr.second (uncurry aggrExpr)- expr (_, (_, e)) = e- aggrOp (_, (x, _)) = x+ groupBy' aggs = handleEmpty $ do+ (_, HPQ.GroupBy e) <- aggs+ pure $ sqlExpr e + attr = sqlBinding . Arr.second aggrExpr -aggrExpr :: Maybe (HPQ.AggrOp, [HPQ.OrderExpr], HPQ.AggrDistinct) -> HPQ.PrimExpr -> HPQ.PrimExpr-aggrExpr = maybe id (\(op, ord, distinct) e -> HPQ.AggrExpr distinct op e ord)+aggrExpr :: HPQ.Aggregate -> HPQ.PrimExpr+aggrExpr = \case+ HPQ.GroupBy e -> e+ HPQ.Aggregate aggr -> HPQ.AggrExpr aggr +window :: PQ.Bindings (HPQ.WndwOp, HPQ.Partition) -> Select -> Select+window wndws' s = SelectFrom $ newSelect+ { attrs = SelectAttrsStar (ensureColumns (map (sqlBinding . fmap (uncurry HPQ.WndwExpr)) wndws'))+ , tables = oneTable s+ }+ distinctOnOrderBy :: Maybe (NEL.NonEmpty HPQ.PrimExpr) -> [HPQ.OrderExpr] -> Select -> Select distinctOnOrderBy distinctExprs orderExprs s = SelectFrom $ newSelect { tables = oneTable s@@ -214,9 +231,9 @@ , limit = limit' , offset = offset' } where (limit', offset') = case lo of- PQ.LimitOp n -> (Just n, Nothing)- PQ.OffsetOp n -> (Nothing, Just n)- PQ.LimitOffsetOp l o -> (Just l, Just o)+ PQ.LimitOp n -> (Just (sqlExpr n), Nothing)+ PQ.OffsetOp n -> (Nothing, Just (sqlExpr n))+ PQ.LimitOffsetOp l o -> (Just (sqlExpr l), Just (sqlExpr o)) join :: PQ.JoinType -> HPQ.PrimExpr@@ -251,6 +268,25 @@ bSelect2 = select2 } +with :: PQ.Recursive -> Maybe PQ.Materialized -> Symbol -> [Symbol] -> Select -> Select -> Select+with recursive materialized name cols wWith wSelect =+ SelectFrom+ newSelect+ { attrs = Star+ , tables = [(NonLateral, SelectWith $ With {..}, Nothing)]+ }+ where+ wTable = HSql.SqlTable Nothing (sqlSymbol name)+ wRecursive = case recursive of+ PQ.NonRecursive -> NonRecursive+ PQ.Recursive -> Recursive+ wMaterialized = case materialized of+ Nothing -> Nothing+ Just PQ.Materialized -> Just Materialized+ Just PQ.NotMaterialized -> Just NotMaterialized+ wCols = map (HSql.SqlColumn . sqlSymbol) cols++ joinType :: PQ.JoinType -> JoinType joinType PQ.LeftJoin = LeftJoin joinType PQ.RightJoin = RightJoin@@ -306,11 +342,13 @@ label l s = SelectLabel (Label l s) -- Very similar to 'baseTable'-relExpr :: HPQ.PrimExpr -> [(Symbol, HPQ.PrimExpr)] -> Select+relExpr :: HPQ.PrimExpr -> [Symbol] -> Select relExpr pe columns = SelectFrom $- newSelect { attrs = SelectAttrs (ensureColumns (map sqlBinding columns))- , tables = oneTable (RelExpr (sqlExpr pe))+ newSelect { attrs = Star+ , tables = [(NonLateral, RelExpr (sqlExpr pe), Just columns')] }+ where+ columns' = HSql.SqlColumn . sqlSymbol <$> columns rebind :: Bool -> [(Symbol, HPQ.PrimExpr)] -> Select -> Select rebind star pes select = SelectFrom newSelect@@ -323,6 +361,6 @@ forUpdate :: Select -> Select forUpdate s = SelectFrom newSelect {- tables = [(NonLateral, s)]+ tables = [(NonLateral, s, Nothing)] , for = Just Update }
src/Opaleye/Internal/Table.hs view
@@ -1,11 +1,9 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE Rank2Types #-} module Opaleye.Internal.Table where -import Opaleye.Internal.Column (Column(Column), unColumn)+import Opaleye.Internal.Column (Field_(Column), unColumn) import qualified Opaleye.Internal.Tag as Tag import qualified Opaleye.Internal.Unpackspec as U import qualified Opaleye.Internal.PrimQuery as PQ@@ -18,9 +16,7 @@ import Data.Profunctor.Product (ProductProfunctor) import qualified Data.Profunctor.Product as PP import qualified Data.List.NonEmpty as NEL-import Data.Monoid (Monoid, mempty, mappend)-import Data.Semigroup (Semigroup, (<>))-import Control.Applicative (Applicative, pure, (<*>), liftA2)+import Control.Applicative (liftA2) import qualified Control.Arrow as Arr -- | Define a table as follows, where \"id\", \"color\", \"location\",@@ -35,11 +31,11 @@ -- , quantity :: d -- , radius :: e } ----- \$('Data.Profunctor.Product.TH.makeAdaptorAndInstance' \"pWidget\" ''Widget)+-- \$('Data.Profunctor.Product.TH.makeAdaptorAndInstanceInferrable' \"pWidget\" ''Widget) -- -- widgetTable :: Table (Widget (Maybe (Field SqlInt4)) (Field SqlText) (Field SqlText) -- (Field SqlInt4) (Field SqlFloat8))--- (Widget (Field SqlText) (Field SqlText) (Field SqlText)+-- (Widget (Field SqlInt4) (Field SqlText) (Field SqlText) -- (Field SqlInt4) (Field SqlFloat8)) -- widgetTable = table \"widgetTable\" -- (pWidget Widget { wid = tableField \"id\"@@ -48,17 +44,9 @@ -- , quantity = tableField \"quantity\" -- , radius = tableField \"radius\" }) -- @------ The constructors of Table are internal only and will be--- removed in version 0.8. data Table writeFields viewFields = Table String (TableFields writeFields viewFields)- -- ^ For unqualified table names. Do not use the constructor. It- -- is considered deprecated and will be removed in version 0.8. | TableWithSchema String String (TableFields writeFields viewFields)- -- ^ Schema name, table name, table properties. Do not use the- -- constructor. It is considered deprecated and will be removed- -- in version 0.8. tableIdentifier :: Table writeColumns viewColumns -> PQ.TableIdentifier tableIdentifier (Table t _) = PQ.TableIdentifier Nothing t@@ -76,12 +64,6 @@ { tablePropertiesWriter :: Writer writeColumns viewColumns , tablePropertiesView :: View viewColumns } -{-# DEPRECATED TableColumns "Use 'TableFields' instead. 'TableColumns' will be removed in version 0.8." #-}-type TableColumns = TableFields--{-# DEPRECATED TableProperties "Use 'TableFields' instead. 'TableProperties' will be removed in version 0.8." #-}-type TableProperties = TableFields- tableColumnsWriter :: TableFields writeColumns viewColumns -> Writer writeColumns viewColumns tableColumnsWriter = tablePropertiesWriter@@ -90,11 +72,8 @@ -> View viewColumns tableColumnsView = tablePropertiesView -{-# DEPRECATED View "Internal only. Do not use. 'View' will be removed in version 0.8." #-} newtype View columns = View columns -{-# DEPRECATED Writer "Internal only. Do not use. 'Writer' will be removed in 0.8." #-}- -- There's no reason the second parameter should exist except that we -- use ProductProfunctors more than ProductContravariants so it makes -- things easier if we make it one of the former.@@ -108,54 +87,59 @@ Writer (forall f. Functor f => PM.PackMap (f HPQ.PrimExpr, String) () (f columns) ()) --- | 'requiredTableField' is for fields which are not optional. You--- must provide them on writes.-requiredTableField :: String -> TableFields (Column a) (Column a)-requiredTableField columnName = TableFields- (requiredW columnName)- (View (Column (HPQ.BaseTableAttrExpr columnName)))+coerceWriterOutput :: Writer columns dummy -> Writer columns dummy'+coerceWriterOutput (Writer w) = Writer w +-- | @requiredTableField@ is for fields which are not optional. You+-- must provide them on writes.+requiredTableField :: String -> TableFields (Field_ n a) (Field_ n a)+requiredTableField = lmap Just . optionalTableField --- | 'optionalTableField' is for fields that you can omit on writes, such as--- fields which have defaults or which are SERIAL.-optionalTableField :: String -> TableFields (Maybe (Column a)) (Column a)+-- | @optionalTableField@ is for fields that you can be set to @DEFAULT@ on writes,+-- such as fields which have defaults or which are SERIAL. Setting+-- the write value to @Nothing@ uses SQL @DEFAULT@ in the generated+-- update.+optionalTableField :: String -> TableFields (Maybe (Field_ n a)) (Field_ n a) optionalTableField columnName = TableFields (optionalW columnName) (View (Column (HPQ.BaseTableAttrExpr columnName))) --- | 'readOnlyTableField' is for fields that you must omit on writes, such as--- SERIAL fields intended to auto-increment only.-readOnlyTableField :: String -> TableFields () (Column a)+-- | Don't use @readOnlyTableField@. It will be formally deprecated+-- in a future version. It is broken for updates because it always+-- updates its field with @DEFAULT@ which is very unlikely to be what+-- you want! For more details see+-- <https://github.com/tomjaguarpaw/haskell-opaleye/issues/447#issuecomment-685617841>.+readOnlyTableField :: String -> TableFields () (Field_ n a) readOnlyTableField = lmap (const Nothing) . optionalTableField -{-# DEPRECATED required "Use 'requiredTableField' instead. Will be removed in version 0.8." #-}-required :: String -> TableFields (Column a) (Column a)-required = requiredTableField--{-# DEPRECATED optional "Use 'optionalTableField' instead. Will be removed in version 0.8." #-}-optional :: String -> TableFields (Maybe (Column a)) (Column a)-optional = optionalTableField--{-# DEPRECATED readOnly "Use 'readOnlyTableField' instead. Will be removed in version 0.8." #-}-readOnly :: String -> TableFields () (Column a)-readOnly = readOnlyTableField--{-# DEPRECATED tableColumn "Use 'tableField' instead. Will be removed in 0.8." #-}+-- | @omitOnwritetablefield@ is for fields that should be omitted on+-- writes, such as those that are @GENERATED ALWAYS@.+omitOnWriteTableField :: String -> TableFields () (Field_ n a)+omitOnWriteTableField columnName = TableFields+ (coerceWriterOutput (pure ()))+ (View (Column (HPQ.BaseTableAttrExpr columnName))) -class TableColumn writeType sqlType | writeType -> sqlType where- tableColumn :: String -> TableFields writeType (Column sqlType)- tableColumn = tableField+-- | You should not define your own instances of+-- 'InferrableTableField'.+class InferrableTableField w n r+ | w -> n, w -> r where -- | Infer either a required ('requiredTableField') or optional -- ('optionalTableField') field depending on -- the write type. It's generally more convenient to use this -- than 'required' or 'optional' but you do have to provide a type -- signature instead.- tableField :: String -> TableFields writeType (Column sqlType)+ tableField :: String -> TableFields w (Field_ n r) -instance TableColumn (Column a) a where+-- | Equivalent to defining the column with 'requiredTableField'. If+-- the write type is @Field_ n r@ then the read type is also @Field_ n+-- r@.+instance InferrableTableField (Field_ n r) n r where tableField = requiredTableField -instance TableColumn (Maybe (Column a)) a where+-- | Equivalent to defining the column with 'optionalTableField'. If+-- the write type is @Maybe (Field_ n r)@ (i.e. @DEFAULT@ can be+-- written to it) then the write type is @Field_ n r@.+instance InferrableTableField (Maybe (Field_ n r)) n r where tableField = optionalTableField queryTable :: U.Unpackspec viewColumns columns@@ -209,11 +193,7 @@ where mempty' = [] `NEL.cons` mempty' mappend = (<>) -requiredW :: String -> Writer (Column a) (Column a)-requiredW columnName =- Writer (PM.iso (flip (,) columnName . fmap unColumn) id)--optionalW :: String -> Writer (Maybe (Column a)) (Column a)+optionalW :: String -> Writer (Maybe (Field_ n a)) (Field_ n a) optionalW columnName = Writer (PM.iso (flip (,) columnName . fmap maybeUnColumn) id) where maybeUnColumn = maybe HPQ.DefaultInsertExpr unColumn
− src/Opaleye/Internal/TableMaker.hs
@@ -1,70 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}--module Opaleye.Internal.TableMaker where--import qualified Opaleye.Column as C-import qualified Opaleye.Internal.Column as IC-import qualified Opaleye.Internal.PackMap as PM-import qualified Opaleye.Internal.Unpackspec as U--import Data.Profunctor (Profunctor, dimap)-import Data.Profunctor.Product (ProductProfunctor)-import qualified Data.Profunctor.Product as PP-import Data.Profunctor.Product.Default (Default, def)--import Control.Applicative (Applicative, pure, (<*>))--import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ----- If we switch to a more lens-like approach to PackMap this should be--- the equivalent of a Setter-newtype ViewColumnMaker strings columns =- ViewColumnMaker (PM.PackMap () () strings columns)--runViewColumnMaker :: ViewColumnMaker strings tablecolumns ->- strings -> tablecolumns-runViewColumnMaker (ViewColumnMaker f) = PM.overPM f id--{-# DEPRECATED ColumnMaker "Use Unpackspec instead" #-}-type ColumnMaker = U.Unpackspec--{-# DEPRECATED runColumnMaker "Use runUnpackspec instead" #-}-runColumnMaker :: Applicative f- => ColumnMaker tablecolumns columns- -> (HPQ.PrimExpr -> f HPQ.PrimExpr)- -> tablecolumns -> f columns-runColumnMaker = U.runUnpackspec---- There's surely a way of simplifying this implementation-tableColumn :: ViewColumnMaker String (C.Column a)-tableColumn = ViewColumnMaker- (PM.PackMap (\f s -> fmap (const (mkColumn s)) (f ())))- where mkColumn = IC.Column . HPQ.BaseTableAttrExpr--instance Default ViewColumnMaker String (C.Column a) where- def = tableColumn--{-# DEPRECATED column "Use unpackspecColumn instead" #-}-column :: ColumnMaker (C.Column a) (C.Column a)-column = U.unpackspecField---- {---- Boilerplate instance definitions. Theoretically, these are derivable.--instance Functor (ViewColumnMaker a) where- fmap f (ViewColumnMaker g) = ViewColumnMaker (fmap f g)--instance Applicative (ViewColumnMaker a) where- pure = ViewColumnMaker . pure- ViewColumnMaker f <*> ViewColumnMaker x = ViewColumnMaker (f <*> x)--instance Profunctor ViewColumnMaker where- dimap f g (ViewColumnMaker q) = ViewColumnMaker (dimap f g q)--instance ProductProfunctor ViewColumnMaker where- purePP = pure- (****) = (<*>)----}
src/Opaleye/Internal/Tag.hs view
@@ -1,5 +1,7 @@ module Opaleye.Internal.Tag where +import Control.Monad.Trans.State.Strict ( get, modify', State )+ -- | Tag is for use as a source of unique IDs in QueryArr newtype Tag = UnsafeTag Int deriving (Read, Show) @@ -14,3 +16,9 @@ tagWith :: Tag -> String -> String tagWith t s = s ++ "_" ++ show (unsafeUnTag t)++fresh :: State Tag Tag+fresh = do+ t <- get+ modify' next+ pure t
src/Opaleye/Internal/TypeFamilies.hs view
@@ -75,9 +75,6 @@ type RecordField f a b c = A f ('C '(a, b, c)) type TableRecordField f a b c d = A f ('TC '( '(a, b, c), d)) -{-# DEPRECATED TableField "Use 'TableRecordField' instead. Will be remoed in version 0.8." #-}-type TableField f a b c d = TableRecordField f a b c d- -- | Type families parameter for Haskell types ('String', 'Int', etc.) type H = 'H HT -- | Type families parameter for Opaleye types ('Opaleye.Field.Field'
src/Opaleye/Internal/Unpackspec.hs view
@@ -1,12 +1,11 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+{-# OPTIONS_HADDOCK not-home #-} module Opaleye.Internal.Unpackspec where import qualified Opaleye.Internal.PackMap as PM import qualified Opaleye.Internal.Column as IC-import qualified Opaleye.Column as C+import qualified Opaleye.Field as F -import Control.Applicative (Applicative, pure, (<*>)) import Data.Profunctor (Profunctor, dimap) import Data.Profunctor.Product (ProductProfunctor) import qualified Data.Profunctor.Product as PP@@ -14,34 +13,30 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ -newtype Unpackspec columns columns' =- -- | An 'Unpackspec' @columns@ @columns'@ allows you to extract and+newtype Unpackspec fields fields' =+ -- | An 'Unpackspec' @fields@ @fields'@ allows you to extract and -- modify a sequence of 'HPQ.PrimExpr's inside a value of type- -- @columns@.+ -- @fields@. --- -- For example, the 'Default' instance of type 'Unpackspec' @(Column- -- a, Column b)@ @(Column a, Column b)@ allows you to manipulate or- -- extract the two 'HPQ.PrimExpr's inside a @(Column a, Column b)@. The- -- 'Default' instance of type @Foo (Column a) (Column b) (Column c)@+ -- For example, the 'Default' instance of type 'Unpackspec' @(Field+ -- a, Field b)@ @(Field a, Field b)@ allows you to manipulate or+ -- extract the two 'HPQ.PrimExpr's inside a @(Field a, Field b)@. The+ -- 'Default' instance of type @Foo (Field a) (Field b) (Field c)@ -- will allow you to manipulate or extract the three 'HPQ.PrimExpr's -- contained therein (for a user-defined product type @Foo@, assuming- -- the @makeAdaptorAndInstance@ splice from+ -- the @makeAdaptorAndInstanceInferrable@ splice from -- @Data.Profunctor.Product.TH@ has been run). -- -- Users should almost never need to create or manipulate -- `Unpackspec`s. Typically they will be created automatically by -- the 'D.Default' instance. If you really need to you can create- -- 'Unpackspec's by hand using 'unpackspecColumn' and the+ -- 'Unpackspec's by hand using 'unpackspecField' and the -- 'Profunctor', 'ProductProfunctor' and 'SumProfunctor' operations.- Unpackspec (PM.PackMap HPQ.PrimExpr HPQ.PrimExpr columns columns')--{-# DEPRECATED unpackspecColumn "Use 'unpackspecField' instead. Will be removed in version 0.8." #-}-unpackspecColumn :: Unpackspec (C.Column a) (C.Column a)-unpackspecColumn = Unpackspec (PM.iso IC.unColumn IC.Column)+ Unpackspec (PM.PackMap HPQ.PrimExpr HPQ.PrimExpr fields fields') --- | Target the single 'HPQ.PrimExpr' inside a 'C.Column'-unpackspecField :: Unpackspec (C.Column a) (C.Column a)-unpackspecField = Unpackspec (PM.iso IC.unColumn IC.Column)+-- | Target the single 'HPQ.PrimExpr' inside a 'F.Field n'+unpackspecField :: Unpackspec (F.Field_ n a) (F.Field_ n a)+unpackspecField = dimap IC.unColumn IC.Column (Unpackspec (PM.PackMap id)) -- | Modify all the targeted 'HPQ.PrimExpr's runUnpackspec :: Applicative f@@ -55,7 +50,7 @@ collectPEs unpackspec = fst . runUnpackspec unpackspec f where f pe = ([pe], pe) -instance D.Default Unpackspec (C.Column a) (C.Column a) where+instance D.Default Unpackspec (F.Field_ n a) (F.Field_ n a) where def = unpackspecField -- {
src/Opaleye/Internal/Values.hs view
@@ -1,145 +1,111 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE Arrows #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-} module Opaleye.Internal.Values where -import Opaleye.Internal.Column (Column(Column))-import qualified Opaleye.Internal.Unpackspec as U+import Opaleye.Internal.Column (Field_(Column))+import qualified Opaleye.Internal.Column as C+import qualified Opaleye.Column as OC import qualified Opaleye.Internal.Tag as T+import qualified Opaleye.Internal.Operators as O import qualified Opaleye.Internal.PrimQuery as PQ import qualified Opaleye.Internal.PackMap as PM+import qualified Opaleye.Internal.QueryArr as Q import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ import qualified Opaleye.Internal.PGTypes import qualified Opaleye.SqlTypes -import Data.Functor.Identity (runIdentity)+import Control.Arrow (returnA)+import qualified Control.Monad.Trans.State.Strict as State import qualified Data.List.NonEmpty as NEL import Data.Profunctor (Profunctor, dimap, rmap, lmap) import Data.Profunctor.Product (ProductProfunctor) import qualified Data.Profunctor.Product as PP import Data.Profunctor.Product.Default (Default, def) -import Control.Applicative (Applicative, pure, (<*>))---- FIXME: We don't currently handle the case of zero columns. Need to--- emit a dummy column and data.-valuesU :: U.Unpackspec columns columns'- -> ValuesspecUnsafe columns columns'- -> [columns]- -> ((), T.Tag) -> (columns', PQ.PrimQuery, T.Tag)-valuesU unpack valuesspec rows ((), t) = (newColumns, primQ', T.next t)- where runRow row = valuesRow- where (_, valuesRow) =- PM.run (U.runUnpackspec unpack extractValuesEntry row)-- (newColumns, valuesPEs_nulls) =- PM.run (runValuesspec valuesspec (extractValuesField t))-- valuesPEs = map fst valuesPEs_nulls-- values :: [[HPQ.PrimExpr]]- values = map runRow rows-- primQ' = case NEL.nonEmpty values of- Nothing -> PQ.Empty ()- Just values' -> PQ.Values valuesPEs values'---- We don't actually use the return value of this. It might be better--- to come up with another Applicative instance for specifically doing--- what we need.-extractValuesEntry :: HPQ.PrimExpr -> PM.PM [HPQ.PrimExpr] HPQ.PrimExpr-extractValuesEntry pe = do- PM.write pe- return pe--extractValuesField :: T.Tag -> primExpr- -> PM.PM [(HPQ.Symbol, primExpr)] HPQ.PrimExpr-extractValuesField = PM.extractAttr "values"--newtype ValuesspecUnsafe columns columns' =- Valuesspec (PM.PackMap () HPQ.PrimExpr () columns')--runValuesspec :: Applicative f => ValuesspecUnsafe columns columns'- -> (() -> f HPQ.PrimExpr) -> f columns'-runValuesspec (Valuesspec v) f = PM.traversePM v f ()--instance Default ValuesspecUnsafe (Column a) (Column a) where- def = Valuesspec (PM.iso id Column)--valuesUSafe :: Valuesspec columns columns'- -> [columns]- -> ((), T.Tag) -> (columns', PQ.PrimQuery, T.Tag)-valuesUSafe valuesspec@(ValuesspecSafe _ unpack) rows ((), t) =- (newColumns, primQ', T.next t)- where runRow row =- case PM.run (U.runUnpackspec unpack extractValuesEntry row) of- (_, []) -> [zero]- (_, xs) -> xs-- (newColumns, valuesPEs_nulls) =- PM.run (runValuesspecSafe valuesspec (extractValuesField t))+import Control.Applicative (liftA2) - valuesPEs = map fst valuesPEs_nulls- nulls = case map snd valuesPEs_nulls of- [] -> [nullInt]- nulls' -> nulls'+nonEmptyValues :: Rowspec columns columns'+ -> NEL.NonEmpty columns+ -> Q.Select columns'+nonEmptyValues rowspec rows =+ let nerowspec' = case rowspec of+ NonEmptyRows nerowspec -> nerowspec+ EmptyRows fields ->+ dimap (const zero) (const fields) nonEmptyRowspecField+ where zero = 0 :: C.Field Opaleye.SqlTypes.SqlInt4+ in nonEmptyRows nerowspec' rows - yieldNoRows :: PQ.PrimQuery -> PQ.PrimQuery- yieldNoRows = PQ.restrict (HPQ.ConstExpr (HPQ.BoolLit False))+nonEmptyRows :: NonEmptyRowspec fields fields'+ -> NEL.NonEmpty fields+ -> Q.Select fields'+nonEmptyRows (NonEmptyRowspec runRow fields) rows =+ Q.productQueryArr $ do+ (valuesPEs, newColumns) <- fields+ pure (newColumns, PQ.Values (NEL.toList valuesPEs) (fmap (NEL.toList . runRow) rows)) - zero = HPQ.ConstExpr (HPQ.IntegerLit 0)- nullInt = HPQ.CastExpr (Opaleye.Internal.PGTypes.showSqlType- (Nothing :: Maybe Opaleye.SqlTypes.SqlInt4))- (HPQ.ConstExpr HPQ.NullLit)+emptySelectExplicit :: Nullspec columns a -> Q.Select a+emptySelectExplicit nullspec = proc () -> do+ O.restrict -< Opaleye.SqlTypes.sqlBool False+ returnA -< nullFields nullspec - (values, wrap) = case NEL.nonEmpty rows of- Nothing -> (pure nulls, yieldNoRows)- Just rows' -> (fmap runRow rows', id)+data NonEmptyRowspec fields fields' =+ NonEmptyRowspec (fields -> NEL.NonEmpty HPQ.PrimExpr)+ (State.State T.Tag (NEL.NonEmpty HPQ.Symbol, fields')) - primQ' = wrap (PQ.Values valuesPEs values)+-- Some overlap here with extractAttrPE+nonEmptyRowspecField :: NonEmptyRowspec (Field_ n a) (Field_ n a)+nonEmptyRowspecField = dimap C.unColumn C.Column $ NonEmptyRowspec pure s+ where s = do+ t <- T.fresh+ let symbol = HPQ.Symbol "values" t+ pure (pure symbol, HPQ.AttrExpr symbol) -data Valuesspec columns columns' =- ValuesspecSafe (PM.PackMap HPQ.PrimExpr HPQ.PrimExpr () columns')- (U.Unpackspec columns columns')+rowspecField :: Rowspec (Field_ n a) (Field_ n a)+rowspecField = NonEmptyRows nonEmptyRowspecField -type ValuesspecSafe = Valuesspec+data Rowspec fields fields' =+ NonEmptyRows (NonEmptyRowspec fields fields')+ | EmptyRows fields' -runValuesspecSafe :: Applicative f- => Valuesspec columns columns'- -> (HPQ.PrimExpr -> f HPQ.PrimExpr)- -> f columns'-runValuesspecSafe (ValuesspecSafe v _) f = PM.traversePM v f ()+data Valuesspec fields fields' =+ ValuesspecSafe (Nullspec fields fields')+ (Rowspec fields fields') valuesspecField :: Opaleye.SqlTypes.IsSqlType a- => Valuesspec (Column a) (Column a)-valuesspecField = def--instance Opaleye.Internal.PGTypes.IsSqlType a- => Default Valuesspec (Column a) (Column a) where- def = def_- where def_ = ValuesspecSafe (PM.PackMap (\f () -> fmap Column (f null_)))- U.unpackspecField- null_ = nullPE sqlType-+ => Valuesspec (Field_ n a) (Field_ n a)+valuesspecField = def_+ where def_ = valuesspecFieldType (Opaleye.Internal.PGTypes.showSqlType sqlType) sqlType = columnProxy def_- columnProxy :: f (Column sqlType) -> Maybe sqlType+ columnProxy :: f (Field_ n sqlType) -> Maybe sqlType columnProxy _ = Nothing -nullPE :: Opaleye.SqlTypes.IsSqlType a => proxy a -> HPQ.PrimExpr-nullPE sqlType = HPQ.CastExpr (Opaleye.Internal.PGTypes.showSqlType sqlType)- (HPQ.ConstExpr HPQ.NullLit)+-- For rel8+valuesspecFieldType :: String -> Valuesspec (Field_ n a) (Field_ n a)+valuesspecFieldType sqlType =+ ValuesspecSafe (nullspecFieldType sqlType) rowspecField --- Implementing this in terms of Valuesspec for convenience-newtype Nullspec fields fields' = Nullspec (Valuesspec fields fields')+instance forall a n. Opaleye.Internal.PGTypes.IsSqlType a+ => Default Valuesspec (Field_ n a) (Field_ n a) where+ def = ValuesspecSafe nullspecField rowspecField -nullspecField :: Opaleye.SqlTypes.IsSqlType b- => Nullspec a (Column b)-nullspecField = Nullspec (lmap e valuesspecField)- where e = error (concat [ "We looked at the argument of a Nullspec when we "- , "expected that we never would! This is a bug in "- , "Opaleye. Please report it, if you can reproduce "- , "it."- ])+newtype Nullspec fields fields' = Nullspec fields' +nullspecField :: forall a n sqlType.+ Opaleye.SqlTypes.IsSqlType sqlType+ => Nullspec a (Field_ n sqlType)+nullspecField = nullspecFieldType ty+ where ty = Opaleye.Internal.PGTypes.showSqlType (Nothing :: Maybe sqlType)++nullspecFieldType :: String+ -> Nullspec a (Field_ n sqlType)+nullspecFieldType sqlType =+ (Nullspec+ . C.unsafeCast sqlType+ . C.unsafeCoerceColumn)+ OC.null+ nullspecList :: Nullspec a [b] nullspecList = pure [] @@ -152,14 +118,14 @@ nullspecEitherRight = fmap Right instance Opaleye.SqlTypes.IsSqlType b- => Default Nullspec a (Column b) where+ => Default Nullspec a (Field_ n b) where def = nullspecField -- | All fields @NULL@, even though technically the type may forbid -- that! Used to create such fields when we know we will never look -- at them expecting to find something non-NULL. nullFields :: Nullspec a fields -> fields-nullFields (Nullspec v) = runIdentity (runValuesspecSafe v pure)+nullFields (Nullspec v) = v -- { @@ -188,24 +154,69 @@ ValuesspecSafe (f <*> x) (f' <*> x') instance Profunctor Valuesspec where- dimap f g (ValuesspecSafe q q') = ValuesspecSafe (rmap g q) (dimap f g q')+ dimap f g (ValuesspecSafe q q') = ValuesspecSafe (dimap f g q) (dimap f g q') instance ProductProfunctor Valuesspec where purePP = pure (****) = (<*>) instance Functor (Nullspec a) where- fmap f (Nullspec g) = Nullspec (fmap f g)+ fmap f (Nullspec g) = Nullspec (f g) instance Applicative (Nullspec a) where- pure = Nullspec . pure- Nullspec f <*> Nullspec x = Nullspec (f <*> x)+ pure = Nullspec+ Nullspec f <*> Nullspec x = Nullspec (f x) instance Profunctor Nullspec where- dimap f g (Nullspec q) = Nullspec (dimap f g q)+ dimap _ g (Nullspec q) = Nullspec (g q) instance ProductProfunctor Nullspec where purePP = pure (****) = (<*>) +instance Functor (NonEmptyRowspec a) where+ fmap = rmap++instance Profunctor NonEmptyRowspec where+ dimap f g (NonEmptyRowspec a b) =+ NonEmptyRowspec (lmap f a) ((fmap . fmap) g b)++instance Functor (Rowspec a) where+ fmap = rmap++instance Applicative (Rowspec a) where+ pure x = EmptyRows x+ r1 <*> r2 = case (r1, r2) of+ (EmptyRows f, EmptyRows x) -> EmptyRows (f x)+ (EmptyRows f, NonEmptyRows (NonEmptyRowspec x1 x2)) ->+ NonEmptyRows (NonEmptyRowspec x1 ((fmap . fmap) f x2))+ (NonEmptyRows (NonEmptyRowspec f1 f2), EmptyRows x) ->+ NonEmptyRows (NonEmptyRowspec f1 ((fmap . fmap) ($ x) f2))+ (NonEmptyRows (NonEmptyRowspec f1 f2),+ NonEmptyRows (NonEmptyRowspec x1 x2)) ->+ NonEmptyRows (NonEmptyRowspec+ (f1 <> x1)+ ((liftA2 . liftF2) ($) f2 x2))++ where -- Instead of depending on Apply+ -- https://www.stackage.org/haddock/lts-19.16/semigroupoids-5.3.7/Data-Functor-Apply.html#v:liftF2+ liftF2 :: Semigroup m+ => (a' -> b -> c) -> (m, a') -> (m, b) -> (m, c)+ liftF2 f (ys1, x1) (ys2, x2) = (ys1 <> ys2, f x1 x2)++instance Profunctor Rowspec where+ dimap f g = \case+ EmptyRows x -> EmptyRows (g x)+ NonEmptyRows x -> NonEmptyRows (dimap f g x)++instance ProductProfunctor Rowspec where+ purePP = pure+ (****) = (<*>)+ -- }++newtype ValuesspecUnsafe columns columns' =+ Valuesspec (PM.PackMap () HPQ.PrimExpr () columns')++instance Default ValuesspecUnsafe (Field_ n a) (Field_ n a) where+ def = Valuesspec (PM.iso id Column)
+ src/Opaleye/Internal/Window.hs view
@@ -0,0 +1,181 @@+-- https://www.postgresql.org/docs/current/tutorial-window.html#id-1.4.5.6.9.5+-- talks about partitions and window frames. The window frame is the+-- way the elements of a partition are ordered for processing the+-- result row of each element of the partition.+--+-- So neither of these terms is suitable for the _whole thing_.+-- Perhaps the answer should be "Window"? This is also attested by+-- the WINDOW declaration in a SELECT.++{-# LANGUAGE LambdaCase #-}++module Opaleye.Internal.Window where++import Data.Profunctor (lmap, Profunctor, dimap)++import qualified Opaleye.Internal.Aggregate as A+import qualified Opaleye.Internal.PackMap as PM+import qualified Opaleye.Internal.PrimQuery as PQ+import qualified Opaleye.Internal.QueryArr as Q+import qualified Opaleye.Internal.Tag as T+import qualified Opaleye.Internal.Column as C+import qualified Opaleye.Internal.Order as O++import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ+import Data.Functor.Contravariant (contramap, Contravariant)+import Control.Arrow (second)+++-- | 'WindowFunction' represents expressions that contain [window+-- functions](https://www.postgresql.org/docs/current/tutorial-window.html).+-- You can choose a 'WindowFunction' from the options below, and+-- combine and manipulate them using the @Applicative@ and+-- 'Data.Profunctor.Profunctor' operations.+newtype WindowFunction a b =+ WindowFunction (PM.PackMap HPQ.WndwOp HPQ.PrimExpr a b)++instance Functor (WindowFunction a) where+ fmap f (WindowFunction w) = WindowFunction (fmap f w)++instance Applicative (WindowFunction a) where+ pure = WindowFunction . pure+ WindowFunction f <*> WindowFunction x = WindowFunction ((<*>) f x)++instance Profunctor WindowFunction where+ dimap f g (WindowFunction w) = WindowFunction (dimap f g w)++-- | You can create @Windows@ using 'over', and combine and manipulate+-- them using the @Applicative@ and 'Data.Profunctor.Profunctor'+-- operations.+newtype Windows a b =+ Windows (PM.PackMap (HPQ.WndwOp, Window a) HPQ.PrimExpr a b)++instance Functor (Windows a) where+ fmap f (Windows w) = Windows (fmap f w)++instance Applicative (Windows a) where+ pure = Windows . pure+ Windows f <*> Windows x = Windows ((<*>) f x)++instance Profunctor Windows where+ dimap f g (Windows (PM.PackMap pm)) =+ Windows $ PM.PackMap $ \h a ->+ fmap g (pm (\(op, w) -> h (op, contramap f w)) (f a))++runWindows' :: Applicative f+ => Windows a b -> ((HPQ.WndwOp, Window a) -> f HPQ.PrimExpr) -> a -> f b+runWindows' (Windows a) = PM.traversePM a+++extractWindowFields+ :: T.Tag+ -> a+ -> (HPQ.WndwOp, Window a)+ -> PM.PM (PQ.Bindings (HPQ.WndwOp, HPQ.Partition)) HPQ.PrimExpr+extractWindowFields tag a (op, Window ps os) = do+ i <- PM.new+ let symbol = HPQ.Symbol ("window" ++ i) tag+ PM.write (symbol, (op, HPQ.Partition (ps a) (O.orderExprs a os)))+ pure (HPQ.AttrExpr symbol)+++-- | A 'WindowFunction' that doesn't actually contain any window+-- function.+noWindowFunction :: (a -> b) -> WindowFunction a b+noWindowFunction f = fmap f (WindowFunction (PM.PackMap (const pure)))+++-- | @runWindows@ runs a query composed of expressions containing+-- [window+-- functions](https://www.postgresql.org/docs/current/tutorial-window.html).+-- @runWindows@ is similar to 'Opaleye.aggregate', with the main+-- difference being that in a window query, each input row corresponds+-- to one output row, whereas aggregation queries fold the entire+-- input query down into a single row per group. In Haskell+-- terminology, 'Opaleye.aggregate' is to 'foldl' as @runWindows@ is+-- to 'scanl'.+runWindows :: Windows a b -> Q.Select a -> Q.Select b+runWindows wndw q = Q.productQueryArr $ do+ (a, primQ) <- Q.runSimpleSelect q+ tag <- T.fresh+ let+ (b, bindings) = PM.run (runWindows' wndw (extractWindowFields tag a) a)+ pure (b, PQ.Window bindings primQ)+++windowsApply :: Windows (Windows a b, a) b+windowsApply = Windows $ PM.PackMap $ \f (agg, a) ->+ case agg of+ Windows (PM.PackMap inner) -> inner (f . second (contramap snd)) a+++makeWndw :: WindowFunction HPQ.WndwOp (C.Field_ n a)+makeWndw = WindowFunction (PM.PackMap (\f op -> C.Column <$> f op))+++makeWndwField :: (HPQ.PrimExpr -> HPQ.WndwOp)+ -> WindowFunction (C.Field_ n a) (C.Field_ n' a')+makeWndwField f = lmap (f . C.unColumn) makeWndw+++makeWndwAny :: HPQ.WndwOp -> WindowFunction a (C.Field_ n b)+makeWndwAny op = lmap (const op) makeWndw++-- | 'aggregatorWindowFunction' allows the use of 'A.Aggregator's in+-- 'WindowFunction's. In particular, @'aggregatorWindowFunction'+-- 'Opaleye.sum'@ gives a running total (when combined with an order+-- argument to 'over').+aggregatorWindowFunction :: A.Aggregator a b -> (a' -> a) -> WindowFunction a' b+aggregatorWindowFunction agg g = WindowFunction $ PM.PackMap $ \f a ->+ pm (\case+ HPQ.GroupBy expr -> pure expr+ HPQ.Aggregate (HPQ.Aggr op e _ _ _ _) -> f (HPQ.WndwAggregate op e)) a+ where A.Aggregator (PM.PackMap pm) = lmap g agg++-- | 'over' applies a 'WindowFunction' on a particular 'Window'. For+-- example,+--+-- @+-- over ('aggregatorWindowFunction' 'Opaleye.sum' salary) ('partitionBy' department) ('Opaleye.desc' salary)+-- @+--+-- If you want to use a 'Window' that consists of the entire @SELECT@+-- then supply 'mempty' for the @'Window' a@ argument. If you don't+-- want to order the 'Window' then supply 'mempty' for the @'O.Order'+-- a@ argument.+over :: WindowFunction a b -> Window a -> O.Order a -> Windows a b+over (WindowFunction windowFunction) partition order =+ let PM.PackMap pm = windowFunction+ orderPartitionBy' = orderPartitionBy order+ in Windows $ PM.PackMap $ \f -> pm (\op ->+ f (op, partition <> orderPartitionBy'))++-- | In PostgreSQL, window functions must specify the \"window\" over+-- which they operate. The syntax for this looks like: @SUM(salary)+-- OVER (PARTITION BY department)@. The Opaleye type 'Window'+-- represents the segment consisting of the @PARTIION BY@.+--+-- You can create a @Window@ using 'partitionBy' and combine two+-- @Windows@ in a single one which combines the partition of both by+-- using '<>'.+data Window a = Window (a -> [HPQ.PrimExpr]) (O.Order a)++instance Semigroup (Window a) where+ Window p1 o1 <> Window p2 o2 = Window (p1 <> p2) (o1 <> o2)++instance Monoid (Window a) where+ mempty = Window mempty mempty+ mappend = (<>)++instance Contravariant Window where+ contramap f (Window p o) = Window (lmap f p) (contramap f o)++-- | The window where each partition shares the same value for the+-- given 'Field'.+partitionBy :: (a -> C.Field_ n b) -> Window a+partitionBy f = Window (\a -> [C.unColumn (f a)]) mempty++-- | Controls the order in which rows are processed by window functions. This+-- does not need to match the ordering of the overall query.+orderPartitionBy :: O.Order a -> Window a+orderPartitionBy = Window mempty
src/Opaleye/Join.hs view
@@ -1,8 +1,5 @@ -- | Left, right, and full outer joins. -{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} module Opaleye.Join where@@ -12,7 +9,6 @@ import qualified Opaleye.Internal.Join as J import qualified Opaleye.Internal.MaybeFields as M import qualified Opaleye.Internal.PrimQuery as PQ-import qualified Opaleye.Internal.Map as Map import qualified Opaleye.Select as S import qualified Opaleye.SqlTypes as T @@ -28,7 +24,7 @@ -- and more composable: -- -- - Inner joins: use 'Opaleye.Operators.where_' directly, along with--- @do@ notatation (or use 'Opaleye.Operators.restrict' directly,+-- @do@ notation (or use 'Opaleye.Operators.restrict' directly, -- along with arrow notation) -- -- - Left/right joins: use 'optional'@@ -43,11 +39,7 @@ -- -- - Full outer joins: use 'Opaleye.FunctionalJoin.fullJoinF' --- | NB Opaleye exports @Opaleye.Table.'Opaleye.Table.optional'@ from--- the top level. If you want this @optional@ you will have to import--- it from this module.------ Convenient access to lateral left/right join+-- | Convenient access to lateral left/right join -- functionality. Performs a @LATERAL LEFT JOIN@ under the hood and -- has behaviour equivalent to the following Haskell function: --@@ -146,19 +138,32 @@ -- -> Select ((Field a, Field b), (FieldNullable c, FieldNullable d)) -- @ --- | We suggest you use 'optionalRestrict' instead. Instead of writing+-- | We suggest you use 'optional' instead. Instead of writing -- \"@'Opaleye.Join.leftJoin' qL qR cond@\" you can write -- -- @+-- do+-- fieldsL <- qL+-- maybeFieldsR \<- 'optional' $ do+-- fieldsR <- qR+-- cond (fieldsL, fieldsR)+-- pure fieldsR+-- pure (fieldsL, maybeFieldsR)+-- @+--+-- Typically everything except the 'optional' block can be inlined in+-- surrounding @do@ notation. In such cases, readability and+-- maintainability increase dramatically.+--+-- Alternatively, if you have a reason to avoid @LATERAL@ joins you+-- can use 'optionalRestrict' and arrow notation.+--+-- @ -- proc () -> do -- fieldsL <- qL -< () -- maybeFieldsR \<- 'optionalRestrict' qR -\< 'Prelude.curry' cond fieldsL -- 'Control.Arrow.returnA' -< (fieldsL, maybeFieldsR) -- @------ Typically everything except the 'optionalRestrict' line can be--- inlined in surrounding arrow notation. In such cases, readability--- and maintainibility increase dramatically. leftJoin :: (D.Default U.Unpackspec fieldsL fieldsL, D.Default U.Unpackspec fieldsR fieldsR, D.Default J.NullMaker fieldsR nullableFieldsR)@@ -168,7 +173,7 @@ -> S.Select (fieldsL, nullableFieldsR) -- ^ Left join leftJoin = leftJoinExplicit D.def D.def D.def --- | We suggest you don't use this. 'optionalRestrict' is probably+-- | We suggest you don't use this. 'optional' or 'optionalRestrict' are probably -- better for your use case. 'Opaleye.Join.leftJoinA' is the same as -- 'optionalRestrict' except without the return type wrapped in -- 'Opaleye.Internal.MaybeFields.MaybeFields'.@@ -182,7 +187,7 @@ -- result comes out leftJoinA = leftJoinAExplict D.def D.def --- | We suggest you use 'optionalRestrict' instead. See 'leftJoin'+-- | We suggest you use 'optional' or 'optionalRestrict' instead. See 'leftJoin' -- for more details. rightJoin :: (D.Default U.Unpackspec fieldsL fieldsL, D.Default U.Unpackspec fieldsR fieldsR,@@ -253,53 +258,3 @@ -> S.SelectArr i a -> S.SelectArr i (M.MaybeFields a) optionalExplicit _ = M.optional---- * Inferrable versions (deprecated)--{-# DEPRECATED leftJoinInferrable "Use 'optionalRestrict' instead." #-}-leftJoinInferrable :: (D.Default U.Unpackspec fieldsL fieldsL,- D.Default U.Unpackspec fieldsR fieldsR,- D.Default J.NullMaker fieldsR nullableFieldsR,- Map.Map J.Nulled 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-leftJoinInferrable = leftJoin--{-# DEPRECATED rightJoinInferrable "Use 'optionalRestrict' instead." #-}-rightJoinInferrable :: (D.Default U.Unpackspec fieldsL fieldsL,- D.Default U.Unpackspec fieldsR fieldsR,- D.Default J.NullMaker fieldsL nullableFieldsL,- Map.Map J.Nulled 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-rightJoinInferrable = rightJoin---{-# DEPRECATED fullJoinInferrable "Use 'Opaleye.FunctionalJoin.rightJoinF' instead." #-}-fullJoinInferrable :: (D.Default U.Unpackspec fieldsL fieldsL,- D.Default U.Unpackspec fieldsR fieldsR,- D.Default J.NullMaker fieldsL nullableFieldsL,- D.Default J.NullMaker fieldsR nullableFieldsR,- Map.Map J.Nulled fieldsL ~ nullableFieldsL,- Map.Map J.Nulled 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-fullJoinInferrable = fullJoin
src/Opaleye/Label.hs view
@@ -1,4 +1,8 @@+{-# LANGUAGE Arrows #-}+ module Opaleye.Label (+ label',+ -- * Deprecated label ) where @@ -6,6 +10,16 @@ import qualified Opaleye.Internal.QueryArr as Q import qualified Opaleye.Select as S +import Control.Arrow (returnA)+ -- | Add a commented label to the generated SQL.+label' :: String -> S.Select ()+label' l = Q.selectArr f where+ f = pure (\() -> ((), PQ.aLabel l))++{-# DEPRECATED label "Will be removed in version 0.11. Use 'label\'' instead." #-} label :: String -> S.SelectArr a b -> S.SelectArr a b-label = Q.mapPrimQuery . PQ.Label+label l s = proc a -> do+ b <- s -< a+ label' l -< ()+ returnA -< b
src/Opaleye/Manipulation.hs view
@@ -1,6 +1,4 @@ {-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -11,22 +9,49 @@ -- generate SQL of the form -- -- @--- INSERT INTO thetable ('John', 1);+-- INSERT INTO thetable (\'John\', 1); -- @ -- -- but not -- -- @ -- INSERT INTO thetable--- SELECT 'John',+-- SELECT \'John\', -- (SELECT num FROM thetable ORDER BY num DESC LIMIT 1) + 1; -- @ -module Opaleye.Manipulation (module Opaleye.Manipulation,- -- | Currently 'HSql.DoNothing' is the+module Opaleye.Manipulation (-- * Insert+ runInsert,+ Insert(..),+ -- * Update+ runUpdate,+ Update(..),+ updateEasy,+ -- * Delete+ runDelete,+ Delete(..),+ -- * Returning+ MI.Returning,+ rCount,+ rReturning,+ rReturningI,+ rReturningExplicit,+ -- * On conflict+ -- | Currently 'doNothing' is the -- only conflict action supported by -- Opaleye.- HSql.OnConflict(..)) where+ HSql.OnConflict,+ doNothing,+ -- * Deprecated+ runInsert_,+ runUpdate_,+ runDelete_,+ -- ** @DoNothing@+ -- | Use 'doNothing' instead.+ -- @DoNothing@ will be removed in+ -- version 0.11.+ HSql.OnConflict(HSql.DoNothing),+ ) where import qualified Opaleye.Field as F import qualified Opaleye.RunSelect as RS@@ -34,7 +59,7 @@ import qualified Opaleye.Table as T import qualified Opaleye.Internal.Table as TI import Opaleye.Internal.Column (Column)-import Opaleye.Internal.Helpers ((.:), (.:.))+import Opaleye.Internal.Helpers ((.:.)) import Opaleye.Internal.Inferrable (Inferrable, runInferrable) import Opaleye.Internal.Manipulation (Updater(Updater)) import qualified Opaleye.Internal.Manipulation as MI@@ -54,59 +79,71 @@ -- | Run the 'Insert'. To create an 'Insert' use the 'Insert' -- constructor.-runInsert_ :: PGS.Connection+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+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.ReturningExplicit qr f, oc) ->- \c t r -> MI.runInsertManyReturningExplicit qr c t r f oc+ let insert = case returning_ of+ MI.Count ->+ runInsertMany' onConflict_+ MI.ReturningExplicit qr f ->+ \c t r -> MI.runInsertManyReturningExplicit qr c t r f onConflict_ in insert conn table_ rows_ +{-# DEPRECATED runInsert_ "Use 'runInsert' instead. Will be removed in 0.11." #-}+runInsert_ :: PGS.Connection+ -> Insert haskells+ -> IO haskells+runInsert_ = runInsert+ -- | Run the 'Update'. To create an 'Update' use the 'Update' -- constructor.-runUpdate_ :: PGS.Connection+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+runUpdate conn i = case i of+ Update table_ updateWith_ where_ returning_ -> case returning_ of MI.Count ->- runUpdate+ PGS.execute_ conn (fromString (MI.arrangeUpdateSql table_ updateWith_ where_)) MI.ReturningExplicit qr f ->- \c t u w -> runUpdateReturningExplicit qr c t u w f- in update conn table_ updateWith_ where_+ runUpdateReturningExplicit qr conn table_ updateWith_ where_ f +{-# DEPRECATED runUpdate_ "Use 'runUpdate' instead. Will be removed in 0.11." #-}+runUpdate_ :: PGS.Connection+ -> Update haskells+ -> IO haskells+runUpdate_ = runUpdate+ -- | Run the 'Delete'. To create an 'Delete' use the 'Delete' -- constructor.-runDelete_ :: PGS.Connection+runDelete :: PGS.Connection -- ^ -> Delete haskells -> IO haskells -- ^ Returns a type that depends on the 'MI.Returning' that -- you provided when creating the 'Delete'.-runDelete_ conn i = case i of- Delete table_ where_ returning_ ->- let delete = case returning_ of+runDelete conn i = case i of+ Delete table_ where_ returning_ -> case returning_ of MI.Count ->- runDelete+ PGS.execute_ conn (fromString (MI.arrangeDeleteSql table_ where_)) MI.ReturningExplicit qr f ->- \c t w -> MI.runDeleteReturningExplicit qr c t w f- in delete conn table_ where_+ MI.runDeleteReturningExplicit qr conn table_ where_ f +{-# DEPRECATED runDelete_ "Use 'runDelete' instead. Will be removed in 0.11." #-}+runDelete_ :: PGS.Connection+ -> Delete haskells+ -> IO haskells+runDelete_ = runDelete+ -- * Create a manipulation data Insert haskells = forall fieldsW fieldsR. Insert@@ -119,7 +156,7 @@ -- -- * 'iOnConflict' @=@ 'Nothing' means omit @ON CONFLICT@ statement --- -- * 'iOnConflict' @=@ 'Just' 'HSql.DoNothing' means @ON CONFLICT DO+ -- * 'iOnConflict' @=@ 'Just' 'HSql.doNothing' means @ON CONFLICT DO -- NOTHING@ } @@ -127,7 +164,7 @@ { uTable :: T.Table fieldsW fieldsR , uUpdateWith :: fieldsR -> fieldsW -- ^ Be careful: providing 'Nothing' to a field created by- -- 'Opaleye.Table.optional' updates the field to its default+ -- 'Opaleye.Table.optionalTableField' updates the field to its default -- value. Many users have been confused by this because they -- assume it means that the field is to be left unchanged. For an -- easier time wrap your update function in 'updateEasy'.@@ -135,12 +172,15 @@ , uReturning :: MI.Returning fieldsR haskells } --- | A convenient wrapper for writing your update function+-- | A convenient wrapper for writing your update function.+-- @updateEasy@ protects you from accidentally updating an+-- 'Opaleye.Table.optionalTableField' with @Nothing@ (i.e. SQL+-- @DEFAULT@). See 'uUpdateWith'. -- -- @uUpdateWith = updateEasy (\\... -> ...)@ updateEasy :: D.Default Updater fieldsR fieldsW => (fieldsR -> fieldsR)- -- ^+ -- ^ ͘ -> (fieldsR -> fieldsW) updateEasy u = u' . u where Updater u' = D.def@@ -166,7 +206,7 @@ -- 'rReturning'. rReturning :: D.Default RS.FromFields fields haskells => (fieldsR -> fields)- -- ^+ -- ^ ͘ -> MI.Returning fieldsR [haskells] rReturning = rReturningExplicit D.def @@ -175,14 +215,14 @@ -- flexible. rReturningI :: D.Default (Inferrable RS.FromFields) fields haskells => (fieldsR -> fields)- -- ^+ -- ^ ͘ -> MI.Returning fieldsR [haskells] rReturningI = rReturningExplicit (runInferrable D.def) -- | Return a function of the inserted or updated rows. Explicit -- version. You probably just want to use 'rReturning' instead. rReturningExplicit :: RS.FromFields fields haskells- -- ^+ -- ^ ͘ -> (fieldsR -> fields) -- ^ -> MI.Returning fieldsR [haskells]@@ -190,153 +230,18 @@ -- * Deprecated versions --- | Insert rows into a table with @ON CONFLICT DO NOTHING@-{-# DEPRECATED runInsertManyOnConflictDoNothing "Use 'runInsert_'. Will be removed in version 0.8." #-}-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 =+runInsertMany' :: Maybe HSql.OnConflict+ -> PGS.Connection+ -> TI.Table columnsW columnsR+ -> [columnsW]+ -> IO Int64+runInsertMany' oc 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 .:. 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_'. Will be removed in version 0.8." #-}-runInsertManyReturningOnConflictDoNothing- :: (D.Default RS.FromFields 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--{-# DEPRECATED runInsertMany "Use 'runInsert_' instead. Will be removed in version 0.8." #-}-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 .: MI.arrangeInsertManySqlI) t columns'--{-# DEPRECATED runInsertManyReturning "Use 'runInsert_' instead. Will be removed in version 0.8." #-}-runInsertManyReturning :: (D.Default RS.FromFields 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--{-# DEPRECATED runInsertReturningExplicit "Use 'runInsert_' instead. Will be removed in version 0.8." #-}-runInsertReturningExplicit :: RS.FromFields columnsReturned haskells- -> PGS.Connection- -> T.Table columnsW columnsR- -> columnsW- -> (columnsR -> columnsReturned)- -> IO [haskells]-runInsertReturningExplicit = MI.runInsertReturningExplicit--{-# DEPRECATED runInsertManyReturningExplicit "Use 'runInsert_' instead. Will be removed in version 0.8." #-}-runInsertManyReturningExplicit :: RS.FromFields columnsReturned haskells- -> PGS.Connection- -> T.Table columnsW columnsR- -> [columnsW]- -> (columnsR -> columnsReturned)- -> IO [haskells]-runInsertManyReturningExplicit = MI.runInsertManyReturningExplicitI--{-# DEPRECATED runInsertManyReturningOnConflictDoNothingExplicit "Use 'runInsert_' instead. Will be removed in version 0.8." #-}-runInsertManyReturningOnConflictDoNothingExplicit- :: RS.FromFields 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)--{-# DEPRECATED runUpdateEasy "Use 'runUpdate_' instead. Will be removed in version 0.8." #-}-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--{-# DEPRECATED runUpdate "Use 'runUpdate_' instead. Will be removed in version 0.8." #-}-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 .:. MI.arrangeUpdateSql--{-# DEPRECATED runUpdateReturning "Use 'runUpdate_' instead. Will be removed in version 0.8." #-}-runUpdateReturning :: (D.Default RS.FromFields 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+ t columns' oc -{-# DEPRECATED runUpdateReturningExplicit "Use 'runUpdate_' instead. Will be removed in version 0.8." #-} runUpdateReturningExplicit :: RS.FromFields columnsReturned haskells -> PGS.Connection -> T.Table columnsW columnsR@@ -347,19 +252,9 @@ runUpdateReturningExplicit qr conn t update cond r = PGS.queryWith_ parser conn (fromString (MI.arrangeUpdateReturningSql u t update cond r))- where IRQ.QueryRunner u _ _ = qr+ where IRQ.FromFields u _ _ = qr parser = IRQ.prepareRowParser qr (r v) TI.View v = TI.tableColumnsView (TI.tableColumns t) -{-# DEPRECATED runDelete "Use 'runDelete_' instead. Will be removed in version 0.8." #-}-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 .: MI.arrangeDeleteSql+doNothing :: HSql.OnConflict+doNothing = HSql.DoNothing
− src/Opaleye/Map.hs
@@ -1,4 +0,0 @@-module Opaleye.Map {-# DEPRECATED "This module will be removed in 0.8." #-}- (module Opaleye.Internal.Map) where--import Opaleye.Internal.Map
src/Opaleye/MaybeFields.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE FlexibleContexts #-}- -- | 'MaybeFields' is Opaleye's analogue to 'Data.Maybe.Maybe'. You -- probably won't want to create values of type 'MaybeFields' -- directly; instead they will appear as the result of@@ -7,17 +5,25 @@ -- 'Opaleye.Join.optionalRestrict' and 'Opaleye.Join.optional'. module Opaleye.MaybeFields (+ -- * 'MaybeFields' type MaybeFields,+ -- * Creating a 'MaybeFields' nothingFields,+ nothingFieldsOfTypeOf, justFields,+ nullableToMaybeFields,+ -- * Using a 'MaybeFields' matchMaybe, fromMaybeFields, maybeFields,- maybeFieldsToSelect,- nothingFieldsOfTypeOf,- catMaybeFields,+ maybeFieldsToNullable,+ isJustAnd,+ -- * Creating a 'Select' which returns 'MaybeFields' Opaleye.Join.optional, Opaleye.MaybeFields.traverseMaybeFields,+ -- * Using a 'Select' which returns 'MaybeFields'+ catMaybeFields,+ maybeFieldsToSelect, -- * Adaptors Nullspec, nullspecField,@@ -60,7 +66,7 @@ => SelectArr a b -- ^ -> SelectArr (MaybeFields a) (MaybeFields b)- -- ^+ -- ^ ͘ traverseMaybeFields = Opaleye.Internal.MaybeFields.traverseMaybeFields -- The Unpackspecs are currently redundant, but I'm adding them in
src/Opaleye/Operators.hs view
@@ -1,9 +1,8 @@ {-# LANGUAGE Arrows #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE DataKinds #-} -- We can probably disable ConstraintKinds and TypeSynonymInstances -- when we move to Sql... instead of PG..@@ -56,14 +55,13 @@ , upper , like , ilike- , charLength , sqlLength -- * Containment operators , in_+ , inMany , inSelect -- * JSON operators , SqlIsJson- , PGIsJson , SqlJsonIndex , PGJsonIndex , (.->)@@ -88,6 +86,7 @@ , index , arrayPosition , sqlElem+ , sqlElemAny -- * Range operators , overlap , liesWithin@@ -105,27 +104,28 @@ , IntervalNum , addInterval , minusInterval+ , TimestampPrecision(..)+ , dateTruncTimestamp+ , dateTruncTimestamptz -- * Deprecated- , exists- , notExists- , inQuery- , keepWhen ) where import qualified Control.Arrow as A-import qualified Data.Foldable as F+import qualified Data.Foldable as F hiding (null) import qualified Data.List.NonEmpty as NEL import Prelude hiding (not) import qualified Opaleye.Exists as E import qualified Opaleye.Field as F-import Opaleye.Internal.Column (Column(Column), unsafeCase_,+import Opaleye.Internal.Column (Field_(Column), Field, FieldNullable,+ Nullability(Nullable),+ unsafeCase_, unsafeIfThenElse, unsafeGt) import qualified Opaleye.Internal.Column as C import qualified Opaleye.Internal.JSONBuildObjectFields as JBOF import Opaleye.Internal.QueryArr (SelectArr(QueryArr),- Query, QueryArr, runSimpleQueryArr)+ runSimpleQueryArr') import qualified Opaleye.Internal.PrimQuery as PQ import qualified Opaleye.Internal.Operators as O import Opaleye.Internal.Helpers ((.:))@@ -140,6 +140,9 @@ import qualified Data.Profunctor.Product.Default as D +import qualified Data.Text as Text+import qualified Data.Text.Encoding as TE+ {-| Keep only the rows of a query satisfying a given condition, using an SQL @WHERE@ clause. It is equivalent to the Haskell function @@ -163,74 +166,76 @@ restrictExists criteria = QueryArr f where -- A where exists clause can always refer to columns defined by the -- query it references so needs no special treatment on LATERAL.- f (a, t0) = ((), \_ primQ -> PQ.Semijoin PQ.Semi primQ existsQ, t1) where- (_, existsQ, t1) = runSimpleQueryArr criteria (a, t0)+ f a = do+ (_, existsQ) <- runSimpleQueryArr' criteria a+ pure ((), PQ.aSemijoin PQ.Semi existsQ) {-| Add a @WHERE NOT EXISTS@ clause to the current query. -} restrictNotExists :: S.SelectArr a b -> S.SelectArr a () restrictNotExists criteria = QueryArr f where -- A where exists clause can always refer to columns defined by the -- query it references so needs no special treatment on LATERAL.- f (a, t0) = ((), \_ primQ -> PQ.Semijoin PQ.Anti primQ existsQ, t1) where- (_, existsQ, t1) = runSimpleQueryArr criteria (a, t0)+ f a = do+ (_, existsQ) <- runSimpleQueryArr' criteria a+ pure ((), PQ.aSemijoin PQ.Anti existsQ) infix 4 .==-(.==) :: Column a -> Column a -> F.Field T.SqlBool+(.==) :: Field a -> Field a -> F.Field T.SqlBool (.==) = C.binOp (HPQ.:==) infix 4 ./=-(./=) :: Column a -> Column a -> F.Field T.SqlBool+(./=) :: Field a -> Field 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+-- have run `makeAdaptorAndInstanceInferrable` on. This may be unified with -- `.==` in a future version. (.===) :: 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+-- you have run `makeAdaptorAndInstanceInferrable` on. This may be unified with -- `./=` in a future version. (./==) :: D.Default O.EqPP fields fields => fields -> fields -> F.Field T.SqlBool (./==) = Opaleye.Operators.not .: (O..==) infix 4 .>-(.>) :: Ord.SqlOrd a => Column a -> Column a -> F.Field T.SqlBool+(.>) :: Ord.SqlOrd a => Field a -> Field a -> F.Field T.SqlBool (.>) = unsafeGt infix 4 .<-(.<) :: Ord.SqlOrd a => Column a -> Column a -> F.Field T.SqlBool+(.<) :: Ord.SqlOrd a => Field a -> Field a -> F.Field T.SqlBool (.<) = C.binOp (HPQ.:<) infix 4 .<=-(.<=) :: Ord.SqlOrd a => Column a -> Column a -> F.Field T.SqlBool+(.<=) :: Ord.SqlOrd a => Field a -> Field a -> F.Field T.SqlBool (.<=) = C.binOp (HPQ.:<=) infix 4 .>=-(.>=) :: Ord.SqlOrd a => Column a -> Column a -> F.Field T.SqlBool+(.>=) :: Ord.SqlOrd a => Field a -> Field a -> F.Field T.SqlBool (.>=) = C.binOp (HPQ.:>=) -- | Integral division, named after 'Prelude.quot'. It maps to the -- @/@ operator in Postgres.-quot_ :: C.SqlIntegral a => Column a -> Column a -> Column a+quot_ :: C.SqlIntegral a => Field a -> Field a -> Field 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.SqlIntegral a => Column a -> Column a -> Column a+rem_ :: C.SqlIntegral a => Field a -> Field a -> Field a rem_ = C.binOp HPQ.OpMod -- | Select the first case for which the condition is true.-case_ :: [(F.Field T.SqlBool, Column a)] -> Column a -> Column a+case_ :: [(F.Field T.SqlBool, Field_ n a)] -> Field_ n a -> Field_ n a case_ = unsafeCase_ -- | Monomorphic if\/then\/else. -- -- This may be replaced by 'ifThenElseMany' in a future version.-ifThenElse :: F.Field T.SqlBool -> Column a -> Column a -> Column a+ifThenElse :: F.Field T.SqlBool -> Field_ n a -> Field_ n a -> Field_ n a ifThenElse = unsafeIfThenElse -- | Polymorphic if\/then\/else.@@ -281,41 +286,48 @@ ilike :: F.Field T.SqlText -> F.Field T.SqlText -> F.Field T.SqlBool ilike = C.binOp HPQ.OpILike --- {-# DEPRECATED charLength "You probably want to use 'sqlLength' instead" #-}--- | Do not use. Will be deprecated in 0.8. You probably want to use--- 'sqlLength' instead.-charLength :: C.PGString a => Column a -> Column Int-charLength (Column e) = Column (HPQ.FunExpr "char_length" [e])--sqlLength :: C.PGString a => F.Field a -> F.Field T.SqlInt4+sqlLength :: C.SqlString a => F.Field a -> F.Field T.SqlInt4 sqlLength (Column e) = Column (HPQ.FunExpr "length" [e]) -- | 'in_' is designed to be used in prefix form. ----- '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 -> 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))+-- 'in_' @validUsers@ @user@ checks whether @user@ is a valid user.+-- 'in_' @validUsers@ is a function which checks whether a user is a+-- valid user.+in_ :: (F.Foldable f) => f (Field a) -> Field a -> F.Field T.SqlBool+in_ fcas (Column a) = case NEL.nonEmpty (F.toList fcas) of+ Nothing -> T.sqlBool False+ Just xs -> Column $ HPQ.BinExpr HPQ.OpIn a (HPQ.ListExpr (fmap C.unColumn xs)) +-- | @inMany@ is a generalization of 'in_' to values with multiple+-- fields. It is designed to be used in prefix form.+--+-- @inMany validUsers user@ checks whether @user@ is a valid user.+-- @inMany validUsers@ is a function which checks whether a user is a+-- valid user.+inMany ::+ (F.Foldable f, D.Default O.EqPP fields fields) =>+ f fields ->+ fields ->+ F.Field T.SqlBool+inMany xs x = ors (fmap (.=== x) (F.toList xs))+ -- | True if the first argument occurs amongst the rows of the second, -- false otherwise. -- -- This operation is equivalent to Postgres's @IN@ operator. inSelect :: D.Default O.EqPP fields fields => fields -> S.Select fields -> S.Select (F.Field T.SqlBool)-inSelect c q = E.exists (keepWhen (c .===) A.<<< q)+inSelect c q = E.exists $ proc () -> do+ r <- q -< ()+ restrict -< c .=== r+ A.returnA -< r -- | Class of Postgres types that represent json values. -- 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 SqlIsJson a--{-# DEPRECATED PGIsJson "Use SqlIsJson instead" #-}-type PGIsJson = SqlIsJson+class SqlIsJson json instance SqlIsJson T.SqlJson instance SqlIsJson T.SqlJsonb@@ -325,6 +337,7 @@ -- Warning: making additional instances of this class can lead to broken code! class SqlJsonIndex a +-- | Use 'SqlJsonIndex' instead. Will be deprecated in a future version. type PGJsonIndex = SqlJsonIndex instance SqlJsonIndex T.SqlInt4@@ -333,33 +346,33 @@ -- | Get JSON object field by key. infixl 8 .->-(.->) :: (SqlIsJson a, SqlJsonIndex k)- => F.FieldNullable a -- ^+(.->) :: (SqlIsJson json, SqlJsonIndex k)+ => F.FieldNullable json -- ^ -> F.Field k -- ^ key or index- -> F.FieldNullable a+ -> F.FieldNullable json (.->) = C.binOp (HPQ.:->) -- | Get JSON object field as text. infixl 8 .->>-(.->>) :: (SqlIsJson a, SqlJsonIndex k)- => F.FieldNullable a -- ^+(.->>) :: (SqlIsJson json, SqlJsonIndex k)+ => F.FieldNullable json -- ^ -> F.Field k -- ^ key or index -> F.FieldNullable T.SqlText (.->>) = C.binOp (HPQ.:->>) -- | Get JSON object at specified path. infixl 8 .#>-(.#>) :: (SqlIsJson a)- => F.FieldNullable a -- ^- -> Column (T.SqlArray T.SqlText) -- ^ path- -> F.FieldNullable a+(.#>) :: (SqlIsJson json)+ => F.FieldNullable json -- ^+ -> Field (T.SqlArray T.SqlText) -- ^ path+ -> F.FieldNullable json (.#>) = C.binOp (HPQ.:#>) -- | Get JSON object at specified path as text. infixl 8 .#>>-(.#>>) :: (SqlIsJson a)- => F.FieldNullable a -- ^- -> Column (T.SqlArray T.SqlText) -- ^ path+(.#>>) :: (SqlIsJson json)+ => F.FieldNullable json -- ^+ -> Field (T.SqlArray T.SqlText) -- ^ path -> F.FieldNullable T.SqlText (.#>>) = C.binOp (HPQ.:#>>) @@ -381,89 +394,97 @@ -- | Do any of these key/element strings exist? infix 4 .?| (.?|) :: F.Field T.SqlJsonb- -> Column (T.SqlArray T.SqlText)+ -> Field (T.SqlArray T.SqlText) -> F.Field T.SqlBool (.?|) = C.binOp (HPQ.:?|) -- | Do all of these key/element strings exist? infix 4 .?& (.?&) :: F.Field T.SqlJsonb- -> Column (T.SqlArray T.SqlText)+ -> Field (T.SqlArray T.SqlText) -> F.Field T.SqlBool (.?&) = C.binOp (HPQ.:?&) -emptyArray :: T.IsSqlType a => Column (T.SqlArray a)+emptyArray :: T.IsSqlType a => Field (T.SqlArray_ n a) emptyArray = T.sqlArray id [] -- | Append two 'T.SqlArray's-arrayAppend :: F.Field (T.SqlArray a) -> F.Field (T.SqlArray a) -> F.Field (T.SqlArray a)+arrayAppend :: F.Field (T.SqlArray_ n a) -> F.Field (T.SqlArray_ n a) -> F.Field (T.SqlArray_ n a) arrayAppend = C.binOp (HPQ.:||) -- | Prepend an element to a 'T.SqlArray'-arrayPrepend :: Column a -> Column (T.SqlArray a) -> Column (T.SqlArray a)+arrayPrepend :: Field_ n a -> Field (T.SqlArray_ n a) -> Field (T.SqlArray_ n a) arrayPrepend (Column e) (Column es) = Column (HPQ.FunExpr "array_prepend" [e, es]) -- | Remove all instances of an element from a 'T.SqlArray'-arrayRemove :: Column a -> Column (T.SqlArray a) -> Column (T.SqlArray a)+arrayRemove :: Field_ n a -> Field (T.SqlArray_ n a) -> Field (T.SqlArray_ n a) arrayRemove (Column e) (Column es) = Column (HPQ.FunExpr "array_remove" [es, e]) -- | Remove all 'NULL' values from a 'T.SqlArray'-arrayRemoveNulls :: Column (T.SqlArray (C.Nullable a)) -> Column (T.SqlArray a)-arrayRemoveNulls = Column.unsafeCoerceColumn . arrayRemove Column.null+arrayRemoveNulls :: Field (T.SqlArray_ Nullable a) -> Field (T.SqlArray a)+arrayRemoveNulls = Column.unsafeCoerceColumn . arrayRemove F.null -singletonArray :: T.IsSqlType a => Column a -> Column (T.SqlArray a)+singletonArray :: T.IsSqlType a => Field_ n a -> Field (T.SqlArray_ n a) singletonArray x = arrayPrepend x emptyArray -index :: (C.SqlIntegral n) => Column (T.SqlArray a) -> Column n -> Column (C.Nullable a)+index :: (C.SqlIntegral n) => Field (T.SqlArray_ n' a) -> Field n -> FieldNullable a index (Column a) (Column b) = Column (HPQ.ArrayIndex a b) -- | Postgres's @array_position@-arrayPosition :: F.Field (T.SqlArray a) -- ^ Haystack- -> F.Field a -- ^ Needle- -> F.Field (Column.Nullable T.SqlInt4)+arrayPosition :: F.Field (T.SqlArray_ n a) -- ^ Haystack+ -> F.Field_ n a -- ^ Needle+ -> F.FieldNullable T.SqlInt4 arrayPosition (Column fs) (Column f') = C.Column (HPQ.FunExpr "array_position" [fs , f']) -- | Whether the element (needle) exists in the array (haystack). -- N.B. this is implemented hackily using @array_position@. If you--- need it to be implemented using @= any@ then please open an issue.-sqlElem :: F.Field a -- ^ Needle- -> F.Field (T.SqlArray a) -- ^ Haystack+-- want the equivalent implemented using @= any@ then use+-- 'sqlElemAny'.+sqlElem :: F.Field_ n a -- ^ Needle+ -> F.Field (T.SqlArray_ n a) -- ^ Haystack -> F.Field T.SqlBool sqlElem f fs = (O.not . F.isNull . arrayPosition fs) f -overlap :: Column (T.SqlRange a) -> Column (T.SqlRange a) -> F.Field T.SqlBool+-- | Whether the element (needle) exists in the array (haystack).+-- This is implemented using @= any@.+sqlElemAny :: F.Field_ n a -- ^ Needle+ -> F.Field (T.SqlArray_ n a) -- ^ Haystack+ -> F.Field T.SqlBool+sqlElemAny (Column f) (Column fs) = Column $ HPQ.AnyExpr (HPQ.:==) f fs++overlap :: Field (T.SqlRange a) -> Field (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 :: T.IsRangeType a => Field a -> Field (T.SqlRange a) -> F.Field T.SqlBool liesWithin = C.binOp (HPQ.:<@) -- | Access the upper bound of a range. For discrete range types it is the exclusive bound.-upperBound :: T.IsRangeType a => Column (T.SqlRange a) -> Column (C.Nullable a)+upperBound :: T.IsRangeType a => Field (T.SqlRange a) -> FieldNullable a upperBound (Column range) = Column $ HPQ.FunExpr "upper" [range] -- | Access the lower bound of a range. For discrete range types it is the inclusive bound.-lowerBound :: T.IsRangeType a => Column (T.SqlRange a) -> Column (C.Nullable a)+lowerBound :: T.IsRangeType a => Field (T.SqlRange a) -> FieldNullable a lowerBound (Column range) = Column $ HPQ.FunExpr "lower" [range] infix 4 .<<-(.<<) :: Column (T.SqlRange a) -> Column (T.SqlRange a) -> F.Field T.SqlBool+(.<<) :: Field (T.SqlRange a) -> Field (T.SqlRange a) -> F.Field T.SqlBool (.<<) = C.binOp (HPQ.:<<) infix 4 .>>-(.>>) :: Column (T.SqlRange a) -> Column (T.SqlRange a) -> F.Field T.SqlBool+(.>>) :: Field (T.SqlRange a) -> Field (T.SqlRange a) -> F.Field T.SqlBool (.>>) = C.binOp (HPQ.:>>) infix 4 .&<-(.&<) :: Column (T.SqlRange a) -> Column (T.SqlRange a) -> F.Field T.SqlBool+(.&<) :: Field (T.SqlRange a) -> Field (T.SqlRange a) -> F.Field T.SqlBool (.&<) = C.binOp (HPQ.:&<) infix 4 .&>-(.&>) :: Column (T.SqlRange a) -> Column (T.SqlRange a) -> F.Field T.SqlBool+(.&>) :: Field (T.SqlRange a) -> Field (T.SqlRange a) -> F.Field T.SqlBool (.&>) = C.binOp (HPQ.:&>) infix 4 .-|--(.-|-) :: Column (T.SqlRange a) -> Column (T.SqlRange a) -> F.Field T.SqlBool+(.-|-) :: Field (T.SqlRange a) -> Field (T.SqlRange a) -> F.Field T.SqlBool (.-|-) = C.binOp (HPQ.:-|-) timestamptzAtTimeZone :: F.Field T.SqlTimestamptz@@ -495,37 +516,31 @@ minusInterval :: IntervalNum from to => F.Field from -> F.Field T.SqlInterval -> F.Field to minusInterval = C.binOp (HPQ.:-) -{-# DEPRECATED exists "Identical to 'restrictExists'. Will be removed in version 0.8." #-}-exists :: QueryArr a b -> QueryArr a ()-exists = restrictExists--{-# DEPRECATED notExists "Identical to 'restrictNotExists'. Will be removed in version 0.8." #-}-notExists :: QueryArr a b -> QueryArr a ()-notExists = restrictNotExists--{-# DEPRECATED inQuery "Identical to 'inSelect'. Will be removed in version 0.8." #-}-inQuery :: D.Default O.EqPP fields fields- => fields -> Query fields -> S.Select (F.Field T.SqlBool)-inQuery = inSelect--{-| This function is probably not useful and is likely to be deprecated- in the future.+-- | Current date and time (start of current transaction)+now :: F.Field T.SqlTimestamptz+now = Column $ HPQ.FunExpr "now" [] -Keep only the rows of a query satisfying a given condition, using-an SQL @WHERE@ clause.+data TimestampPrecision =+ MicrosecondsPrecision+ | MillisecondsPrecision+ | SecondPrecision+ | MinutePrecision+ | HourPrecision+ | DayPrecision+ | WeekPrecision+ | MonthPrecision+ | QuarterPrecision+ | YearPrecision+ | DecadePrecision+ | CenturyPrecision+ | MillenniumPrecision+ deriving Show -You would typically use 'keepWhen' if you want to write-your query using a "point free" style. If you want to use 'A.Arrow'-notation then 'restrict' will suit you better.+precisionToExpr :: TimestampPrecision -> HPQ.PrimExpr+precisionToExpr p = HPQ.ConstExpr . HPQ.ByteStringLit . TE.encodeUtf8 . Text.toLower . Text.dropEnd 9 . Text.pack $ show p -This is the 'S.SelectArr' equivalent of 'Prelude.filter' from the-'Prelude'.--}-keepWhen :: (a -> F.Field T.SqlBool) -> S.SelectArr a a-keepWhen p = proc a -> do- restrict -< p a- A.returnA -< a+dateTruncTimestamp :: TimestampPrecision -> F.Field T.SqlTimestamp -> F.Field T.SqlTimestamp+dateTruncTimestamp p (Column e) = Column $ HPQ.FunExpr "date_trunc" [(precisionToExpr p), e] --- | Current date and time (start of current transaction)-now :: F.Field T.SqlTimestamptz-now = Column $ HPQ.FunExpr "now" []+dateTruncTimestamptz :: TimestampPrecision -> F.Field T.SqlTimestamptz -> F.Field T.SqlTimestamptz+dateTruncTimestamptz p (Column e) = Column $ HPQ.FunExpr "date_trunc" [(precisionToExpr p), e]
src/Opaleye/Order.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleContexts #-}- -- | @ORDER BY@, @LIMIT@, @OFFSET@ and @DISTINCT ON@ module Opaleye.Order ( -- * Order by@@ -11,25 +7,32 @@ , asc , desc , ascNullsFirst+ , ascNullsLast , descNullsLast+ , descNullsFirst -- * Limit and offset , limit+ , limitField , offset+ , offsetField -- * Distinct on- , distinctOnCorrect- , distinctOnByCorrect+ , distinctOn+ , distinctOnBy -- * Exact ordering , O.exact -- * Other- , PGOrd , SqlOrd+ -- * Explicit versions+ , distinctOnExplicit+ , distinctOnByExplicit -- * Deprecated- , distinctOn- , distinctOnBy+ , distinctOnCorrect+ , distinctOnByCorrect ) where import qualified Data.Profunctor.Product.Default as D-import qualified Opaleye.Column as C+import qualified Opaleye.Field as F+import qualified Opaleye.Internal.Column as C import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ import qualified Opaleye.Internal.Order as O import qualified Opaleye.Internal.QueryArr as Q@@ -55,30 +58,41 @@ -} orderBy :: O.Order a -> S.Select a -> S.Select a orderBy os q =- Q.productQueryArr (O.orderByU os . Q.runSimpleQueryArr q)+ Q.productQueryArr $ do+ a_pq <- Q.runSimpleSelect q+ pure (O.orderByU os a_pq) -- | Specify an ascending ordering by the given expression.--- (Any NULLs appear last)-asc :: SqlOrd b => (a -> C.Column b) -> O.Order a+asc :: SqlOrd b => (a -> F.Field 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 :: SqlOrd b => (a -> C.Column b) -> O.Order a+desc :: SqlOrd b => (a -> F.Field 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 :: SqlOrd b => (a -> C.Column b) -> O.Order a+ascNullsFirst :: SqlOrd b => (a -> F.Field_ n b) -> O.Order a ascNullsFirst = O.order HPQ.OrderOp { HPQ.orderDirection = HPQ.OpAsc , HPQ.orderNulls = HPQ.NullsFirst } +-- | Specify an ascending ordering by the given expression.+-- (Any NULLs appear last)+ascNullsLast :: SqlOrd b => (a -> F.Field_ n b) -> O.Order a+ascNullsLast = O.order HPQ.OrderOp { HPQ.orderDirection = HPQ.OpAsc+ , HPQ.orderNulls = HPQ.NullsLast } -- | Specify an descending ordering by the given expression.+-- (Any NULLs appear first)+descNullsFirst :: SqlOrd b => (a -> F.Field_ n b) -> O.Order a+descNullsFirst = O.order HPQ.OrderOp { HPQ.orderDirection = HPQ.OpDesc+ , HPQ.orderNulls = HPQ.NullsFirst }++-- | Specify an descending ordering by the given expression. -- (Any NULLs appear last)-descNullsLast :: SqlOrd b => (a -> C.Column b) -> O.Order a+descNullsLast :: SqlOrd b => (a -> F.Field_ n b) -> O.Order a descNullsLast = O.order HPQ.OrderOp { HPQ.orderDirection = HPQ.OpDesc , HPQ.orderNulls = HPQ.NullsLast } @@ -112,8 +126,15 @@ @ -} limit :: Int -> S.Select a -> S.Select a-limit n a = Q.productQueryArr (O.limit' n . Q.runSimpleQueryArr a)+limit = limitField . fromIntegral +-- | A version of 'limit' that can accept a @Field@ rather than a+-- constant @Int@.+limitField :: F.Field T.SqlInt8 -> S.Select a -> S.Select a+limitField (C.Column n) a = Q.productQueryArr $ do+ a_pq <- Q.runSimpleSelect a+ pure (O.limit' n a_pq)+ {- | Offset the results of the given 'S.Select' by the given amount, skipping that many result rows.@@ -122,31 +143,31 @@ 'offset' with 'limit'. -} offset :: Int -> S.Select a -> S.Select a-offset n a = Q.productQueryArr (O.offset' n . Q.runSimpleQueryArr a)+offset = offsetField . fromIntegral +-- | A version of 'offset' that can accept a @Field@ rather than a+-- constant @Int@.+offsetField :: F.Field T.SqlInt8 -> S.Select a -> S.Select a+offsetField (C.Column n) a = Q.productQueryArr $ do+ a_pq <- Q.runSimpleSelect a+ pure (O.offset' n a_pq)+ -- * Distinct on --- | Keep a row from each set where the given function returns the same result. No--- ordering is guaranteed. Multiple fields may be distinguished by projecting out--- tuples of 'Opaleye.Field.Field_'s. Use 'distinctOnBy' to control how the rows--- are chosen.+{-# DEPRECATED distinctOnCorrect "Use 'distinctOn' instead. Will be removed in 0.11." #-} distinctOnCorrect :: D.Default U.Unpackspec b b => (a -> b) -> S.Select a -> S.Select a-distinctOnCorrect proj q = Q.productQueryArr (O.distinctOnCorrect D.def proj . Q.runSimpleQueryArr q)-+distinctOnCorrect = distinctOnExplicit D.def --- | Keep the row from each set where the given function returns the same result. The--- row is chosen according to which comes first by the supplied ordering. However, no--- output ordering is guaranteed. Mutliple fields may be distinguished by projecting--- out tuples of 'Opaleye.Field.Field_'s.+{-# DEPRECATED distinctOnByCorrect "Use 'distinctOnBy' instead. Will be removed in 0.11." #-} distinctOnByCorrect :: D.Default U.Unpackspec b b => (a -> b) -> O.Order a -> S.Select a -> S.Select a-distinctOnByCorrect proj ord q = Q.productQueryArr (O.distinctOnByCorrect D.def proj ord . Q.runSimpleQueryArr q)+distinctOnByCorrect = distinctOnByExplicit D.def -- * Other@@ -154,9 +175,6 @@ -- | Typeclass for Postgres types which support ordering operations. class SqlOrd a where -{-# DEPRECATED PGOrd "Use SqlOrd instead" #-}-type PGOrd = SqlOrd- instance SqlOrd T.SqlBool instance SqlOrd T.SqlDate instance SqlOrd T.SqlFloat8@@ -172,19 +190,35 @@ instance SqlOrd T.SqlTimestamp instance SqlOrd T.SqlCitext instance SqlOrd T.SqlUuid-instance SqlOrd a => SqlOrd (C.Nullable a) --- | Use 'distinctOnCorrect' instead. This version has a bug whereby--- it returns the whole query if zero columns are chosen to be--- distinct (it should just return the first row). Will be deprecated--- in version 0.8.+-- | Keep a row from each set where the given function returns the same result. No+-- ordering is guaranteed. Multiple fields may be distinguished by projecting out+-- tuples of 'Opaleye.Field.Field_'s. Use 'distinctOnBy' to control how the rows+-- are chosen. distinctOn :: D.Default U.Unpackspec b b => (a -> b) -> S.Select a -> S.Select a-distinctOn proj q = Q.productQueryArr (O.distinctOn D.def proj . Q.runSimpleQueryArr q)+distinctOn = distinctOnCorrect --- | Use 'distinctOnByCorrect' instead. This version has a bug--- whereby it returns the whole query if zero columns are chosen to be--- distinct (it should just return the first row). Will be deprecated--- in version 0.8.+-- | Keep the row from each set where the given function returns the same result. The+-- row is chosen according to which comes first by the supplied ordering. However, no+-- output ordering is guaranteed. Multiple fields may be distinguished by projecting+-- out tuples of 'Opaleye.Field.Field_'s. distinctOnBy :: D.Default U.Unpackspec b b => (a -> b) -> O.Order a -> S.Select a -> S.Select a-distinctOnBy proj ord q = Q.productQueryArr (O.distinctOnBy D.def proj ord . Q.runSimpleQueryArr q)+distinctOnBy = distinctOnByCorrect++distinctOnExplicit :: U.Unpackspec b b+ -> (a -> b)+ -> S.Select a+ -> S.Select a+distinctOnExplicit unpack proj q = Q.productQueryArr $ do+ a_pq <- Q.runSimpleSelect q+ pure (O.distinctOn unpack proj a_pq)++distinctOnByExplicit :: U.Unpackspec b b+ -> (a -> b)+ -> O.Order a+ -> S.Select a+ -> S.Select a+distinctOnByExplicit unpack proj ord q = Q.productQueryArr $ do+ a_pq <- Q.runSimpleSelect q+ pure (O.distinctOnBy unpack proj ord a_pq)
− src/Opaleye/PGTypes.hs
@@ -1,4 +0,0 @@-module Opaleye.PGTypes {-# DEPRECATED "Use \"Opaleye.SqlTypes\" instead." #-}- (module Opaleye.Internal.PGTypesExternal) where--import Opaleye.Internal.PGTypesExternal
− src/Opaleye/QueryArr.hs
@@ -1,3 +0,0 @@-module Opaleye.QueryArr {-# DEPRECATED "Use \"Opaleye.Select\" instead. This module will be removed in 0.8." #-} (Query, QueryArr) where--import Opaleye.Internal.QueryArr (QueryArr, Query)
− src/Opaleye/RunQuery.hs
@@ -1,4 +0,0 @@-module Opaleye.RunQuery {-# DEPRECATED "Use \"Opaleye.RunSelect\" instead." #-}- (module Opaleye.Internal.RunQueryExternal) where--import Opaleye.Internal.RunQueryExternal
src/Opaleye/RunSelect.hs view
@@ -1,11 +1,10 @@-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} module Opaleye.RunSelect (-- * Running 'S.Select's- runSelect, runSelectI,+ runSelect, runSelectFold, -- * Cursor interface declareCursor,@@ -29,10 +28,8 @@ runSelectTF, ) where -import qualified Data.Profunctor as P import qualified Database.PostgreSQL.Simple as PGS -import qualified Opaleye.Column as C import qualified Opaleye.Select as S import qualified Opaleye.Internal.RunQueryExternal as RQ import qualified Opaleye.TypeFamilies as TF@@ -42,38 +39,27 @@ import qualified Data.Profunctor.Product.Default as D --- | @runSelect@'s use of the @'D.Default' 'FromFields'@+-- | An alternative version of @runSelectI@ that is more general but+-- has worse type inference. @runSelect@'s use of the @'D.Default'+-- 'FromFields'@ -- 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' ('Opaleye.Field.Field' 'Opaleye.SqlTypes.SqlInt4', 'Opaleye.Field.Field' 'Opaleye.SqlTypes.SqlText') -> IO [(Int, String)]--- @------ Assuming the @makeAdaptorAndInstance@ splice has been run for the product type @Foo@:------ @--- runSelect :: 'S.Select' (Foo ('Opaleye.Field.Field' 'Opaleye.SqlTypes.SqlInt4') ('Opaleye.Field.Field' 'Opaleye.SqlTypes.SqlText') ('Opaleye.Field.Field' 'Opaleye.SqlTypes.SqlBool')--- -> IO [Foo Int String Bool]--- @ runSelect :: D.Default FromFields fields haskells => PGS.Connection -- ^ -> S.Select fields- -- ^+ -- ^ ͘ -> IO [haskells] runSelect = RQ.runQuery --- | Will be deprecated in 0.8. Use 'runSelectI' instead.+{-# DEPRECATED runSelectTF "Use 'runSelectI' instead." #-} runSelectTF :: D.Default FromFields (rec TF.O) (rec TF.H) => PGS.Connection -- ^ -> S.Select (rec TF.O)- -- ^+ -- ^ ͘ -> IO [rec TF.H] runSelectTF = RQ.runQuery @@ -91,7 +77,7 @@ -> b -- ^ -> (b -> haskells -> IO b)- -- ^+ -- ^ ͘ -> IO b runSelectFold = RQ.runQueryFold @@ -102,7 +88,7 @@ => PGS.Connection -- ^ -> S.Select fields- -- ^+ -- ^ ͘ -> IO (IRQ.Cursor haskells) declareCursor = RQ.declareCursor @@ -121,7 +107,7 @@ -> (a -> haskells -> IO a) -- ^ -> a- -- ^+ -- ^ ͘ -> IO (Either a a) foldForward = RQ.foldForward @@ -130,9 +116,10 @@ -- -- @ -- newtype Foo = Foo Int+-- data SqlFoo ----- instance DefaultFromField Foo Foo where--- defaultFromField = unsafeFromField Foo defaultFromField+-- instance 'IRQ.DefaultFromField' SqlFoo Foo where+-- 'IRQ.defaultFromField' = unsafeFromField Foo defaultFromField -- @ -- -- It is \"unsafe\" because it does not check that the @sqlType@@@ -140,11 +127,8 @@ unsafeFromField :: (b -> b') -> IRQ.FromField sqlType b -> IRQ.FromField sqlType' b'-unsafeFromField haskellF qrc = IRQ.QueryRunnerColumn (P.lmap colF u)- (fmapFP haskellF fp)- where IRQ.QueryRunnerColumn u fp = qrc- fmapFP = fmap . fmap . fmap- colF = C.unsafeCoerceColumn+unsafeFromField haskellF (IRQ.FromField fp) =+ fmap haskellF (IRQ.FromField fp) runSelectExplicit :: FromFields fields haskells -> PGS.Connection@@ -168,11 +152,22 @@ -> IO (IRQ.Cursor haskells) declareCursorExplicit = RQ.declareCursorExplicit --- | Version of 'runSelect' with better type inference+-- | Example type specialization:+--+-- @+-- runSelectI :: 'S.Select' ('Opaleye.Field.Field' 'Opaleye.SqlTypes.SqlInt4', 'Opaleye.Field.Field' 'Opaleye.SqlTypes.SqlText') -> IO [(Int, String)]+-- @+--+-- Assuming the @makeAdaptorAndInstanceInferrable@ splice has been run for the product type @Foo@:+--+-- @+-- runSelectI :: 'S.Select' (Foo ('Opaleye.Field.Field' 'Opaleye.SqlTypes.SqlInt4') ('Opaleye.Field.Field' 'Opaleye.SqlTypes.SqlText') ('Opaleye.Field.Field' 'Opaleye.SqlTypes.SqlBool')+-- -> IO [Foo Int String Bool]+-- @ runSelectI :: (D.Default (Inferrable FromFields) fields haskells) => PGS.Connection -- ^ -> S.Select fields- -- ^+ -- ^ ͘ -> IO [haskells] runSelectI = RQ.runQueryExplicit (runInferrable D.def)
src/Opaleye/Select.hs view
@@ -1,4 +1,4 @@--- | A 'Select' represents an SQL @SELECT@ statment. To run a+-- | A 'Select' represents an SQL @SELECT@ statement. To run a -- 'Select' use the functions in "Opaleye.RunSelect". To create a -- 'Select' you probably want to start by querying one of your -- 'Opaleye.Table.Table's using 'Opaleye.Table.selectTable'.
src/Opaleye/Sql.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables #-} module Opaleye.Sql ( -- * Showing SQL@@ -7,11 +7,6 @@ -- * Explicit versions showSqlExplicit, showSqlUnoptExplicit,- -- * Deprecated functions- showSqlForPostgres,- showSqlForPostgresUnopt,- showSqlForPostgresExplicit,- showSqlForPostgresUnoptExplicit, ) where import qualified Opaleye.Internal.Unpackspec as U@@ -35,7 +30,7 @@ -- showSql :: Select (Field a, Field b) -> Maybe String -- @ ----- Assuming the @makeAdaptorAndInstance@ splice has been run for the+-- Assuming the @makeAdaptorAndInstanceInferrable@ splice has been run for the -- product type @Foo@: -- -- @@@ -59,21 +54,3 @@ showSqlUnoptExplicit :: U.Unpackspec fields b -> S.Select fields -> Maybe String showSqlUnoptExplicit = Pr.formatAndShowSQL .: Q.runQueryArrUnpack--{-# DEPRECATED showSqlForPostgres "Will be removed in version 0.8. Use 'showSql' instead." #-}-showSqlForPostgres :: forall columns . D.Default U.Unpackspec columns columns =>- S.Select columns -> Maybe String-showSqlForPostgres = showSql--{-# DEPRECATED showSqlForPostgresUnopt "Will be removed in version 0.8. Use 'showSqlUnopt' instead." #-}-showSqlForPostgresUnopt :: forall columns . D.Default U.Unpackspec columns columns =>- S.Select columns -> Maybe String-showSqlForPostgresUnopt = showSqlUnopt--{-# DEPRECATED showSqlForPostgresExplicit "Will be removed in version 0.8. Use 'showSqlExplicit' instead." #-}-showSqlForPostgresExplicit :: U.Unpackspec columns b -> S.Select columns -> Maybe String-showSqlForPostgresExplicit = showSqlExplicit--{-# DEPRECATED showSqlForPostgresUnoptExplicit "Will be removed in version 0.8. Use 'showSqlUnoptExplicit' instead." #-}-showSqlForPostgresUnoptExplicit :: U.Unpackspec columns b -> S.Select columns -> Maybe String-showSqlForPostgresUnoptExplicit = showSqlUnoptExplicit
src/Opaleye/SqlTypes.hs view
@@ -9,6 +9,7 @@ sqlDouble, sqlInt8, sqlNumeric,+ sqlInt2, -- ** Types SqlInt4, SqlFloat8,@@ -16,6 +17,10 @@ SqlInt8, SqlInt2, SqlFloat4,+ -- ** Type classes+ IC.SqlNum,+ IC.SqlIntegral,+ IC.SqlFractional, -- * Date and time -- ** Creating values sqlDay,@@ -60,11 +65,14 @@ SqlText, SqlVarcharN, SqlCitext,+ -- ** Type classes+ IC.SqlString, -- * Array -- ** Creating values sqlArray, -- ** Types SqlArray,+ SqlArray_, -- * Range -- ** Creating values sqlRange,@@ -82,12 +90,13 @@ SqlUuid, SqlBytea, -- * @IsSqlType@- P.IsSqlType,- -- * Entire module- module Opaleye.SqlTypes,+ P.IsSqlType(P.showSqlType),+ IPT.sqlTypeWithSchema, ) where import qualified Opaleye.Field as F+import qualified Opaleye.Internal.Column as IC+import qualified Opaleye.Internal.PGTypes as IPT import qualified Opaleye.Internal.PGTypesExternal as P import Opaleye.Internal.PGTypesExternal (IsSqlType, IsRangeType) import Opaleye.Internal.PGTypesExternal (SqlBool,@@ -107,6 +116,7 @@ SqlUuid, SqlCitext, SqlArray,+ SqlArray_, SqlBytea, SqlJson, SqlJsonb,@@ -116,12 +126,12 @@ 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.Int (Int16, Int64) import Data.Scientific as Sci import qualified Data.Text as SText import qualified Data.Text.Lazy as LText import qualified Data.Time.Compat as Time-import qualified Data.UUID as UUID+import qualified Data.UUID.Types as UUID import qualified Database.PostgreSQL.Simple.Range as R @@ -145,6 +155,9 @@ sqlNumeric :: Sci.Scientific -> F.Field SqlNumeric sqlNumeric = P.pgNumeric +sqlInt2 :: Int16 -> F.Field SqlInt2+sqlInt2 = P.pgInt2+ sqlInt4 :: Int -> F.Field SqlInt4 sqlInt4 = P.pgInt4 @@ -217,7 +230,7 @@ sqlValueJSONB :: Ae.ToJSON a => a -> F.Field SqlJsonb sqlValueJSONB = P.pgValueJSONB -sqlArray :: IsSqlType b => (a -> F.Field b) -> [a] -> F.Field (SqlArray b)+sqlArray :: IsSqlType b => (a -> F.Field_ n b) -> [a] -> F.Field (SqlArray_ n b) sqlArray = P.pgArray sqlRange :: IsRangeType b
src/Opaleye/Table.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-- {- | Table fields can be required or optional and, independently, nullable or@@ -15,7 +11,7 @@ @ The leftmost argument is the type of writes. When you insert or- update into this column you must give it a @Field SqlInt4@ (which you+ update into this field you must give it a @Field SqlInt4@ (which you can define with @sqlInt4 :: Int -> Field SqlInt4@). A required nullable @SqlInt4@ is defined with 'T.requiredTableField' and gives rise@@ -25,7 +21,7 @@ TableFields (FieldNullable SqlInt4) (FieldNullable SqlInt4) @ - When you insert or update into this column you must give it a+ When you insert or update into this field you must give it a @FieldNullable SqlInt4@, which you can define either with @sqlInt4@ and @toNullable :: Field a -> FieldNullable a@, or with @null :: FieldNullable a@.@@ -37,10 +33,10 @@ TableFields (Maybe (Field SqlInt4)) (Field SqlInt4) @ - Optional columns are those that can be omitted on writes, such as+ Optional fields 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- (Field SqlInt4)@. If you provide @Nothing@ then the column will be+ When you insert or update into this field you must give it a @Maybe+ (Field SqlInt4)@. If you provide @Nothing@ then the field will be omitted from the query and the default value will be used. Otherwise you have to provide a @Just@ containing a @Field SqlInt4@. @@ -51,9 +47,9 @@ TableFields (Maybe (FieldNullable SqlInt4)) (FieldNullable SqlInt4) @ - Optional columns are those that can be omitted on writes, such as+ Optional fields 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+ When you insert or update into this field you must give it a @Maybe (FieldNullable SqlInt4)@. If you provide @Nothing@ then the default value will be used. Otherwise you have to provide a @Just@ containing a @FieldNullable SqlInt4@ (which can be null).@@ -66,30 +62,22 @@ T.Table, T.tableField, T.optionalTableField,- T.readOnlyTableField, T.requiredTableField,+ T.omitOnWriteTableField,+ T.InferrableTableField, -- * Selecting from tables selectTable, -- * Data types- T.TableColumns, TableFields, -- * Explicit versions selectTableExplicit,- -- * Deprecated- T.optional,- T.readOnly,- T.required,- T.tableColumn,- View,- Writer,- T.Table(T.Table, T.TableWithSchema),- queryTable,- queryTableExplicit) where+ -- * Deprecated versions+ T.readOnlyTableField,+ ) where import qualified Opaleye.Internal.QueryArr as Q import qualified Opaleye.Internal.Table as T-import Opaleye.Internal.Table (View, Table, Writer,- TableFields)+import Opaleye.Internal.Table (Table, TableFields) import qualified Opaleye.Internal.Tag as Tag import qualified Opaleye.Internal.Unpackspec as U@@ -105,7 +93,7 @@ -- -> Select (Field a, Field b) -- @ ----- Assuming the @makeAdaptorAndInstance@ splice has been run for the+-- Assuming the @makeAdaptorAndInstanceInferrable@ splice has been run for the -- product type @Foo@: -- -- @@@ -114,7 +102,7 @@ -- @ selectTable :: D.Default U.Unpackspec fields fields => Table a fields- -- ^+ -- ^ ͘ -> S.Select fields selectTable = selectTableExplicit D.def @@ -139,20 +127,9 @@ selectTableExplicit :: U.Unpackspec tablefields fields -- ^ -> Table a tablefields- -- ^+ -- ^ ͘ -> S.Select fields-selectTableExplicit cm table' = Q.productQueryArr f where- f ((), t0) = (retwires, primQ, Tag.next t0) where- (retwires, primQ) = T.queryTable cm table' t0---- * Deprecated versions--{-# DEPRECATED queryTable "Use 'selectTable' instead. Will be removed in version 0.8." #-}-queryTable :: D.Default U.Unpackspec fields fields =>- Table a fields -> S.Select fields-queryTable = selectTable--{-# DEPRECATED queryTableExplicit "Use 'selectTableExplicit' instead. Will be removed in version 0.8." #-}-queryTableExplicit :: U.Unpackspec tablefields fields ->- Table a tablefields -> S.Select fields-queryTableExplicit = selectTableExplicit+selectTableExplicit cm table' = Q.productQueryArr $ do+ t0 <- Tag.fresh+ let (retwires, primQ) = T.queryTable cm table' t0+ pure (retwires, primQ)
src/Opaleye/ToFields.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE FlexibleContexts #-}- module Opaleye.ToFields (-- * Creating 'Field's from Haskell values toFields, toFieldsI,@@ -50,6 +48,6 @@ -- | Version of 'C.toFields' with better type inference toFieldsI :: (D.Default (Inferrable C.ToFields) haskells fields) => haskells- -- ^+ -- ^ ͘ -> fields toFieldsI = toFieldsExplicit (runInferrable D.def)
src/Opaleye/TypeFamilies.hs view
@@ -1,6 +1,4 @@--- | Will be deprecated in 0.8.--module Opaleye.TypeFamilies+module Opaleye.TypeFamilies {-# DEPRECATED "No longer supported" #-} ( TF.TableRecordField , TF.RecordField , (TF.:<*>)@@ -17,7 +15,6 @@ , TF.Opt , TF.Req , TF.Nulls- , TF.TableField ) where import Opaleye.Internal.TypeFamilies as TF
src/Opaleye/Values.hs view
@@ -1,40 +1,18 @@-{-# LANGUAGE FlexibleContexts #-}- module Opaleye.Values( values, -- * Explicit versions valuesExplicit, -- * Adaptors V.Valuesspec,- V.ValuesspecSafe, V.valuesspecField,- -- * Deprecated versions- valuesSafe,- valuesSafeExplicit,- valuesUnsafe,- valuesUnsafeExplicit, ) where -import qualified Opaleye.Internal.QueryArr as Q-import Opaleye.Internal.Values as V-import qualified Opaleye.Internal.Unpackspec as U+import qualified Opaleye.Internal.Values as V import qualified Opaleye.Select as S +import qualified Data.List.NonEmpty as NEL import Data.Profunctor.Product.Default (Default, def) --- | Do not use. Will be deprecated in 0.8.-valuesUnsafe :: (Default V.ValuesspecUnsafe fields fields,- Default U.Unpackspec fields fields) =>- [fields] -> S.Select fields-valuesUnsafe = valuesUnsafeExplicit def def---- | Do not use. Will be deprecated in 0.8.-valuesUnsafeExplicit :: U.Unpackspec fields fields'- -> V.ValuesspecUnsafe fields fields'- -> [fields] -> S.Select fields'-valuesUnsafeExplicit unpack valuesspec fields =- Q.productQueryArr (V.valuesU unpack valuesspec fields)- -- | 'values' implements Postgres's @VALUES@ construct and allows you -- to create a @SELECT@ that consists of the given rows. --@@ -44,7 +22,7 @@ -- values :: [(Field a, Field b)] -> Select (Field a, Field b) -- @ ----- Assuming the @makeAdaptorAndInstance@ splice has been run for the+-- Assuming the @makeAdaptorAndInstanceInferrable@ splice has been run for the -- product type @Foo@: -- -- @@@ -56,15 +34,6 @@ valuesExplicit :: V.Valuesspec fields fields' -> [fields] -> S.Select fields'-valuesExplicit valuesspec fields =- Q.productQueryArr (V.valuesUSafe valuesspec fields)---- | Use 'values' instead. Will be deprecated in 0.8.-valuesSafe :: Default V.Valuesspec fields fields- => [fields] -> S.Select fields-valuesSafe = values---- | Use 'valuesExplicit' instead. Will be deprecated in 0.8.-valuesSafeExplicit :: V.Valuesspec fields fields'- -> [fields] -> S.Select fields'-valuesSafeExplicit = valuesExplicit+valuesExplicit (V.ValuesspecSafe nullspec rowspec) fields = case NEL.nonEmpty fields of+ Nothing -> V.emptySelectExplicit nullspec+ Just rows -> V.nonEmptyValues rowspec rows
+ src/Opaleye/Window.hs view
@@ -0,0 +1,114 @@+-- | Support for [PostgreSQL window+-- functions](https://www.postgresql.org/docs/current/tutorial-window.html)++module Opaleye.Window+ (+ -- * Run window functions on a @Select@+ W.runWindows++ -- * Create @Windows@+ , W.Windows+ , W.over++ -- * Create a @Window@+ , W.Window+ , W.partitionBy++ -- * Create a @WindowFunction@+ , W.WindowFunction++ -- * Window functions++ -- | You might like to also refer to [the Postgres+ -- documentation page that describes its window+ -- functions](https://www.postgresql.org/docs/devel/functions-window.html).++ , W.noWindowFunction+ , W.aggregatorWindowFunction+ , rowNumber+ , rank+ , denseRank+ , percentRank+ , cumeDist+ , ntile+ , lag+ , lead+ , firstValue+ , lastValue+ , nthValue+ ) where++import qualified Opaleye.Internal.Column as IC+import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ+import qualified Opaleye.Internal.Window as W++import qualified Opaleye.Field as F+import qualified Opaleye.SqlTypes as T++-- | [@row_number()@](https://www.postgresql.org/docs/current/functions-window.html)+rowNumber :: W.WindowFunction a (F.Field T.SqlInt8)+rowNumber = W.makeWndwAny HPQ.WndwRowNumber+++-- | [@rank()@](https://www.postgresql.org/docs/current/functions-window.html)+rank :: W.WindowFunction a (F.Field T.SqlInt8)+rank = W.makeWndwAny HPQ.WndwRank+++-- | [@dense_rank()@](https://www.postgresql.org/docs/current/functions-window.html)+denseRank :: W.WindowFunction a (F.Field T.SqlInt8)+denseRank = W.makeWndwAny HPQ.WndwDenseRank+++-- | [@percent_rank()@](https://www.postgresql.org/docs/current/functions-window.html)+percentRank :: W.WindowFunction a (F.Field T.SqlFloat8)+percentRank = W.makeWndwAny HPQ.WndwPercentRank+++-- | [@cume_dist()@](https://www.postgresql.org/docs/current/functions-window.html)+cumeDist :: W.WindowFunction a (F.Field T.SqlFloat8)+cumeDist = W.makeWndwAny HPQ.WndwCumeDist+++-- | [@ntile(num_buckets)@](https://www.postgresql.org/docs/current/functions-window.html)+ntile :: F.Field T.SqlInt4+ -- ^ num_buckets+ -> W.WindowFunction a (F.Field T.SqlInt4)+ntile (IC.Column buckets) = W.makeWndwAny $ HPQ.WndwNtile buckets+++-- | [@lag(value, offset, default)@](https://www.postgresql.org/docs/current/functions-window.html)+lag :: F.Field T.SqlInt4+ -- ^ offset+ -> F.Field_ n a+ -- ^ default+ -> W.WindowFunction (F.Field_ n a) (F.Field_ n a)+lag (IC.Column offset) (IC.Column def) =+ W.makeWndwField $ \a -> HPQ.WndwLag a offset def+++-- | [@lead(value, offset, default)@](https://www.postgresql.org/docs/current/functions-window.html)+lead :: F.Field T.SqlInt4+ -- ^ offset+ -> F.Field_ n a+ -- ^ default+ -> W.WindowFunction (F.Field_ n a) (F.Field_ n a)+lead (IC.Column offset) (IC.Column def) =+ W.makeWndwField $ \a -> HPQ.WndwLead a offset def+++-- | [@first_value(value)@](https://www.postgresql.org/docs/current/functions-window.html)+firstValue :: W.WindowFunction (F.Field_ n a) (F.Field_ n a)+firstValue = W.makeWndwField HPQ.WndwFirstValue+++-- | [@last_value(value)@](https://www.postgresql.org/docs/current/functions-window.html)+lastValue :: W.WindowFunction (F.Field_ n a) (F.Field_ n a)+lastValue = W.makeWndwField HPQ.WndwLastValue+++-- | [@nth_value(value, n)@](https://www.postgresql.org/docs/current/functions-window.html)+nthValue :: F.Field T.SqlInt4+ -- ^ n+ -> W.WindowFunction (F.Field_ n a) (F.FieldNullable a)+nthValue (IC.Column n) = W.makeWndwField $ \a -> HPQ.WndwNthValue a n
+ src/Opaleye/With.hs view
@@ -0,0 +1,150 @@+module Opaleye.With+ ( with,+ withMaterialized,+ withRecursive,+ withRecursiveDistinct,++ -- * Explicit versions+ withExplicit,+ withMaterializedExplicit,+ withRecursiveExplicit,+ withRecursiveDistinctExplicit,+ )+where++import Control.Category ((>>>))+import Control.Monad.Trans.State.Strict (State)+import Data.Profunctor.Product.Default (Default, def)+import Opaleye.Binary (unionAllExplicit, unionExplicit)+import Opaleye.Internal.Binary (Binaryspec (..))+import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ+import Opaleye.Internal.PackMap (PackMap (..))+import qualified Opaleye.Internal.PackMap as PM+import qualified Opaleye.Internal.PrimQuery as PQ+import Opaleye.Internal.QueryArr (Select, productQueryArr, runSimpleSelect)+import Opaleye.Internal.Rebind (rebindExplicitPrefixNoStar)+import qualified Opaleye.Internal.Sql as Sql+import qualified Opaleye.Internal.Tag as Tag+import Opaleye.Internal.Unpackspec (Unpackspec (..), runUnpackspec)++with :: Default Unpackspec a a => Select a -> (Select a -> Select b) -> Select b+with = withExplicit def++withMaterialized :: Default Unpackspec a a => Select a -> (Select a -> Select b) -> Select b+withMaterialized = withMaterializedExplicit def++-- | Denotionally, @withRecursive s f@ is the smallest set of rows @r@ such+-- that+--+-- @+-- r == s \`'unionAll'\` (r >>= f)+-- @+--+-- Operationally, @withRecursive s f@ takes each row in an initial set @s@ and+-- supplies it to @f@, resulting in a new generation of rows which are added+-- to the result set. Each row from this new generation is then fed back to+-- @f@, and this process is repeated until a generation comes along for which+-- @f@ returns an empty set for each row therein.+withRecursive :: Default Binaryspec a a => Select a -> (a -> Select a) -> Select a+withRecursive = withRecursiveExplicit def++-- | Denotationally, @withRecursiveDistinct s f@ is the smallest set of rows+-- @r@ such that+--+-- @+-- r == s \`'union'\` (r >>= f)+-- @+--+-- Operationally, @withRecursiveDistinct s f@ takes each /distinct/ row in an+-- initial set @s@ and supplies it to @f@, resulting in a new generation of+-- rows. Any rows returned by @f@ that already exist in the result set are not+-- considered part of this new generation by `withRecursiveDistinct` (in+-- contrast to `withRecursive`). This new generation is then added to the+-- result set, and each row therein is then fed back to @f@, and this process+-- is repeated until a generation comes along for which @f@ returns no rows+-- that don't already exist in the result set.+withRecursiveDistinct :: Default Binaryspec a a => Select a -> (a -> Select a) -> Select a+withRecursiveDistinct = withRecursiveDistinctExplicit def++withExplicit :: Unpackspec a a -> Select a -> (Select a -> Select b) -> Select b+withExplicit unpackspec rhsSelect bodySelect = productQueryArr $ do+ withG unpackspec PQ.NonRecursive Nothing (\_ -> rebind rhsSelect) bodySelect+ where+ rebind = (>>> rebindExplicitPrefixNoStar "rebind" unpackspec)++withMaterializedExplicit :: Unpackspec a a -> Select a -> (Select a -> Select b) -> Select b+withMaterializedExplicit unpackspec rhsSelect bodySelect = productQueryArr $ do+ withG unpackspec PQ.NonRecursive (Just PQ.Materialized) (\_ -> rebind rhsSelect) bodySelect+ where+ rebind = (>>> rebindExplicitPrefixNoStar "rebind" unpackspec)++withRecursiveExplicit :: Binaryspec a a -> Select a -> (a -> Select a) -> Select a+withRecursiveExplicit binaryspec base recursive = productQueryArr $ do+ let bodySelect selectCte = selectCte+ let rhsSelect selectCte = unionAllExplicit binaryspec base (selectCte >>= recursive)++ withG unpackspec PQ.Recursive Nothing rhsSelect bodySelect+ where+ unpackspec = binaryspecToUnpackspec binaryspec++withRecursiveDistinctExplicit :: Binaryspec a a -> Select a -> (a -> Select a) -> Select a+withRecursiveDistinctExplicit binaryspec base recursive = productQueryArr $ do+ let bodySelect selectCte = selectCte+ let rhsSelect selectCte = unionExplicit binaryspec base (selectCte >>= recursive)++ withG unpackspec PQ.Recursive Nothing rhsSelect bodySelect+ where+ unpackspec = binaryspecToUnpackspec binaryspec++withG ::+ Unpackspec a a ->+ PQ.Recursive ->+ Maybe PQ.Materialized ->+ (Select a -> Select a) ->+ (Select a -> Select b) ->+ State Tag.Tag (b, PQ.PrimQuery)+withG unpackspec recursive materialized rhsSelect bodySelect = do+ (selectCte, withCte) <- freshCte unpackspec++ let rhsSelect' = rhsSelect selectCte+ let bodySelect' = bodySelect selectCte++ (_, rhsQ) <- runSimpleSelect rhsSelect'+ bodyQ <- runSimpleSelect bodySelect'++ pure (withCte recursive materialized rhsQ bodyQ)++freshCte ::+ Unpackspec a a ->+ State+ Tag.Tag+ ( Select a,+ PQ.Recursive -> Maybe PQ.Materialized -> PQ.PrimQuery -> (b, PQ.PrimQuery) -> (b, PQ.PrimQuery)+ )+freshCte unpackspec = do+ cteName <- HPQ.Symbol "cte" <$> Tag.fresh++ -- TODO: Make a function that explicitly ignores its argument+ (cteColumns, cteBindings) <- do+ startTag <- Tag.fresh+ pure $+ PM.run $+ runUnpackspec unpackspec (PM.extractAttr "cte" startTag) (error "freshCte")++ let selectCte = productQueryArr $ do+ tag <- Tag.fresh+ let (renamedCte, renameCte) =+ PM.run $+ runUnpackspec unpackspec (PM.extractAttr "cte_renamed" tag) cteColumns++ pure (renamedCte, PQ.BaseTable (PQ.TableIdentifier Nothing (Sql.sqlSymbol cteName)) renameCte)++ pure+ ( selectCte,+ \recursive materialized withQ (withedCols, withedQ) ->+ (withedCols, PQ.With recursive materialized cteName (map fst cteBindings) withQ withedQ)+ )++binaryspecToUnpackspec :: Binaryspec a a -> Unpackspec a a+binaryspecToUnpackspec (Binaryspec (PackMap spec)) =+ Unpackspec $ PackMap $ \f a -> spec (\(pe, _) -> f pe) (a, a)