opaleye 0.9.3.3 → 0.10.8.0
raw patch · 68 files changed
Files
- CHANGELOG.md +135/−3
- Doc/Tutorial/DefaultExplanation.lhs +1/−1
- Doc/Tutorial/TutorialBasic.lhs +24/−27
- Doc/Tutorial/TutorialBasicMonomorphic.lhs +19/−36
- LICENSE +1/−1
- README.md +2/−2
- Test/Opaleye/Test/Arbitrary.hs +4/−5
- Test/Opaleye/Test/Fields.hs +0/−1
- Test/QuickCheck.hs +4/−5
- Test/Test.hs +167/−22
- opaleye.cabal +15/−13
- src/Opaleye/Adaptors.hs +0/−1
- src/Opaleye/Aggregate.hs +51/−20
- src/Opaleye/Binary.hs +1/−3
- src/Opaleye/Column.hs +3/−5
- src/Opaleye/Distinct.hs +4/−4
- src/Opaleye/Experimental/Enum.hs +13/−14
- src/Opaleye/Field.hs +38/−8
- src/Opaleye/FunctionalJoin.hs +2/−89
- src/Opaleye/Inferrable.hs +9/−0
- src/Opaleye/Internal/Aggregate.hs +89/−29
- src/Opaleye/Internal/Binary.hs +1/−5
- src/Opaleye/Internal/Column.hs +1/−2
- src/Opaleye/Internal/Constant.hs +4/−5
- src/Opaleye/Internal/Distinct.hs +5/−8
- src/Opaleye/Internal/HaskellDB/PrimQuery.hs +25/−5
- src/Opaleye/Internal/HaskellDB/Sql.hs +6/−3
- src/Opaleye/Internal/HaskellDB/Sql/Default.hs +39/−33
- src/Opaleye/Internal/HaskellDB/Sql/Print.hs +16/−5
- src/Opaleye/Internal/Inferrable.hs +53/−46
- src/Opaleye/Internal/JSONBuildObjectFields.hs +0/−1
- src/Opaleye/Internal/Join.hs +0/−1
- src/Opaleye/Internal/Lateral.hs +0/−2
- src/Opaleye/Internal/Manipulation.hs +3/−3
- src/Opaleye/Internal/MaybeFields.hs +9/−3
- src/Opaleye/Internal/Operators.hs +27/−42
- src/Opaleye/Internal/Optimize.hs +2/−3
- src/Opaleye/Internal/Order.hs +4/−3
- src/Opaleye/Internal/PGTypes.hs +19/−0
- src/Opaleye/Internal/PGTypesExternal.hs +8/−2
- src/Opaleye/Internal/PackMap.hs +21/−4
- src/Opaleye/Internal/PrimQuery.hs +18/−16
- src/Opaleye/Internal/Print.hs +43/−20
- src/Opaleye/Internal/QueryArr.hs +0/−2
- src/Opaleye/Internal/Rebind.hs +7/−2
- src/Opaleye/Internal/RunQuery.hs +11/−17
- src/Opaleye/Internal/RunQueryExternal.hs +1/−6
- src/Opaleye/Internal/Sql.hs +48/−36
- src/Opaleye/Internal/Table.hs +20/−19
- src/Opaleye/Internal/TableMaker.hs +0/−69
- src/Opaleye/Internal/Unpackspec.hs +2/−5
- src/Opaleye/Internal/Values.hs +3/−47
- src/Opaleye/Internal/Window.hs +131/−69
- src/Opaleye/Join.hs +21/−11
- src/Opaleye/Label.hs +1/−1
- src/Opaleye/Manipulation.hs +10/−12
- src/Opaleye/MaybeFields.hs +2/−3
- src/Opaleye/Operators.hs +65/−17
- src/Opaleye/Order.hs +33/−13
- src/Opaleye/RunSelect.hs +22/−23
- src/Opaleye/Select.hs +1/−1
- src/Opaleye/Sql.hs +2/−2
- src/Opaleye/SqlTypes.hs +8/−2
- src/Opaleye/Table.hs +4/−7
- src/Opaleye/ToFields.hs +1/−3
- src/Opaleye/Values.hs +1/−37
- src/Opaleye/Window.hs +58/−37
- src/Opaleye/With.hs +61/−11
CHANGELOG.md view
@@ -1,3 +1,135 @@+## 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@@ -103,7 +235,7 @@ ## 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 @@ -266,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 @@ -454,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-2022 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@@ -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
@@ -16,7 +16,7 @@ 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)@@ -302,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) ]@@ -471,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)@@ -481,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
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,15 +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@@ -24,14 +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, FieldNullable, Select, SelectArr, (.==), (.>)) import qualified Opaleye as O-import qualified Opaleye.Field as F+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@@ -48,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. @@ -508,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@@ -611,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. @@ -644,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]@@ -699,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@@ -765,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@@ -837,6 +895,18 @@ 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@@ -1064,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)@@ -1415,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"@@ -1493,8 +1625,11 @@ testOverwriteAggregateOrdered testMultipleAggregateOrdered testStringArrayAggregateOrdered+ testStringArrayAggregateOrderedDistinct+ testStringArrayAggregateOrderedDistinctDuplicateFields testDistinctAndAggregate testDoubleAggregate+ testSetAggregate describe "distinct" $ do testDistinct describe "distinct on"@@ -1512,6 +1647,11 @@ testOffset testLimitOffset testOffsetLimit+ describe "limit field" $ do+ testLimitField+ testOffsetField+ testLimitFieldOffset+ testOffsetFieldLimit describe "double" $ do testDoubleDistinct testDoubleLeftJoin@@ -1527,11 +1667,11 @@ testArrayAppend testArrayPosition testSqlElem+ testSqlElemAny describe "joins" $ do testLeftJoin testLeftJoinNullable testThreeWayProduct- testLeftJoinF describe "json" $ jsonTests table8Q describe "jsonb" $ do jsonTests table9Q@@ -1553,6 +1693,7 @@ testUpdate testDeleteReturning testInsertConflict+ testSelectCaseNull describe "range" $ do testRangeOverlap testRangeDateOverlap@@ -1580,3 +1721,7 @@ 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-2022 Tom Ellis-version: 0.9.3.3+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@@ -16,7 +16,7 @@ extra-doc-files: README.md CHANGELOG.md *.md-tested-with: GHC==9.2, 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@@ -24,25 +24,28 @@ library default-language: Haskell2010+ default-extensions: MultiParamTypeClasses,+ FlexibleContexts,+ FlexibleInstances hs-source-dirs: src build-depends:- aeson >= 0.6 && < 2.2- , base >= 4.9 && < 4.17+ 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.12+ , 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.11.0.3 && < 0.12 , profunctors >= 4.0 && < 5.7 , scientific >= 0.3 && < 0.4 , semigroups >= 0.13 && < 0.21- , text >= 0.11 && < 1.3- , transformers >= 0.3 && < 0.6+ , 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,@@ -54,6 +57,7 @@ Opaleye.Exists, Opaleye.Field, Opaleye.FunctionalJoin,+ Opaleye.Inferrable, Opaleye.Join, Opaleye.Label, Opaleye.Lateral,@@ -99,7 +103,6 @@ Opaleye.Internal.RunQueryExternal, Opaleye.Internal.Sql, Opaleye.Internal.Table,- Opaleye.Internal.TableMaker, Opaleye.Internal.Tag, Opaleye.Internal.TypeFamilies, Opaleye.Internal.Unpackspec,@@ -137,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/Adaptors.hs view
@@ -63,7 +63,6 @@ Updater, -- * Valuesspec Valuesspec,- ValuesspecSafe, valuesspecField, valuesspecMaybeFields, -- * WithNulls
src/Opaleye/Aggregate.hs view
@@ -1,4 +1,5 @@ {-# 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@@ -13,10 +14,12 @@ aggregate , aggregateOrdered , distinctAggregator+ , filterWhere , Aggregator -- * Basic 'Aggregator's , groupBy , Opaleye.Aggregate.sum+ , sumInt2 , sumInt4 , sumInt8 , count@@ -27,23 +30,30 @@ , 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.Field as F import qualified Opaleye.Order as Ord@@ -81,11 +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 $ do- (a, pq) <- Q.runSimpleSelect q- t <- Tag.fresh- pure (A.aggregateU agg (a, pq, t))+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@@ -96,14 +103,33 @@ -- 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 (F.Field_ n a) (F.Field_ n a) groupBy = A.makeAggr' Nothing@@ -114,8 +140,11 @@ -- runtime when the argument is 'T.SqlInt4' or 'T.SqlInt8'. For those -- use 'sumInt4' or 'sumInt8' instead. sum :: Aggregator (F.Field a) (F.Field a)-sum = A.makeAggr HPQ.AggrSum+sum = A.unsafeSum +sumInt2 :: Aggregator (F.Field T.SqlInt2) (F.Field T.SqlInt8)+sumInt2 = fmap F.unsafeCoerceField Opaleye.Aggregate.sum+ sumInt4 :: Aggregator (F.Field T.SqlInt4) (F.Field T.SqlInt8) sumInt4 = fmap F.unsafeCoerceField Opaleye.Aggregate.sum @@ -133,15 +162,15 @@ -- | Average of a group avg :: Aggregator (F.Field T.SqlFloat8) (F.Field T.SqlFloat8)-avg = A.makeAggr HPQ.AggrAvg+avg = A.unsafeAvg -- | Maximum of a group max :: Ord.SqlOrd a => Aggregator (F.Field a) (F.Field a)-max = A.makeAggr HPQ.AggrMax+max = A.unsafeMax -- | Maximum of a group min :: Ord.SqlOrd a => Aggregator (F.Field a) (F.Field a)-min = A.makeAggr HPQ.AggrMin+min = A.unsafeMin boolOr :: Aggregator (F.Field T.SqlBool) (F.Field T.SqlBool) boolOr = A.makeAggr HPQ.AggrBoolOr@@ -150,14 +179,13 @@ boolAnd = A.makeAggr HPQ.AggrBoolAnd arrayAgg :: Aggregator (F.Field a) (F.Field (T.SqlArray a))-arrayAgg = A.makeAggr HPQ.AggrArr--{-|-FIXME: no longer supports nulls+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@@ -179,7 +207,10 @@ stringAgg :: F.Field T.SqlText -> Aggregator (F.Field T.SqlText) (F.Field T.SqlText)-stringAgg = A.makeAggr' . Just . HPQ.AggrStringAggr . IC.unColumn+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
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))@@ -31,8 +31,6 @@ -- `unionAll` is very close to being the @\<|\>@ operator of a -- @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,
src/Opaleye/Column.hs view
@@ -1,13 +1,11 @@ {-# OPTIONS_GHC -fno-warn-duplicate-exports #-}--- | Do not use. Will be deprecated in version 0.10. 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. -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,
src/Opaleye/Distinct.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE FlexibleContexts #-}- module Opaleye.Distinct (distinct, distinctOn, distinctOnBy,@@ -20,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'. --@@ -29,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))@@ -42,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/Experimental/Enum.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE RankNTypes #-} module Opaleye.Experimental.Enum (@@ -8,20 +8,22 @@ enumMapperWithSchema, enumFromField, enumToFields,- fromFieldToFieldsEnum,+ enumShowSqlType, ) where import Opaleye.Field (Field) import qualified Opaleye as O+import qualified Opaleye.Internal.PGTypes as IPT import qualified Opaleye.Internal.RunQuery as RQ import Data.ByteString.Char8 (unpack)-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 (Field sqlEnum)+ , enumShowSqlType :: forall proxy. proxy sqlEnum -> String } -- | Create a mapping between a Postgres @ENUM@ type and a Haskell@@ -81,10 +83,13 @@ -- -- instance rating ~ Rating -- => D.Default (Inferrable O.FromField) SqlRating rating where--- def = Inferrable D.def+-- def = inferrableDef -- -- 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@@ -114,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@@ -131,6 +138,7 @@ enumMapper' type_ from to_ = EnumMapper { enumFromField = fromFieldEnum , enumToFields = toFieldsEnum+ , enumShowSqlType = \_ -> type_ } where toFieldsEnum = O.toToFields (O.unsafeCast type_ . O.sqlString . to_)@@ -139,12 +147,3 @@ Just s -> case from (unpack s) of Just r -> r Nothing -> error ("Unexpected: " ++ unpack s)--{-# DEPRECATED fromFieldToFieldsEnum "Use 'enumMapper' instead. Will be removed in 0.10." #-}-fromFieldToFieldsEnum :: String- -> (String -> Maybe haskellSum)- -> (haskellSum -> String)- -> (RQ.FromField sqlEnum haskellSum,- O.ToFields haskellSum (Field 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.10.+-- 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,@@ -41,12 +51,32 @@ import qualified Opaleye.Internal.PGTypesExternal as T import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ +import Data.Proxy (Proxy(Proxy))+ -- FIXME Put Nullspec (or sqltype?) constraint on this --- | A NULL of any type+-- | A @NULL@ of any type. This will change to become 'typedNull' in+-- a future version. null :: FieldNullable a null = Column (HPQ.ConstExpr HPQ.NullLit) +-- | 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)++-- | 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.unOp HPQ.OpIsNull@@ -61,7 +91,7 @@ -> (Field a -> Field b) -- ^ -> FieldNullable a- -- ^+ -- ^ ͘ -> Field b matchNullable replacement f x = C.unsafeIfThenElse (isNull x) replacement (f (unsafeCoerceField x))@@ -75,7 +105,7 @@ fromNullable :: Field a -- ^ -> FieldNullable a- -- ^+ -- ^ ͘ -> Field a fromNullable = flip matchNullable id
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,83 +19,6 @@ import qualified Opaleye.Select as S import qualified Opaleye.SqlTypes as T import qualified Opaleye.Operators as O--{-# DEPRECATED joinF "Use 'Opaleye.Operators.where_' and @do@ notation instead. Will be removed in 0.10." #-}-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))--{-# DEPRECATED leftJoinF "Use 'Opaleye.Join.optional' instead. Will be removed in 0.10." #-}-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--{-# DEPRECATED rightJoinF "Use 'Opaleye.Join.optional' instead. Will be removed in 0.10." #-}-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,18 +33,28 @@ 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.Field_ n a) (C.Field_ n' b)-makeAggr' mAggrOp = Aggregator (PM.PackMap- (\f (C.Column e) -> fmap C.Column (f (fmap (, [], HPQ.AggrAll) mAggrOp, e))))+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.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@@ -78,13 +93,18 @@ 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 @@ -109,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)-aggregateU agg (c0, primQ, t0) = (c1, primQ')- 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,7 +1,5 @@ {-# OPTIONS_HADDOCK not-home #-} -{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-}- module Opaleye.Internal.Binary where import Opaleye.Internal.Column (Field_(Column), unColumn)@@ -17,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)@@ -35,8 +32,7 @@ runBinaryspec (Binaryspec b) = PM.traversePM b binaryspecColumn :: Binaryspec (Field_ n a) (Field_ n a)-binaryspecColumn = Binaryspec (PM.iso (mapBoth unColumn) Column)- where mapBoth f (s, t) = (f s, f t)+binaryspecColumn = dimap unColumn Column (Binaryspec (PM.PackMap id)) sameTypeBinOpHelper :: PQ.BinOp -> Binaryspec columns columns' -> Q.Query columns -> Q.Query columns -> Q.Query columns'
src/Opaleye/Internal/Column.hs view
@@ -3,7 +3,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-} module Opaleye.Internal.Column where @@ -22,7 +21,7 @@ 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_
src/Opaleye/Internal/Constant.hs view
@@ -1,6 +1,5 @@ {-# OPTIONS_HADDOCK not-home #-} -{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} {-# LANGUAGE DataKinds #-} module Opaleye.Internal.Constant where@@ -18,16 +17,13 @@ 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 ) @@ -77,6 +73,9 @@ instance D.Default ToFields Sci.Scientific (Field T.SqlNumeric) where def = toToFields T.sqlNumeric++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
src/Opaleye/Internal/Distinct.hs view
@@ -1,28 +1,25 @@ {-# OPTIONS_HADDOCK not-home #-} -{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}- module Opaleye.Internal.Distinct where import qualified Opaleye.Internal.MaybeFields as M import Opaleye.Select (Select) import Opaleye.Field (Field_)-import Opaleye.Aggregate (Aggregator, groupBy, aggregate)--import Control.Applicative (Applicative, pure, (<*>))+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)
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,9 @@ | 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@@ -80,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) @@ -115,7 +135,7 @@ | WndwFirstValue PrimExpr | WndwLastValue PrimExpr | WndwNthValue PrimExpr PrimExpr- | WndwAggregate AggrOp PrimExpr+ | WndwAggregate AggrOp [PrimExpr] deriving (Show,Read) data Partition = Partition
src/Opaleye/Internal/HaskellDB/Sql.hs view
@@ -33,8 +33,8 @@ data SqlPartition = SqlPartition- { sqlPartitionBy :: [SqlExpr]- , sqlOrderBy :: [(SqlExpr, SqlOrder)]+ { sqlPartitionBy :: Maybe (NEL.NonEmpty SqlExpr)+ , sqlOrderBy :: Maybe (NEL.NonEmpty (SqlExpr, SqlOrder)) } deriving Show @@ -48,11 +48,12 @@ 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@@ -72,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@@ -52,8 +52,8 @@ toSqlPartition :: SqlGenerator -> Partition -> SqlPartition toSqlPartition gen (Partition partition order) = SqlPartition- { sqlPartitionBy = map (sqlExpr gen) partition- , sqlOrderBy = map (toSqlOrder gen) order+ { sqlPartitionBy = NEL.nonEmpty (map (sqlExpr gen) partition)+ , sqlOrderBy = NEL.nonEmpty (map (toSqlOrder gen) order) } @@ -124,24 +124,26 @@ (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', e') = showAggrOp gen op e- ord' = toSqlOrder gen <$> ord- distinct' = case distinct of- AggrDistinct -> SqlDistinct- AggrAll -> SqlNotDistinct- in AggrFunSqlExpr op' e' 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'@@ -220,23 +222,27 @@ sqlUnOp (UnOpOther s) = (s, UnOpFun) -showAggrOp :: SqlGenerator -> AggrOp -> PrimExpr -> (String, [SqlExpr])-showAggrOp gen op arg = case op of- AggrCount -> ("COUNT", [sqlExpr gen arg])- AggrSum -> ("SUM", [sqlExpr gen arg])- AggrAvg -> ("AVG", [sqlExpr gen arg])- AggrMin -> ("MIN", [sqlExpr gen arg])- AggrMax -> ("MAX", [sqlExpr gen arg])- AggrStdDev -> ("StdDev", [sqlExpr gen arg])- AggrStdDevP -> ("StdDevP", [sqlExpr gen arg])- AggrVar -> ("Var", [sqlExpr gen arg])- AggrVarP -> ("VarP", [sqlExpr gen arg])- AggrBoolAnd -> ("BOOL_AND", [sqlExpr gen arg])- AggrBoolOr -> ("BOOL_OR", [sqlExpr gen arg])- AggrArr -> ("ARRAY_AGG", [sqlExpr gen arg])- JsonArr -> ("JSON_AGG", [sqlExpr gen arg])- AggrStringAggr sep -> ("STRING_AGG", [sqlExpr gen arg, sqlExpr gen sep])- AggrOther s -> (s, [sqlExpr gen arg])+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])
src/Opaleye/Internal/HaskellDB/Sql/Print.hs view
@@ -61,11 +61,12 @@ ppSqlPartition :: SqlPartition -> Doc ppSqlPartition partition = ppPartitionBy (sqlPartitionBy partition) <+>- ppOrderBy (sqlOrderBy partition)+ ppOrderBy (maybe [] NEL.toList (sqlOrderBy partition)) -ppPartitionBy :: [SqlExpr] -> Doc-ppPartitionBy [] = empty-ppPartitionBy es = text "PARTITION BY" <+> ppPartitionAttrs es+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)@@ -180,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)@@ -191,7 +193,16 @@ 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"
src/Opaleye/Internal/Inferrable.hs view
@@ -1,8 +1,6 @@ {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE DataKinds #-} module Opaleye.Internal.Inferrable where@@ -24,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@@ -45,19 +43,28 @@ => 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@@ -68,25 +75,25 @@ 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@@ -95,23 +102,23 @@ --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 @@ -151,107 +158,107 @@ instance F.Field a ~ fieldA => D.Default (Inferrable ToFields) (F.Field a) fieldA where- def = Inferrable D.def+ def = inferrableDef instance F.Field T.SqlText ~ cSqlText => D.Default (Inferrable ToFields) String cSqlText where- def = Inferrable D.def+ def = inferrableDef instance F.Field T.SqlBytea ~ cSqlBytea => D.Default (Inferrable ToFields) LBS.ByteString cSqlBytea where- def = Inferrable D.def+ def = inferrableDef instance F.Field T.SqlBytea ~ cSqlBytea => D.Default (Inferrable ToFields) SBS.ByteString cSqlBytea where- def = Inferrable D.def+ def = inferrableDef instance F.Field T.SqlText ~ cSqlText => D.Default (Inferrable ToFields) ST.Text cSqlText where- def = Inferrable D.def+ def = inferrableDef instance F.Field T.SqlText ~ cSqlText => D.Default (Inferrable ToFields) LT.Text cSqlText where- def = Inferrable D.def+ def = inferrableDef instance F.Field T.SqlNumeric ~ cSqlNumeric => D.Default (Inferrable ToFields) Sci.Scientific cSqlNumeric where- def = Inferrable D.def+ def = inferrableDef instance F.Field T.SqlInt4 ~ cSqlInt4 => D.Default (Inferrable ToFields) Int cSqlInt4 where- def = Inferrable D.def+ def = inferrableDef instance F.Field T.SqlInt4 ~ cSqlInt4 => D.Default (Inferrable ToFields) Int32 cSqlInt4 where- def = Inferrable D.def+ def = inferrableDef instance F.Field T.SqlInt8 ~ cSqlInt8 => D.Default (Inferrable ToFields) Int64 cSqlInt8 where- def = Inferrable D.def+ def = inferrableDef instance F.Field T.SqlFloat8 ~ cSqlFloat8 => D.Default (Inferrable ToFields) Double cSqlFloat8 where- def = Inferrable D.def+ def = inferrableDef instance F.Field T.SqlBool ~ cSqlBool => D.Default (Inferrable ToFields) Bool cSqlBool where- def = Inferrable D.def+ def = inferrableDef instance F.Field T.SqlUuid ~ cSqlUuid => D.Default (Inferrable ToFields) UUID cSqlUuid where- def = Inferrable D.def+ def = inferrableDef instance F.Field T.SqlDate ~ cSqlDate => D.Default (Inferrable ToFields) Time.Day cSqlDate where- def = Inferrable D.def+ def = inferrableDef instance F.Field T.SqlTimestamptz ~ cSqlTimestamptz => D.Default (Inferrable ToFields) Time.UTCTime cSqlTimestamptz where- def = Inferrable D.def+ def = inferrableDef instance F.Field T.SqlTimestamptz ~ cSqlTimestamptz => D.Default (Inferrable ToFields) Time.ZonedTime cSqlTimestamptz where- def = Inferrable D.def+ def = inferrableDef instance F.Field T.SqlTime ~ cSqlTime => D.Default (Inferrable ToFields) Time.TimeOfDay cSqlTime where- def = Inferrable D.def+ def = inferrableDef instance F.Field T.SqlInterval ~ cSqlInterval => D.Default (Inferrable ToFields) Time.CalendarDiffTime cSqlInterval where- def = Inferrable D.def+ def = inferrableDef instance F.Field T.SqlCitext ~ cSqlCitext => D.Default (Inferrable ToFields) (CI.CI ST.Text) cSqlCitext where- def = Inferrable D.def+ def = inferrableDef instance F.Field T.SqlCitext ~ cSqlCitext => D.Default (Inferrable ToFields) (CI.CI LT.Text) cSqlCitext where- def = Inferrable D.def+ def = inferrableDef instance F.Field (T.SqlRange T.SqlInt4) ~ cRangeInt4 => D.Default (Inferrable ToFields) (R.PGRange Int) cRangeInt4 where- def = Inferrable D.def+ def = inferrableDef instance F.Field (T.SqlRange T.SqlInt8) ~ cRangeInt8 => D.Default (Inferrable ToFields) (R.PGRange Int64) cRangeInt8 where- def = Inferrable D.def+ def = inferrableDef 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 F.Field (T.SqlRange T.SqlTimestamp) ~ cRangeTimestamp => D.Default (Inferrable ToFields) (R.PGRange Time.LocalTime) cRangeTimestamp where- def = Inferrable D.def+ def = inferrableDef 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 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
@@ -9,7 +9,6 @@ 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
src/Opaleye/Internal/Join.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Arrows #-}
src/Opaleye/Internal/Lateral.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE FlexibleContexts #-}- module Opaleye.Internal.Lateral ( lateral , viaLateral
src/Opaleye/Internal/Manipulation.hs view
@@ -1,7 +1,4 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-} module Opaleye.Internal.Manipulation where @@ -127,6 +124,9 @@ 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
src/Opaleye/Internal/MaybeFields.hs view
@@ -1,12 +1,10 @@ {-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Arrows #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Opaleye.Internal.MaybeFields where@@ -141,6 +139,14 @@ returnA -< MaybeFields (mfPresent mfInput) (mfFields mfOutput) 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))
src/Opaleye/Internal/Operators.hs view
@@ -1,26 +1,25 @@ {-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} module Opaleye.Internal.Operators where +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 @@ -77,43 +76,32 @@ 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 (Field_ n a)-relExprColumn = RelExprMaker TM.tableColumn U.unpackspecField -instance D.Default RelExprMaker String (Field_ n 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 =+relationValuedExprExplicit relExprPP pe = QA.productQueryArr' $ do- tag <- Tag.fresh- pure $ \a ->- let (primExprs, projcols) = runRelExprMaker rem_ tag strings- primQ :: PQ.PrimQuery- primQ = PQ.RelExpr (pe a) projcols- in (primExprs, primQ)+ (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 @@ -127,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,9 +8,8 @@ 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@@ -73,7 +72,7 @@ , PQ.relExpr = return .: PQ.RelExpr , PQ.rebind = \b -> fmap . PQ.Rebind b , PQ.forUpdate = fmap PQ.ForUpdate- , PQ.with = \recursive name cols -> liftA2 (PQ.With recursive name cols)+ , 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
@@ -60,10 +60,10 @@ orderExprs :: a -> Order a -> [HPQ.OrderExpr] orderExprs x (Order os) = map (uncurry HPQ.OrderExpr) (os x) -limit' :: Int -> (a, PQ.PrimQuery) -> (a, PQ.PrimQuery)+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) -> (a, PQ.PrimQuery)+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)@@ -75,8 +75,9 @@ 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 1) (PQ.DistinctOnOrderBy Nothing 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 fields. Note that this list does not have to contain an entry for
src/Opaleye/Internal/PGTypes.hs view
@@ -15,6 +15,8 @@ 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 -> Field c unsafePgFormatTime typeName = castToType typeName . format@@ -34,6 +36,23 @@ 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
src/Opaleye/Internal/PGTypesExternal.hs view
@@ -24,15 +24,18 @@ import qualified Data.ByteString.Lazy as LByteString import 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 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 @@ -87,6 +90,9 @@ pgNumeric :: Sci.Scientific -> Field PGNumeric pgNumeric = IPT.literalColumn . HPQ.NumericLit++pgInt2 :: Int16 -> Field PGInt2+pgInt2 = IPT.literalColumn . HPQ.IntegerLit . fromIntegral pgInt4 :: Int -> Field PGInt4 pgInt4 = IPT.literalColumn . HPQ.IntegerLit . fromIntegral
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
@@ -5,12 +5,13 @@ 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@@ -50,6 +51,9 @@ 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')@@ -63,6 +67,9 @@ 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 @@ -114,7 +121,7 @@ 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'@@ -128,10 +135,7 @@ | 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@@@ -154,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)@@ -163,7 +167,7 @@ -- ForUpdate in the future -- -- https://www.postgresql.org/docs/current/sql-select.html#SQL-FOR-UPDATE-SHARE- | With Recursive Symbol [Symbol] (PrimQuery' a) (PrimQuery' a)+ | With Recursive (Maybe Materialized) Symbol [Symbol] (PrimQuery' a) (PrimQuery' a) deriving Show type PrimQuery = PrimQuery' ()@@ -176,9 +180,7 @@ , 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)+ , aggregate :: Bindings HPQ.Aggregate -> p -> p' , window :: Bindings (HPQ.WndwOp, HPQ.Partition) -> p -> p'@@ -199,11 +201,11 @@ -> (p, p) -> p' , label :: String -> p -> p'- , relExpr :: HPQ.PrimExpr -> Bindings HPQ.PrimExpr -> p'+ , relExpr :: HPQ.PrimExpr -> [Symbol] -> p' -- ^ A relation-valued expression , rebind :: Bool -> Bindings HPQ.PrimExpr -> p -> p' , forUpdate :: p -> p'- , with :: Recursive -> Symbol -> [Symbol] -> p -> p -> p'+ , with :: Recursive -> Maybe Materialized -> Symbol -> [Symbol] -> p -> p -> p' } @@ -251,7 +253,7 @@ , 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 s ss p1 p2 -> g (with f r s ss (self p1) (self p2))+ , with = \r m s ss p1 p2 -> g (with f r m s ss (self p1) (self p2)) } applyPrimQueryFoldF ::@@ -274,7 +276,7 @@ Exists s q -> exists f s q Rebind star pes q -> rebind f star pes q ForUpdate q -> forUpdate f q- With recursive name cols a b -> with f recursive name cols a b+ 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'
src/Opaleye/Internal/Print.hs view
@@ -26,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@@ -66,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"@@ -108,18 +118,25 @@ 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@@ -140,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@@ -167,27 +186,31 @@ SelectLabel sll -> parens (ppSelectLabel sll) SelectExists saj -> parens (ppSelectExists saj) SelectWith w -> parens (ppWith w)- `ppAs`- Just alias+ <+> 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
@@ -18,11 +18,9 @@ import Control.Arrow ((&&&), (***), arr, returnA) import qualified Control.Category as C import Control.Category ((<<<), id)-import Control.Applicative (Applicative, pure, (<*>)) import Control.Monad.Trans.State.Strict (State, evalState, runState, state) import qualified Data.Profunctor as P import qualified Data.Profunctor.Product as PP-import Data.Semigroup ((<>)) -- | A parametrised 'Select'. A @SelectArr a b@ accepts an argument -- of type @a@.
src/Opaleye/Internal/Rebind.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE FlexibleContexts #-}- module Opaleye.Internal.Rebind where import Data.Profunctor.Product.Default (Default, def)@@ -21,3 +19,10 @@ 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,13 +1,12 @@ {-# OPTIONS_HADDOCK not-home #-} -{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} {-# 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)@@ -45,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 @@ -85,7 +84,7 @@ -- | 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@@ -111,17 +110,9 @@ -- SqlInt4)' has no columns when it is Nothing and one -- column when it is Just. -{-# DEPRECATED fieldQueryRunnerColumn "Will be removed in version 0.10. Use fromPGSFromField instead." #-}-fieldQueryRunnerColumn :: PGS.FromField haskell => FromField pgType haskell-fieldQueryRunnerColumn = fromPGSFromField- fromPGSFromField :: PGS.FromField haskell => FromField pgType haskell fromPGSFromField = fromPGSFieldParser fromField -{-# DEPRECATED fieldParserQueryRunnerColumn " Will be removed in version 0.10. Use fromPGSFieldParser instead." #-}-fieldParserQueryRunnerColumn :: FieldParser haskell -> FromField pgType haskell-fieldParserQueryRunnerColumn = fromPGSFieldParser- fromPGSFieldParser :: FieldParser haskell -> FromField pgType haskell fromPGSFieldParser = FromField @@ -131,10 +122,6 @@ fieldParserFromFields :: FieldParser haskells -> FromFields (Field_ n a) haskells fieldParserFromFields fp = FromFields (P.rmap (const ()) U.unpackspecField) (const (fieldWith fp)) (const 1) -{-# DEPRECATED queryRunner "Use fromFields instead. Will be removed in version 0.10." #-}-queryRunner :: FromField a b -> FromFields (Field a) b-queryRunner = fromFields- fromFieldsNullable :: FromField a b -> FromFields (FieldNullable a) (Maybe b) fromFieldsNullable (FromField fp) = fieldParserFromFields (optionalField fp) @@ -193,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 @@ -320,6 +310,10 @@ instance (Typeable b, DefaultFromField a b) => 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
src/Opaleye/Internal/RunQueryExternal.hs view
@@ -1,18 +1,13 @@ {-# OPTIONS_HADDOCK not-home #-} -{-# LANGUAGE FlexibleContexts #-}- module Opaleye.Internal.RunQueryExternal (module Opaleye.Internal.RunQueryExternal, -- * Datatypes IRQ.Cursor, IRQ.FromFields, IRQ.FromField,- -- * Creating new 'FromField'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
src/Opaleye/Internal/Sql.hs view
@@ -3,7 +3,7 @@ module Opaleye.Internal.Sql where -import Prelude hiding (product)+import Prelude hiding (filter, product) import qualified Opaleye.Internal.PrimQuery as PQ @@ -42,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@@ -83,12 +83,14 @@ 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,- wWith :: Select,- wSelect :: Select+ 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 @@ -142,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 $@@ -154,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@@ -190,21 +190,21 @@ handleEmpty :: [HSql.SqlExpr] -> NEL.NonEmpty HSql.SqlExpr 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@@ -231,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@@ -268,15 +268,25 @@ bSelect2 = select2 } -with :: PQ.Recursive -> Symbol -> [Symbol]-> Select -> Select -> Select-with recursive name cols wWith wSelect = SelectWith $ With {..}+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@@ -332,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@@ -349,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,5 +1,3 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE Rank2Types #-} @@ -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,7 +31,7 @@ -- , 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))@@ -91,22 +87,24 @@ Writer (forall f. Functor f => PM.PackMap (f HPQ.PrimExpr, String) () (f columns) ()) --- | 'requiredTableField' is for fields which are not optional. You+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 columnName = TableFields- (requiredW columnName)- (View (Column (HPQ.BaseTableAttrExpr columnName)))-+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@ 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))) --- | Don't use 'readOnlyTableField'. It will be formally deprecated+-- | 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@@ -114,6 +112,13 @@ readOnlyTableField :: String -> TableFields () (Field_ n a) readOnlyTableField = lmap (const Nothing) . optionalTableField +-- | @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)))+ -- | You should not define your own instances of -- 'InferrableTableField'. class InferrableTableField w n r@@ -131,7 +136,7 @@ instance InferrableTableField (Field_ n r) n r where tableField = requiredTableField --- | Equivalaent to defining the column with 'optionalTableField'. If+-- | 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@@ -187,10 +192,6 @@ mempty = Zip mempty' where mempty' = [] `NEL.cons` mempty' mappend = (<>)--requiredW :: String -> Writer (Field_ n a) (Field_ n a)-requiredW columnName =- Writer (PM.iso (flip (,) columnName . fmap unColumn) id) optionalW :: String -> Writer (Maybe (Field_ n a)) (Field_ n a) optionalW columnName =
− src/Opaleye/Internal/TableMaker.hs
@@ -1,69 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}--module Opaleye.Internal.TableMaker where--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 (IC.Field_ n a)-tableColumn = ViewColumnMaker- (PM.PackMap (\f s -> fmap (const (mkColumn s)) (f ())))- where mkColumn = IC.Column . HPQ.BaseTableAttrExpr--instance Default ViewColumnMaker String (IC.Field_ n a) where- def = tableColumn--{-# DEPRECATED column "Use unpackspecColumn instead" #-}-column :: ColumnMaker (IC.Field_ n a) (IC.Field_ n 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/Unpackspec.hs view
@@ -1,14 +1,11 @@ {-# OPTIONS_HADDOCK not-home #-} -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}- module Opaleye.Internal.Unpackspec where import qualified Opaleye.Internal.PackMap as PM import qualified Opaleye.Internal.Column as IC 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@@ -27,7 +24,7 @@ -- '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@@ -39,7 +36,7 @@ -- | Target the single 'HPQ.PrimExpr' inside a 'F.Field n' unpackspecField :: Unpackspec (F.Field_ n a) (F.Field_ n a)-unpackspecField = Unpackspec (PM.iso IC.unColumn IC.Column)+unpackspecField = dimap IC.unColumn IC.Column (Unpackspec (PM.PackMap id)) -- | Modify all the targeted 'HPQ.PrimExpr's runUnpackspec :: Applicative f
src/Opaleye/Internal/Values.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE Arrows #-}-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-} @@ -8,7 +7,6 @@ import Opaleye.Internal.Column (Field_(Column)) import qualified Opaleye.Internal.Column as C import qualified Opaleye.Column as OC-import qualified Opaleye.Internal.Unpackspec as U import qualified Opaleye.Internal.Tag as T import qualified Opaleye.Internal.Operators as O import qualified Opaleye.Internal.PrimQuery as PQ@@ -25,9 +23,8 @@ import Data.Profunctor.Product (ProductProfunctor) import qualified Data.Profunctor.Product as PP import Data.Profunctor.Product.Default (Default, def)-import Data.Semigroup (Semigroup, (<>)) -import Control.Applicative (Applicative, pure, (<*>), liftA2)+import Control.Applicative (liftA2) nonEmptyValues :: Rowspec columns columns' -> NEL.NonEmpty columns@@ -59,11 +56,11 @@ -- Some overlap here with extractAttrPE nonEmptyRowspecField :: NonEmptyRowspec (Field_ n a) (Field_ n a)-nonEmptyRowspecField = NonEmptyRowspec (pure . C.unColumn) s+nonEmptyRowspecField = dimap C.unColumn C.Column $ NonEmptyRowspec pure s where s = do t <- T.fresh let symbol = HPQ.Symbol "values" t- pure (pure symbol, C.Column (HPQ.AttrExpr symbol))+ pure (pure symbol, HPQ.AttrExpr symbol) rowspecField :: Rowspec (Field_ n a) (Field_ n a) rowspecField = NonEmptyRows nonEmptyRowspecField@@ -218,49 +215,8 @@ -- } -{-# DEPRECATED valuesU "Will be removed in 0.10" #-}-valuesU :: U.Unpackspec columns columns'- -> ValuesspecUnsafe columns columns'- -> [columns]- -> ((), T.Tag) -> (columns', PQ.PrimQuery)-valuesU unpack valuesspec rows ((), t) = (newColumns, primQ')- 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'--{-# DEPRECATED extractValuesEntry "Will be removed in 0.10" #-}-extractValuesEntry :: HPQ.PrimExpr -> PM.PM [HPQ.PrimExpr] HPQ.PrimExpr-extractValuesEntry pe = do- PM.write pe- return pe--{-# DEPRECATED extractValuesField "Will be removed in 0.10" #-}-extractValuesField :: T.Tag -> primExpr- -> PM.PM [(HPQ.Symbol, primExpr)] HPQ.PrimExpr-extractValuesField = PM.extractAttr "values"--{-# DEPRECATED runValuesspec "Will be removed in 0.10" #-}-runValuesspec :: Applicative f => ValuesspecUnsafe columns columns'- -> (() -> f HPQ.PrimExpr) -> f columns'-runValuesspec (Valuesspec v) f = PM.traversePM v f ()- 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)--{-# DEPRECATED ValuesspecSafe "Use Valuesspec instead. Will be removed in version 0.10." #-}-type ValuesspecSafe = Valuesspec
src/Opaleye/Internal/Window.hs view
@@ -1,6 +1,17 @@+-- 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 Control.Applicative (Applicative, pure, (<*>))+import Data.Profunctor (lmap, Profunctor, dimap) import qualified Opaleye.Internal.Aggregate as A import qualified Opaleye.Internal.PackMap as PM@@ -11,109 +22,160 @@ 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) --- | 'Window' is an applicative functor that represents expressions that--- contain--- [window functions](https://www.postgresql.org/docs/current/tutorial-window.html).--- 'window' can be used to evaluate these expressions over a particular query.-newtype Window a =- Window (PM.PackMap (HPQ.WndwOp, Partition) HPQ.PrimExpr () a)+-- | '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 Functor Window where- fmap f (Window g) = Window (fmap f g)+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) -instance Applicative Window where- pure = Window . pure- Window f <*> Window x = Window (f <*> x)+-- | 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) -runWindow :: Applicative f- => Window a -> ((HPQ.WndwOp, Partition) -> f HPQ.PrimExpr) -> f a-runWindow (Window a) f = PM.traversePM a f ()+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- -> (HPQ.WndwOp, Partition)+ -> a+ -> (HPQ.WndwOp, Window a) -> PM.PM (PQ.Bindings (HPQ.WndwOp, HPQ.Partition)) HPQ.PrimExpr-extractWindowFields tag (op, Partition ps os) = do+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 os)))+ PM.write (symbol, (op, HPQ.Partition (ps a) (O.orderExprs a os))) pure (HPQ.AttrExpr symbol) --- | 'window' runs a query composed of expressions containing--- [window functions](https://www.postgresql.org/docs/current/tutorial-window.html).--- 'window' 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. To put this into a Haskell context, 'Opaleye.aggregate' is to 'foldl'--- as 'window' is to 'scanl'.-window :: Q.Select (Window a) -> Q.Select a-window q = Q.productQueryArr $ do- (wndw, primQ) <- Q.runSimpleQueryArr' q ()+-- | 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- (a, bindings) = PM.run (runWindow wndw (extractWindowFields tag))- pure (a, PQ.Window bindings primQ)+ (b, bindings) = PM.run (runWindows' wndw (extractWindowFields tag a) a)+ pure (b, PQ.Window bindings primQ) -makeWndw :: HPQ.WndwOp -> Window (C.Field_ n a)-makeWndw op = Window (PM.PackMap (\f _ -> C.Column <$> f (op, mempty)))+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 --- | 'cumulative' allows the use of aggregation functions in 'Window'--- expressions. In particular, @'cumulative' 'Opaleye.sum'@--- (when combined with 'orderPartitionBy') gives a running total,--- also known as a \"cumulative sum\", hence the name @cumulative@.-cumulative :: A.Aggregator a b -> a -> Window b-cumulative (A.Aggregator (PM.PackMap pm)) a = Window $ PM.PackMap $ \f _ ->- pm (\(mop, expr) -> case mop of- Nothing -> pure expr- Just (op, _, _) -> f (HPQ.WndwAggregate op expr, mempty)) a+makeWndw :: WindowFunction HPQ.WndwOp (C.Field_ n a)+makeWndw = WindowFunction (PM.PackMap (\f op -> C.Column <$> f op)) --- | 'over' adds a 'Partition' to a 'Window' expression.------ @--- 'cumulative' 'Opaleye.sum' salary \`'over'\` 'partitionBy' department <> 'orderPartitionBy' salary ('Opaleye.desc' id)--- @-over :: Window a -> Partition -> Window a-over (Window (PM.PackMap pm)) partition =- Window $ PM.PackMap $ \f -> pm $ \(op, partition') ->- f (op, partition' <> partition)-infixl 1 `over`+makeWndwField :: (HPQ.PrimExpr -> HPQ.WndwOp)+ -> WindowFunction (C.Field_ n a) (C.Field_ n' a')+makeWndwField f = lmap (f . C.unColumn) makeWndw --- | In PostgreSQL, window functions must specify the \"window\" or--- \"partition\" over which they operate. The syntax for this looks like:--- @SUM(salary) OVER (PARTITION BY department)@. The Opaleye type 'Partition'--- represents everything that comes after @OVER@.------ 'Partition' is a 'Monoid', so 'Partition's created with 'partitionBy' and--- 'orderPartitionBy' can be combined using '<>'.-data Partition = Partition ![HPQ.PrimExpr] ![HPQ.OrderExpr]+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 -instance Semigroup Partition where- Partition ps os <> Partition ps' os' = Partition (ps <> ps') (os <> os')+-- | '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 Monoid Partition where- mempty = Partition [] []+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 = (<>) --- | Restricts a window function to operate only the group of rows that share--- the same value(s) for the given expression(s).-partitionBy :: C.Field_ n a -> Partition-partitionBy (C.Column expr) = Partition [expr] []+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 :: a -> O.Order a -> Partition-orderPartitionBy a ordering = Partition [] (O.orderExprs a ordering)+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@@ -27,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'@@ -141,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)@@ -163,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'.@@ -177,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,
src/Opaleye/Label.hs view
@@ -17,7 +17,7 @@ label' l = Q.selectArr f where f = pure (\() -> ((), PQ.aLabel l)) --- | Will be deprecated in version 0.10. Use 'label\'' instead.+{-# DEPRECATED label "Will be removed in version 0.11. Use 'label\'' instead." #-} label :: String -> S.SelectArr a b -> S.SelectArr a b label l s = proc a -> do b <- s -< a
src/Opaleye/Manipulation.hs view
@@ -1,6 +1,4 @@ {-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -50,8 +48,8 @@ runDelete_, -- ** @DoNothing@ -- | Use 'doNothing' instead.- -- @DoNothing@ will be deprecated in- -- version 0.10.+ -- @DoNothing@ will be removed in+ -- version 0.11. HSql.OnConflict(HSql.DoNothing), ) where @@ -97,7 +95,7 @@ \c t r -> MI.runInsertManyReturningExplicit qr c t r f onConflict_ in insert conn table_ rows_ --- | Use 'runInsert' instead. Will be deprecated in 0.10.+{-# DEPRECATED runInsert_ "Use 'runInsert' instead. Will be removed in 0.11." #-} runInsert_ :: PGS.Connection -> Insert haskells -> IO haskells@@ -119,7 +117,7 @@ MI.ReturningExplicit qr f -> runUpdateReturningExplicit qr conn table_ updateWith_ where_ f --- | Use 'runUpdate' instead. Will be deprecated in 0.10.+{-# DEPRECATED runUpdate_ "Use 'runUpdate' instead. Will be removed in 0.11." #-} runUpdate_ :: PGS.Connection -> Update haskells -> IO haskells@@ -140,7 +138,7 @@ MI.ReturningExplicit qr f -> MI.runDeleteReturningExplicit qr conn table_ where_ f --- | Use 'runDelete' instead. Will be deprecated in 0.10.+{-# DEPRECATED runDelete_ "Use 'runDelete' instead. Will be removed in 0.11." #-} runDelete_ :: PGS.Connection -> Delete haskells -> IO haskells@@ -158,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@ } @@ -182,7 +180,7 @@ -- @uUpdateWith = updateEasy (\\... -> ...)@ updateEasy :: D.Default Updater fieldsR fieldsW => (fieldsR -> fieldsR)- -- ^+ -- ^ ͘ -> (fieldsR -> fieldsW) updateEasy u = u' . u where Updater u' = D.def@@ -208,7 +206,7 @@ -- 'rReturning'. rReturning :: D.Default RS.FromFields fields haskells => (fieldsR -> fields)- -- ^+ -- ^ ͘ -> MI.Returning fieldsR [haskells] rReturning = rReturningExplicit D.def @@ -217,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]
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@@ -19,6 +17,7 @@ fromMaybeFields, maybeFields, maybeFieldsToNullable,+ isJustAnd, -- * Creating a 'Select' which returns 'MaybeFields' Opaleye.Join.optional, Opaleye.MaybeFields.traverseMaybeFields,@@ -67,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,8 +1,6 @@ {-# LANGUAGE Arrows #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE DataKinds #-} @@ -60,6 +58,7 @@ , sqlLength -- * Containment operators , in_+ , inMany , inSelect -- * JSON operators , SqlIsJson@@ -87,6 +86,7 @@ , index , arrayPosition , sqlElem+ , sqlElemAny -- * Range operators , overlap , liesWithin@@ -104,8 +104,10 @@ , IntervalNum , addInterval , minusInterval+ , TimestampPrecision(..)+ , dateTruncTimestamp+ , dateTruncTimestamptz -- * Deprecated- , keepWhen ) where@@ -138,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 @@ -184,14 +189,14 @@ 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..==)@@ -286,21 +291,37 @@ -- | '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 (Field a) -> Field a -> F.Field T.SqlBool+-- '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'.@@ -418,12 +439,20 @@ -- | 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.+-- 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 +-- | 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.:&&) @@ -487,12 +516,31 @@ minusInterval :: IntervalNum from to => F.Field from -> F.Field T.SqlInterval -> F.Field to minusInterval = C.binOp (HPQ.:-) -{-# DEPRECATED keepWhen "Use 'where_' or 'restrict' instead. Will be removed in version 0.10." #-}-keepWhen :: (a -> F.Field T.SqlBool) -> S.SelectArr a a-keepWhen p = proc a -> do- restrict -< p a- A.returnA -< a- -- | Current date and time (start of current transaction) now :: F.Field T.SqlTimestamptz now = Column $ HPQ.FunExpr "now" []++data TimestampPrecision =+ MicrosecondsPrecision+ | MillisecondsPrecision+ | SecondPrecision+ | MinutePrecision+ | HourPrecision+ | DayPrecision+ | WeekPrecision+ | MonthPrecision+ | QuarterPrecision+ | YearPrecision+ | DecadePrecision+ | CenturyPrecision+ | MillenniumPrecision+ deriving Show++precisionToExpr :: TimestampPrecision -> HPQ.PrimExpr+precisionToExpr p = HPQ.ConstExpr . HPQ.ByteStringLit . TE.encodeUtf8 . Text.toLower . Text.dropEnd 9 . Text.pack $ show p++dateTruncTimestamp :: TimestampPrecision -> F.Field T.SqlTimestamp -> F.Field T.SqlTimestamp+dateTruncTimestamp p (Column e) = Column $ HPQ.FunExpr "date_trunc" [(precisionToExpr p), e]++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,10 +7,14 @@ , asc , desc , ascNullsFirst+ , ascNullsLast , descNullsLast+ , descNullsFirst -- * Limit and offset , limit+ , limitField , offset+ , offsetField -- * Distinct on , distinctOn , distinctOnBy@@ -32,6 +32,7 @@ import qualified Data.Profunctor.Product.Default as D 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@@ -62,27 +63,36 @@ pure (O.orderByU os a_pq) -- | Specify an ascending ordering by the given expression.--- (Any NULLs appear last) 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 -> 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 -> F.Field 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 -> F.Field 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 } @@ -116,7 +126,12 @@ @ -} limit :: Int -> S.Select a -> S.Select a-limit n a = Q.productQueryArr $ do+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) @@ -128,20 +143,25 @@ 'offset' with 'limit'. -} offset :: Int -> S.Select a -> S.Select a-offset n a = Q.productQueryArr $ do+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 --- | Use 'distinctOn' instead. Will be deprecated in 0.10.+{-# 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 = distinctOnExplicit D.def --- | Use 'distinctOnBy' instead. Will be deprecated in 0.10.+{-# DEPRECATED distinctOnByCorrect "Use 'distinctOnBy' instead. Will be removed in 0.11." #-} distinctOnByCorrect :: D.Default U.Unpackspec b b => (a -> b) -> O.Order a@@ -180,7 +200,7 @@ -- | 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+-- 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
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,@@ -40,29 +39,18 @@ 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 @@ -71,7 +59,7 @@ => PGS.Connection -- ^ -> S.Select (rec TF.O)- -- ^+ -- ^ ͘ -> IO [rec TF.H] runSelectTF = RQ.runQuery @@ -89,7 +77,7 @@ -> b -- ^ -> (b -> haskells -> IO b)- -- ^+ -- ^ ͘ -> IO b runSelectFold = RQ.runQueryFold @@ -100,7 +88,7 @@ => PGS.Connection -- ^ -> S.Select fields- -- ^+ -- ^ ͘ -> IO (IRQ.Cursor haskells) declareCursor = RQ.declareCursor @@ -119,7 +107,7 @@ -> (a -> haskells -> IO a) -- ^ -> a- -- ^+ -- ^ ͘ -> IO (Either a a) foldForward = RQ.foldForward @@ -164,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@@ -30,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@: -- -- @
src/Opaleye/SqlTypes.hs view
@@ -9,6 +9,7 @@ sqlDouble, sqlInt8, sqlNumeric,+ sqlInt2, -- ** Types SqlInt4, SqlFloat8,@@ -90,10 +91,12 @@ SqlBytea, -- * @IsSqlType@ 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,@@ -123,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 @@ -151,6 +154,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
src/Opaleye/Table.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-- {- | Table fields can be required or optional and, independently, nullable or@@ -67,6 +63,7 @@ T.tableField, T.optionalTableField, T.requiredTableField,+ T.omitOnWriteTableField, T.InferrableTableField, -- * Selecting from tables selectTable,@@ -96,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@: -- -- @@@ -105,7 +102,7 @@ -- @ selectTable :: D.Default U.Unpackspec fields fields => Table a fields- -- ^+ -- ^ ͘ -> S.Select fields selectTable = selectTableExplicit D.def @@ -130,7 +127,7 @@ selectTableExplicit :: U.Unpackspec tablefields fields -- ^ -> Table a tablefields- -- ^+ -- ^ ͘ -> S.Select fields selectTableExplicit cm table' = Q.productQueryArr $ do t0 <- Tag.fresh
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/Values.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE FlexibleContexts #-}- module Opaleye.Values( values, -- * Explicit versions@@ -7,38 +5,14 @@ -- * Adaptors V.Valuesspec, V.valuesspecField,- -- * Deprecated versions- valuesSafe,- valuesSafeExplicit,- valuesUnsafe,- valuesUnsafeExplicit,- V.ValuesspecSafe, ) where -import qualified Opaleye.Internal.QueryArr as Q-import qualified Opaleye.Internal.Tag as Tag import qualified Opaleye.Internal.Values as V-import qualified Opaleye.Internal.Unpackspec as U import qualified Opaleye.Select as S import qualified Data.List.NonEmpty as NEL import Data.Profunctor.Product.Default (Default, def) -{-# DEPRECATED valuesUnsafe "Use 'values' instead. Will be removed in 0.10." #-}-valuesUnsafe :: (Default V.ValuesspecUnsafe fields fields,- Default U.Unpackspec fields fields) =>- [fields] -> S.Select fields-valuesUnsafe = valuesUnsafeExplicit def def--{-# DEPRECATED valuesUnsafeExplicit "Use 'values' instead. Will be removed in 0.10." #-}-valuesUnsafeExplicit :: U.Unpackspec fields fields'- -> V.ValuesspecUnsafe fields fields'- -> [fields] -> S.Select fields'-valuesUnsafeExplicit unpack valuesspec fields =- Q.productQueryArr $ do- t <- Tag.fresh- pure (V.valuesU unpack valuesspec fields ((), t))- -- | 'values' implements Postgres's @VALUES@ construct and allows you -- to create a @SELECT@ that consists of the given rows. --@@ -48,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@: -- -- @@@ -63,13 +37,3 @@ valuesExplicit (V.ValuesspecSafe nullspec rowspec) fields = case NEL.nonEmpty fields of Nothing -> V.emptySelectExplicit nullspec Just rows -> V.nonEmptyValues rowspec rows--{-# DEPRECATED valuesSafe "Use 'values' instead. Will be removed in 0.10." #-}-valuesSafe :: Default V.Valuesspec fields fields- => [fields] -> S.Select fields-valuesSafe = values--{-# DEPRECATED valuesSafeExplicit "Use 'values' instead. Will be removed in 0.10." #-}-valuesSafeExplicit :: V.Valuesspec fields fields'- -> [fields] -> S.Select fields'-valuesSafeExplicit = valuesExplicit
src/Opaleye/Window.hs view
@@ -1,15 +1,30 @@+-- | Support for [PostgreSQL window+-- functions](https://www.postgresql.org/docs/current/tutorial-window.html)+ module Opaleye.Window (- -- * Window queries- W.window- , W.Window+ -- * Run window functions on a @Select@+ W.runWindows++ -- * Create @Windows@+ , W.Windows , W.over- , W.Partition++ -- * Create a @Window@+ , W.Window , W.partitionBy- , W.orderPartitionBy - -- ** Specific window functions- , W.cumulative+ -- * 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@@ -30,64 +45,70 @@ import qualified Opaleye.Field as F import qualified Opaleye.SqlTypes as T --- This page of Postgres documentation tell us what window--- functions are available------ https://www.postgresql.org/docs/devel/functions-window.html-- -- | [@row_number()@](https://www.postgresql.org/docs/current/functions-window.html)-rowNumber :: W.Window (F.Field T.SqlInt8)-rowNumber = W.makeWndw HPQ.WndwRowNumber+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.Window (F.Field T.SqlInt8)-rank = W.makeWndw HPQ.WndwRank+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.Window (F.Field T.SqlInt8)-denseRank = W.makeWndw HPQ.WndwDenseRank+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.Window (F.Field T.SqlFloat8)-percentRank = W.makeWndw HPQ.WndwPercentRank+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.Window (F.Field T.SqlFloat8)-cumeDist = W.makeWndw HPQ.WndwCumeDist+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 -> W.Window (F.Field T.SqlInt4)-ntile (IC.Column buckets) = W.makeWndw $ HPQ.WndwNtile buckets+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_ n a -> F.Field T.SqlInt4 -> F.Field_ n a -> W.Window (F.Field_ n a)-lag (IC.Column a) (IC.Column offset) (IC.Column def) =- W.makeWndw $ HPQ.WndwLag a offset def+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_ n a -> F.Field T.SqlInt4 -> F.Field_ n a -> W.Window (F.Field_ n a)-lead (IC.Column a) (IC.Column offset) (IC.Column def) =- W.makeWndw $ HPQ.WndwLead a offset def+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 :: F.Field_ n a -> W.Window (F.Field_ n a)-firstValue (IC.Column a) = W.makeWndw $ HPQ.WndwFirstValue a+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 :: F.Field_ n a -> W.Window (F.Field_ n a)-lastValue (IC.Column a) = W.makeWndw $ HPQ.WndwLastValue a+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_ n a -> F.Field T.SqlInt4 -> W.Window (F.FieldNullable a)-nthValue (IC.Column a) (IC.Column n) = W.makeWndw $ HPQ.WndwNthValue a n+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
@@ -1,24 +1,28 @@-{-# LANGUAGE FlexibleContexts #-}- 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)+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)@@ -26,34 +30,80 @@ with :: Default Unpackspec a a => Select a -> (Select a -> Select b) -> Select b with = withExplicit def --- | @withRecursive s f@ is the smallest set of rows @r@ such that+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 (\_ -> rhsSelect) bodySelect+ 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 rhsSelect bodySelect+ 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 rhsSelect bodySelect = do+withG unpackspec recursive materialized rhsSelect bodySelect = do (selectCte, withCte) <- freshCte unpackspec let rhsSelect' = rhsSelect selectCte@@ -62,14 +112,14 @@ (_, rhsQ) <- runSimpleSelect rhsSelect' bodyQ <- runSimpleSelect bodySelect' - pure (withCte recursive rhsQ bodyQ)+ pure (withCte recursive materialized rhsQ bodyQ) freshCte :: Unpackspec a a -> State Tag.Tag ( Select a,- PQ.Recursive -> PQ.PrimQuery -> (b, PQ.PrimQuery) -> (b, PQ.PrimQuery)+ PQ.Recursive -> Maybe PQ.Materialized -> PQ.PrimQuery -> (b, PQ.PrimQuery) -> (b, PQ.PrimQuery) ) freshCte unpackspec = do cteName <- HPQ.Symbol "cte" <$> Tag.fresh@@ -91,8 +141,8 @@ pure ( selectCte,- \recursive withQ (withedCols, withedQ) ->- (withedCols, PQ.With recursive cteName (map fst cteBindings) withQ withedQ)+ \recursive materialized withQ (withedCols, withedQ) ->+ (withedCols, PQ.With recursive materialized cteName (map fst cteBindings) withQ withedQ) ) binaryspecToUnpackspec :: Binaryspec a a -> Unpackspec a a