on master help sign in
27 files changed+558−196
since splitsnapshots
unifiedsplit
.github/workflows/build.yaml+1−1 Changelog.md+23 default.nix+1−1 nix/sources.json+9−9 nix/sources.nix+21−1 rel8.cabal+9−3 shell.nix+1−1 src/Rel8.hs+26 src/Rel8/Aggregate.hs+11−19 src/Rel8/Expr/Aggregate.hs+16−70 src/Rel8/Expr/Opaleye.hs+10−1 src/Rel8/Expr/Sequence.hs+2−1 src/Rel8/Expr/Window.hs+121 src/Rel8/Generic/Rel8able.hs+6−1 src/Rel8/Order.hs+1−8 src/Rel8/Query.hs+14−1 src/Rel8/Query/Indexed.hs+5−18 src/Rel8/Query/Window.hs+26 src/Rel8/Schema/HTable.hs+29−2 src/Rel8/Statement/Select.hs+2−3 src/Rel8/Statement/View.hs+30−5 src/Rel8/Table/Opaleye.hs+28−46 src/Rel8/Table/These.hs+14−3 src/Rel8/Table/Window.hs+43 src/Rel8/Tabulate.hs+2−1 src/Rel8/Window.hs+97 tests/Rel8/Generic/Rel8able/Test.hs+10−1
.github/workflows/build.yaml+1−1
@@ -14,7 +14,7 @@ jobs:
1414 nix_path: nixpkgs=channel:nixos-unstable
1515 extra_nix_config: |
1616 trusted-public-keys = cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ=
17− substituters = https://cache.nixos.org/ https://hydra.iohk.io
17+ substituters = https://cache.nixos.org/ https://cache.iog.io
1818
1919 - uses: cachix/cachix-action@v10
2020 with:
Changelog.md+23
@@ -1,3 +1,26 @@
1+# 1.4.0.0 (2002-08-17)
2+
3+## Breaking changes
4+
5+* The behavior of `greatest`/`least` has been corrected, and was previously flipped. ([#183](https://github.com/circuithub/rel8/pull/183))
6+
7+## New features
8+
9+* `NullTable`/`HNull` have been added. This is an alternative to `MaybeTable` that doesn't use a tag columns. It's less flexible (no `Functor` or `Applicative` instance) and is meaningless when used with a table that has no non-nullable columns (so nesting `NullTable` is redundant). But in situations where the underlying `Table` does have non-nullable columns, it can losslessly converted to and from `MaybeTable`. It is useful for embedding into a base table when you don't want to store the extra tag column in your schema. ([#173](https://github.com/circuithub/rel8/pull/173))
10+* Add `fromMaybeTable`. ([#179](https://github.com/circuithub/rel8/pull/179))
11+* Add `alignMaybeTable`. ([#196](https://github.com/circuithub/rel8/pull/196))
12+
13+## Improvements
14+
15+* Optimize implementation of `AltTable` for `Tabulation` ([#178](https://github.com/circuithub/rel8/pull/178))
16+
17+## Other
18+
19+* Documentation improvements for `HADT`. ([#177](https://github.com/circuithub/rel8/pull/177))
20+* Document example usage of `groupBy`. ([#184](https://github.com/circuithub/rel8/pull/184))
21+* Build with and require Opaleye >= 0.9.3.3. ([#190](https://github.com/circuithub/rel8/pull/190))
22+* Build with `hasql` 1.6. ([#195](https://github.com/circuithub/rel8/pull/195))
23+
124# 1.3.1.0 (2022-01-20)
225
326## Other
default.nix+1−1
@@ -5,7 +5,7 @@ let
55
66 nixpkgsArgs = haskellNix.nixpkgsArgs;
77
8− compiler-nix-name = "ghc921";
8+ compiler-nix-name = "ghc924";
99
1010 pkgs = import nixpkgsSrc nixpkgsArgs;
1111
nix/sources.json+9−9
@@ -5,10 +5,10 @@
55 "homepage": "https://input-output-hk.github.io/haskell.nix",
66 "owner": "input-output-hk",
77 "repo": "haskell.nix",
8− "rev": "f3b66b194cd95bfd269a29f89b686eb62269a2b4",
9− "sha256": "16nk8ahn1n8fg24zrxj4bp4zrmacdw11zhjk80r5fnmshm232s47",
8+ "rev": "0837156c56cb5350dd9bd84eb424187e00aa1e8a",
9+ "sha256": "1djmv5a0vfj78csw2cad6nicrs8iqrp928b9b3v4h7lwwhhzliwl",
1010 "type": "tarball",
11− "url": "https://github.com/input-output-hk/haskell.nix/archive/f3b66b194cd95bfd269a29f89b686eb62269a2b4.tar.gz",
11+ "url": "https://github.com/input-output-hk/haskell.nix/archive/0837156c56cb5350dd9bd84eb424187e00aa1e8a.tar.gz",
1212 "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
1313 },
1414 "niv": {
@@ -17,10 +17,10 @@
1717 "homepage": "https://github.com/nmattia/niv",
1818 "owner": "nmattia",
1919 "repo": "niv",
20− "rev": "e0ca65c81a2d7a4d82a189f1e23a48d59ad42070",
21− "sha256": "1pq9nh1d8nn3xvbdny8fafzw87mj7gsmp6pxkdl65w2g18rmcmzx",
20+ "rev": "acdb1726783637852c01e0ad639ac9cbec28d8c8",
21+ "sha256": "1wszl8q70z6wfgkh2dvgmhhry6qp9nar421qq2ifd17hq2jj9ck3",
2222 "type": "tarball",
23− "url": "https://github.com/nmattia/niv/archive/e0ca65c81a2d7a4d82a189f1e23a48d59ad42070.tar.gz",
23+ "url": "https://github.com/nmattia/niv/archive/acdb1726783637852c01e0ad639ac9cbec28d8c8.tar.gz",
2424 "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
2525 },
2626 "nixpkgs": {
@@ -29,10 +29,10 @@
2929 "homepage": null,
3030 "owner": "nixos",
3131 "repo": "nixpkgs",
32− "rev": "59b8d9cf24e9fcf10341a0923c9bdca088dca8c8",
33− "sha256": "08f38v4b2kcxnbapdwrb54bglka92cxj9qlnqlk5px206jyq9v4c",
32+ "rev": "1c1f5649bb9c1b0d98637c8c365228f57126f361",
33+ "sha256": "0f2nvdijyxfgl5kwyb4465pppd5vkhqxddx6v40k2s0z9jfhj0xl",
3434 "type": "tarball",
35− "url": "https://github.com/nixos/nixpkgs/archive/59b8d9cf24e9fcf10341a0923c9bdca088dca8c8.tar.gz",
35+ "url": "https://github.com/nixos/nixpkgs/archive/1c1f5649bb9c1b0d98637c8c365228f57126f361.tar.gz",
3636 "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
3737 }
3838}
nix/sources.nix+21−1
@@ -31,8 +31,28 @@ let
3131 if spec ? branch then "refs/heads/${spec.branch}" else
3232 if spec ? tag then "refs/tags/${spec.tag}" else
3333 abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!";
34+ submodules = if spec ? submodules then spec.submodules else false;
35+ submoduleArg =
36+ let
37+ nixSupportsSubmodules = builtins.compareVersions builtins.nixVersion "2.4" >= 0;
38+ emptyArgWithWarning =
39+ if submodules == true
40+ then
41+ builtins.trace
42+ (
43+ "The niv input \"${name}\" uses submodules "
44+ + "but your nix's (${builtins.nixVersion}) builtins.fetchGit "
45+ + "does not support them"
46+ )
47+ {}
48+ else {};
49+ in
50+ if nixSupportsSubmodules
51+ then { inherit submodules; }
52+ else emptyArgWithWarning;
3453 in
35− builtins.fetchGit { url = spec.repo; inherit (spec) rev; inherit ref; };
54+ builtins.fetchGit
55+ ({ url = spec.repo; inherit (spec) rev; inherit ref; } // submoduleArg);
3656
3757 fetch_local = spec: spec.path;
3858
rel8.cabal+9−3
@@ -1,6 +1,6 @@
11cabal-version: 2.0
22name: rel8
3−version: 1.3.1.0
3+version: 1.4.0.0
44synopsis: Hey! Hey! Can u rel8?
55license: BSD3
66license-file: LICENSE
@@ -26,8 +26,8 @@ library
2626 , case-insensitive
2727 , comonad
2828 , contravariant
29− , hasql ^>= 1.4.5.1 || ^>= 1.5.0.0
30− , opaleye ^>= 0.9.1.0
29+ , hasql ^>= 1.4.5.1 || ^>= 1.5.0.0 || ^>= 1.6.0.0
30+ , opaleye ^>= 0.9.6.1
3131 , pretty
3232 , profunctors
3333 , product-profunctors
@@ -82,6 +82,7 @@ library
8282 Rel8.Expr.Order
8383 Rel8.Expr.Sequence
8484 Rel8.Expr.Serialize
85+ Rel8.Expr.Window
8586
8687 Rel8.FCF
8788
@@ -120,6 +121,7 @@ library
120121 Rel8.Query.SQL
121122 Rel8.Query.These
122123 Rel8.Query.Values
124+ Rel8.Query.Window
123125
124126 Rel8.Schema.Context.Nullify
125127 Rel8.Schema.Dict
@@ -179,6 +181,7 @@ library
179181 Rel8.Table.These
180182 Rel8.Table.Transpose
181183 Rel8.Table.Undefined
184+ Rel8.Table.Window
182185
183186 Rel8.Type
184187 Rel8.Type.Array
@@ -197,6 +200,9 @@ library
197200 Rel8.Type.Sum
198201 Rel8.Type.Tag
199202
203+ Rel8.Window
204+
205+
200206test-suite tests
201207 type: exitcode-stdio-1.0
202208 build-depends:
shell.nix+1−1
@@ -1,6 +1,6 @@
11let
22 sources = import ./nix/sources.nix;
3− pkgs = import sources.nixpkgs {};
3+ pkgs = import sources.nixpkgs {overlays = [];};
44 hsPkgs = import ./default.nix;
55in
66 hsPkgs.shellFor {
src/Rel8.hs+26
@@ -81,6 +81,7 @@ module Rel8
8181 , isThisTable, isThatTable, isThoseTable
8282 , hasHereTable, hasThereTable
8383 , justHereTable, justThereTable
84+ , alignMaybeTable
8485 , alignBy
8586 , keepHereTable, loseHereTable
8687 , keepThereTable, loseThereTable
@@ -274,6 +275,26 @@ module Rel8
274275 , nullsLast
275276
276277 -- ** Window functions
278+ , Window
279+ , window
280+ , Partition
281+ , over
282+ , partitionBy
283+ , orderPartitionBy
284+ , cumulative
285+ , cumulative_
286+ , currentRow
287+ , rowNumber
288+ , rank
289+ , denseRank
290+ , percentRank
291+ , cumeDist
292+ , ntile
293+ , lag
294+ , lead
295+ , firstValue
296+ , lastValue
297+ , nthValue
277298 , indexed
278299
279300 -- ** Bindings
@@ -313,6 +334,7 @@ module Rel8
313334
314335 -- ** @CREATE VIEW@
315336 , createView
337+ , createOrReplaceView
316338
317339 -- ** Sequences
318340 , nextval
@@ -346,6 +368,7 @@ import Rel8.Expr.Order
346368import Rel8.Expr.Serialize
347369import Rel8.Expr.Sequence
348370import Rel8.Expr.Text ( like, ilike )
371+import Rel8.Expr.Window hiding ( cumulative )
349372import Rel8.Generic.Rel8able ( KRel8able, Rel8able )
350373import Rel8.Order
351374import Rel8.Query
@@ -367,6 +390,7 @@ import Rel8.Query.SQL (showQuery)
367390import Rel8.Query.Set
368391import Rel8.Query.These
369392import Rel8.Query.Values
393+import Rel8.Query.Window
370394import Rel8.Schema.Field
371395import Rel8.Schema.HTable
372396import Rel8.Schema.Name
@@ -402,6 +426,7 @@ import Rel8.Table.Rel8able ()
402426import Rel8.Table.Serialize
403427import Rel8.Table.These
404428import Rel8.Table.Transpose
429+import Rel8.Table.Window
405430import Rel8.Type
406431import Rel8.Type.Composite
407432import Rel8.Type.Eq
@@ -416,6 +441,7 @@ import Rel8.Type.ReadShow
416441import Rel8.Type.Semigroup
417442import Rel8.Type.String
418443import Rel8.Type.Sum
444+import Rel8.Window
419445
420446
421447-- $running
src/Rel8/Aggregate.hs+11−19
@@ -2,7 +2,6 @@
22{-# language FlexibleContexts #-}
33{-# language FlexibleInstances #-}
44{-# language MultiParamTypeClasses #-}
5−{-# language NamedFieldPuns #-}
65{-# language RankNTypes #-}
76{-# language StandaloneKindSignatures #-}
87{-# language TypeFamilies #-}
@@ -10,7 +9,7 @@
109
1110module Rel8.Aggregate
1211 ( Aggregate(..), zipOutputs
13− , Aggregator(..), unsafeMakeAggregate
12+ , unsafeMakeAggregate
1413 , Aggregates
1514 )
1615where
@@ -21,10 +20,13 @@ import Data.Functor.Identity ( Identity( Identity ) )
2120import Data.Kind ( Constraint, Type )
2221import Prelude
2322
23+-- profunctors
24+import Data.Profunctor ( dimap )
25+
2426-- opaleye
25−import qualified Opaleye.Internal.Aggregate as Opaleye
27+import qualified Opaleye.Aggregate as Opaleye
2628import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
27−import qualified Opaleye.Internal.PackMap as Opaleye
29+import qualified Opaleye.Internal.Column as Opaleye
2830
2931-- rel8
3032import Rel8.Expr ( Expr )
@@ -69,23 +71,13 @@ zipOutputs :: ()
6971zipOutputs f (Aggregate a) (Aggregate b) = Aggregate (liftA2 f a b)
7072
7173
72−type Aggregator :: Type
73−data Aggregator = Aggregator
74− { operation :: Opaleye.AggrOp
75− , ordering :: [Opaleye.OrderExpr]
76− , distinction :: Opaleye.AggrDistinct
77− }
78−
79−
80−unsafeMakeAggregate :: forall (input :: Type) (output :: Type). ()
74+unsafeMakeAggregate :: forall (input :: Type) (output :: Type) n n' a a'. ()
8175 => (Expr input -> Opaleye.PrimExpr)
8276 -> (Opaleye.PrimExpr -> Expr output)
83− -> Maybe Aggregator
77+ -> Opaleye.Aggregator (Opaleye.Field_ n a) (Opaleye.Field_ n' a')
8478 -> Expr input
8579 -> Aggregate output
8680unsafeMakeAggregate input output aggregator expr =
87− Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ \f _ ->
88− output <$> f (tuplize <$> aggregator, input expr)
89− where
90− tuplize Aggregator {operation, ordering, distinction} =
91− (operation, ordering, distinction)
81+ Aggregate $ dimap in_ out aggregator
82+ where out = output . Opaleye.unColumn
83+ in_ = Opaleye.Column . input . const expr
src/Rel8/Expr/Aggregate.hs+16−70
@@ -24,10 +24,12 @@ import Data.List.NonEmpty ( NonEmpty )
2424import Prelude hiding ( and, max, min, null, or, sum )
2525
2626-- opaleye
27−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
27+import qualified Opaleye.Internal.Aggregate as Opaleye
28+import Opaleye.Internal.Column ( Field_( Column ) )
29+import qualified Opaleye.Aggregate as Opaleye
2830
2931-- rel8
30−import Rel8.Aggregate ( Aggregate, Aggregator(..), unsafeMakeAggregate )
32+import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )
3133import Rel8.Expr ( Expr )
3234import Rel8.Expr.Bool ( caseExpr )
3335import Rel8.Expr.Opaleye
@@ -51,23 +53,13 @@ import Rel8.Type.Sum ( DBSum )
5153
5254-- | Count the occurances of a single column. Corresponds to @COUNT(a)@
5355count :: Expr a -> Aggregate Int64
54−count = unsafeMakeAggregate toPrimExpr fromPrimExpr $
55− Just Aggregator
56− { operation = Opaleye.AggrCount
57− , ordering = []
58− , distinction = Opaleye.AggrAll
59− }
60−
56+count = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.count
6157
6258-- | Count the number of distinct occurances of a single column. Corresponds to
6359-- @COUNT(DISTINCT a)@
6460countDistinct :: Sql DBEq a => Expr a -> Aggregate Int64
6561countDistinct = unsafeMakeAggregate toPrimExpr fromPrimExpr $
66− Just Aggregator
67− { operation = Opaleye.AggrCount
68− , ordering = []
69− , distinction = Opaleye.AggrDistinct
70− }
62+ Opaleye.distinctAggregator Opaleye.count
7163
7264
7365-- | Corresponds to @COUNT(*)@.
@@ -82,42 +74,22 @@ countWhere condition = count (caseExpr [(condition, litExpr (Just True))] null)
8274
8375-- | Corresponds to @bool_and@.
8476and :: Expr Bool -> Aggregate Bool
85−and = unsafeMakeAggregate toPrimExpr fromPrimExpr $
86− Just Aggregator
87− { operation = Opaleye.AggrBoolAnd
88− , ordering = []
89− , distinction = Opaleye.AggrAll
90− }
77+and = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolAnd
9178
9279
9380-- | Corresponds to @bool_or@.
9481or :: Expr Bool -> Aggregate Bool
95−or = unsafeMakeAggregate toPrimExpr fromPrimExpr $
96− Just Aggregator
97− { operation = Opaleye.AggrBoolOr
98− , ordering = []
99− , distinction = Opaleye.AggrAll
100− }
82+or = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolOr
10183
10284
10385-- | Produce an aggregation for @Expr a@ using the @max@ function.
10486max :: Sql DBMax a => Expr a -> Aggregate a
105−max = unsafeMakeAggregate toPrimExpr fromPrimExpr $
106− Just Aggregator
107− { operation = Opaleye.AggrMax
108− , ordering = []
109− , distinction = Opaleye.AggrAll
110− }
87+max = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMax
11188
11289
11390-- | Produce an aggregation for @Expr a@ using the @max@ function.
11491min :: Sql DBMin a => Expr a -> Aggregate a
115−min = unsafeMakeAggregate toPrimExpr fromPrimExpr $
116− Just Aggregator
117− { operation = Opaleye.AggrMin
118− , ordering = []
119− , distinction = Opaleye.AggrAll
120− }
92+min = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMin
12193
12294-- | Corresponds to @sum@. Note that in SQL, @sum@ is type changing - for
12395-- example the @sum@ of @integer@ returns a @bigint@. Rel8 doesn't support
@@ -125,12 +97,7 @@ min = unsafeMakeAggregate toPrimExpr fromPrimExpr $
12597-- lead to overflows, and if you anticipate very large sums, you should upcast
12698-- your input.
12799sum :: Sql DBSum a => Expr a -> Aggregate a
128−sum = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $
129− Just Aggregator
130− { operation = Opaleye.AggrSum
131− , ordering = []
132− , distinction = Opaleye.AggrAll
133− }
100+sum = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) Opaleye.unsafeSum
134101
135102
136103-- | Corresponds to @avg@. Note that in SQL, @avg@ is type changing - for
@@ -139,13 +106,7 @@ sum = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $
139106-- need a fractional result on an integral column, you should cast your input
140107-- to 'Double' or 'Data.Scientific.Scientific' before calling 'avg'.
141108avg :: Sql DBSum a => Expr a -> Aggregate a
142−avg = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $
143− Just Aggregator
144− { operation = Opaleye.AggrAvg
145− , ordering = []
146− , distinction = Opaleye.AggrAll
147− }
148−
109+avg = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) Opaleye.unsafeAvg
149110
150111-- | Take the sum of all expressions that satisfy a predicate.
151112sumWhere :: (Sql DBNum a, Sql DBSum a)
@@ -157,17 +118,12 @@ sumWhere condition a = sum (caseExpr [(condition, a)] 0)
157118stringAgg :: Sql DBString a
158119 => Expr db -> Expr a -> Aggregate a
159120stringAgg delimiter =
160− unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $
161− Just Aggregator
162− { operation = Opaleye.AggrStringAggr (toPrimExpr delimiter)
163− , ordering = []
164− , distinction = Opaleye.AggrAll
165− }
121+ unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) (Opaleye.stringAgg (Column (toPrimExpr delimiter)))
166122
167123
168124-- | Aggregate a value by grouping by it.
169125groupByExpr :: Sql DBEq a => Expr a -> Aggregate a
170−groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Nothing
126+groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.groupBy
171127
172128
173129-- | Collect expressions values as a list.
@@ -182,23 +138,13 @@ nonEmptyAggExpr = snonEmptyAggExpr typeInformation
182138
183139slistAggExpr :: ()
184140 => TypeInformation (Unnullify a) -> Expr a -> Aggregate [a]
185−slistAggExpr info = unsafeMakeAggregate to fromPrimExpr $ Just
186− Aggregator
187− { operation = Opaleye.AggrArr
188− , ordering = []
189− , distinction = Opaleye.AggrAll
190− }
141+slistAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg
191142 where
192143 to = encodeArrayElement info . toPrimExpr
193144
194145
195146snonEmptyAggExpr :: ()
196147 => TypeInformation (Unnullify a) -> Expr a -> Aggregate (NonEmpty a)
197−snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr $ Just
198− Aggregator
199− { operation = Opaleye.AggrArr
200− , ordering = []
201− , distinction = Opaleye.AggrAll
202− }
148+snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg
203149 where
204150 to = encodeArrayElement info . toPrimExpr
src/Rel8/Expr/Opaleye.hs+10−1
@@ -10,7 +10,7 @@ module Rel8.Expr.Opaleye
1010 , scastExpr, sunsafeCastExpr
1111 , unsafeLiteral
1212 , fromPrimExpr, toPrimExpr, mapPrimExpr, zipPrimExprsWith, traversePrimExpr
13− , toColumn, fromColumn
13+ , toColumn, fromColumn, traverseFieldP
1414 )
1515where
1616
@@ -27,6 +27,9 @@ import Rel8.Schema.Null ( Unnullify, Sql )
2727import Rel8.Type ( DBType, typeInformation )
2828import Rel8.Type.Information ( TypeInformation(..) )
2929
30+-- profunctors
31+import Data.Profunctor ( Profunctor, dimap )
32+
3033
3134castExpr :: Sql DBType a => Expr a -> Expr a
3235castExpr = scastExpr typeInformation
@@ -80,6 +83,12 @@ traversePrimExpr :: Functor f
8083traversePrimExpr f = fmap fromPrimExpr . f . toPrimExpr
8184
8285
86+traverseFieldP :: Profunctor p
87+ => p (Opaleye.Field_ n x) (Opaleye.Field_ m y)
88+ -> p (Expr a) (Expr b)
89+traverseFieldP = dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn)
90+
91+
8392toColumn :: Opaleye.PrimExpr -> Opaleye.Field_ n b
8493toColumn = Opaleye.Column
8594
src/Rel8/Expr/Sequence.hs+2−1
@@ -11,6 +11,7 @@ import Prelude
1111import Rel8.Expr ( Expr )
1212import Rel8.Expr.Function ( function )
1313import Rel8.Expr.Serialize ( litExpr )
14+import Rel8.Expr.Text ( quoteIdent )
1415
1516-- text
1617import Data.Text ( pack )
@@ -18,4 +19,4 @@ import Data.Text ( pack )
1819
1920-- | See https://www.postgresql.org/docs/current/functions-sequence.html
2021nextval :: String -> Expr Int64
21−nextval = function "nextval" . litExpr . pack
22+nextval = function "nextval" . quoteIdent . litExpr . pack
src/Rel8/Expr/Window.hsnew file+121
@@ -0,0 +1,121 @@
1+module Rel8.Expr.Window
2+ ( cumulative
3+ , rowNumber
4+ , rank
5+ , denseRank
6+ , percentRank
7+ , cumeDist
8+ , ntile
9+ , lag
10+ , lead
11+ , firstValue
12+ , lastValue
13+ , nthValue
14+ )
15+where
16+
17+-- base
18+import Data.Int ( Int32, Int64 )
19+import Prelude
20+
21+-- opaleye
22+import qualified Opaleye.Internal.Aggregate as Opaleye
23+import qualified Opaleye.Internal.PackMap as Opaleye
24+import qualified Opaleye.Internal.Window as Opaleye
25+import qualified Opaleye.Window as Opaleye
26+
27+-- profunctors
28+import Data.Profunctor (dimap)
29+
30+-- rel8
31+import Rel8.Aggregate ( Aggregate( Aggregate ) )
32+import Rel8.Expr ( Expr )
33+import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr, toColumn, toPrimExpr )
34+import Rel8.Schema.Null ( Nullify )
35+import Rel8.Window ( Window( Window ) )
36+
37+
38+cumulative :: (a -> Aggregate b) -> Window a (Expr b)
39+cumulative f =
40+ fromWindowFunction $ Opaleye.aggregatorWindowFunction (fromAggregate f) id
41+
42+
43+-- | [@row_number()@](https://www.postgresql.org/docs/current/functions-window.html)
44+rowNumber :: Window a (Expr Int64)
45+rowNumber = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.rowNumber
46+
47+
48+-- | [@rank()@](https://www.postgresql.org/docs/current/functions-window.html)
49+rank :: Window a (Expr Int64)
50+rank = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.rank
51+
52+
53+-- | [@dense_rank()@](https://www.postgresql.org/docs/current/functions-window.html)
54+denseRank :: Window a (Expr Int64)
55+denseRank = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.denseRank
56+
57+
58+-- | [@percent_rank()@](https://www.postgresql.org/docs/current/functions-window.html)
59+percentRank :: Window a (Expr Double)
60+percentRank = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.percentRank
61+
62+
63+-- | [@cume_dist()@](https://www.postgresql.org/docs/current/functions-window.html)
64+cumeDist :: Window a (Expr Double)
65+cumeDist = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.cumeDist
66+
67+
68+-- | [@ntile(num_buckets)@](https://www.postgresql.org/docs/current/functions-window.html)
69+ntile :: Expr Int32 -> Window a (Expr Int32)
70+ntile buckets = fromWindowFunction $ fromPrimExpr . fromColumn <$>
71+ Opaleye.ntile (toColumn (toPrimExpr buckets))
72+
73+
74+-- | [@lag(value, offset, default)@](https://www.postgresql.org/docs/current/functions-window.html)
75+lag :: Expr Int32 -> Expr a -> Window (Expr a) (Expr a)
76+lag offset def =
77+ fromWindowFunction $
78+ dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $
79+ Opaleye.lag (toColumn (toPrimExpr offset)) (toColumn (toPrimExpr def))
80+
81+
82+-- | [@lead(value, offset, default)@](https://www.postgresql.org/docs/current/functions-window.html)
83+lead :: Expr Int32 -> Expr a -> Window (Expr a) (Expr a)
84+lead offset def =
85+ fromWindowFunction $
86+ dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $
87+ Opaleye.lead (toColumn (toPrimExpr offset)) (toColumn (toPrimExpr def))
88+
89+
90+-- | [@first_value(value)@](https://www.postgresql.org/docs/current/functions-window.html)
91+firstValue :: Window (Expr a) (Expr a)
92+firstValue =
93+ fromWindowFunction $
94+ dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn)
95+ Opaleye.firstValue
96+
97+
98+-- | [@last_value(value)@](https://www.postgresql.org/docs/current/functions-window.html)
99+lastValue :: Window (Expr a) (Expr a)
100+lastValue =
101+ fromWindowFunction $
102+ dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn)
103+ Opaleye.lastValue
104+
105+
106+-- | [@nth_value(value, n)@](https://www.postgresql.org/docs/current/functions-window.html)
107+nthValue :: Expr Int32 -> Window (Expr a) (Expr (Nullify a))
108+nthValue n =
109+ fromWindowFunction $
110+ dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $
111+ Opaleye.nthValue (toColumn (toPrimExpr n))
112+
113+
114+fromAggregate :: (a -> Aggregate b) -> Opaleye.Aggregator a (Expr b)
115+fromAggregate f = Opaleye.Aggregator $ Opaleye.PackMap $ \w a -> case f a of
116+ Aggregate (Opaleye.Aggregator (Opaleye.PackMap x)) -> x w ()
117+
118+
119+fromWindowFunction :: Opaleye.WindowFunction a b -> Window a b
120+fromWindowFunction (Opaleye.WindowFunction (Opaleye.PackMap w)) =
121+ Window $ Opaleye.Windows $ Opaleye.PackMap $ \f -> w $ \o -> f (o, mempty)
src/Rel8/Generic/Rel8able.hs+6−1
@@ -63,6 +63,11 @@ type KRel8able = K.Rel8able
6363-- This is almost 'Data.Type.Equality.==', but we add an extra case.
6464type (==) :: k -> k -> Bool
6565type family a == b where
66+ -- This extra case is needed to solve the equation "a == a" (where a is a
67+ -- KRel8able), which occurs when we have polymorphic Rel8ables
68+ -- (e.g., newtype T t f = T { x :: t a })
69+ (a :: KRel8able) == (a :: KRel8able) = 'True
70+
6671 -- This extra case is needed to solve the equation "a == Identity a",
6772 -- which occurs when we have polymorphic Rel8ables
6873 -- (e.g., newtype T a f = T { x :: Column f a })
@@ -141,7 +146,7 @@ type instance Eval (TSerialize expr a) =
141146-- [Supplying @Rel8able@ instances]
142147--
143148-- This type class should be derived generically for all table types in your
144−-- project. To do this, enable the @DeriveAnyType@ and @DeriveGeneric@ language
149+-- project. To do this, enable the @DeriveAnyClass@ and @DeriveGeneric@ language
145150-- extensions:
146151--
147152-- @
src/Rel8/Order.hs+1−8
@@ -4,7 +4,6 @@
44
55module Rel8.Order
66 ( Order(..)
7− , toOrderExprs
87 )
98where
109
@@ -17,8 +16,7 @@ import Prelude
1716import Data.Functor.Contravariant.Divisible ( Decidable, Divisible )
1817
1918-- opaleye
20−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
21−import qualified Opaleye.Internal.Order as Opaleye
19+import qualified Opaleye.Order as Opaleye
2220
2321
2422-- | An ordering expression for @a@. Primitive orderings are defined with
@@ -30,8 +28,3 @@ import qualified Opaleye.Internal.Order as Opaleye
3028type Order :: Type -> Type
3129newtype Order a = Order (Opaleye.Order a)
3230 deriving newtype (Contravariant, Divisible, Decidable, Semigroup, Monoid)
33−
34−
35−toOrderExprs :: Order a -> a -> [Opaleye.OrderExpr]
36−toOrderExprs (Order (Opaleye.Order order)) a =
37− uncurry Opaleye.OrderExpr <$> order a
src/Rel8/Query.hs+14−1
@@ -1,4 +1,6 @@
1+{-# language FlexibleContexts #-}
12{-# language StandaloneKindSignatures #-}
3+{-# language UndecidableInstances #-}
24
35module Rel8.Query
46 ( Query( Query )
@@ -20,10 +22,11 @@ import qualified Opaleye.Internal.QueryArr as Opaleye
2022import qualified Opaleye.Internal.Tag as Opaleye
2123
2224-- rel8
25+import Rel8.Expr ( Expr )
2326import Rel8.Query.Set ( unionAll )
2427import Rel8.Query.Opaleye ( fromOpaleye )
2528import Rel8.Query.Values ( values )
26−import Rel8.Table ( fromColumns, toColumns )
29+import Rel8.Table ( Table, fromColumns, toColumns )
2730import Rel8.Table.Alternative
2831 ( AltTable, (<|>:)
2932 , AlternativeTable, emptyTable
@@ -208,3 +211,13 @@ instance AltTable Query where
208211-- | 'emptyTable' = 'values' @[]@.
209212instance AlternativeTable Query where
210213 emptyTable = values []
214+
215+
216+-- | '<>' = 'unionAll'.
217+instance Table Expr a => Semigroup (Query a) where
218+ (<>) = (<|>:)
219+
220+
221+-- | 'mempty' = @'values' []@.
222+instance Table Expr a => Monoid (Query a) where
223+ mempty = emptyTable
src/Rel8/Query/Indexed.hs+5−18
@@ -4,31 +4,18 @@ module Rel8.Query.Indexed
44where
55
66-- base
7+import Control.Applicative ( liftA2 )
78import Data.Int ( Int64 )
89import Prelude
910
10−-- opaleye
11−import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
12−import qualified Opaleye.Internal.PackMap as Opaleye
13−import qualified Opaleye.Internal.PrimQuery as Opaleye
14−import qualified Opaleye.Internal.QueryArr as Opaleye
15−import qualified Opaleye.Internal.Tag as Opaleye
16−
1711-- rel8
1812import Rel8.Expr ( Expr )
19−import Rel8.Expr.Opaleye ( fromPrimExpr )
13+import Rel8.Expr.Window ( rowNumber )
2014import Rel8.Query ( Query )
21−import Rel8.Query.Opaleye ( mapOpaleye )
15+import Rel8.Query.Window ( window )
16+import Rel8.Table.Window ( currentRow )
2217
2318
2419-- | Pair each row of a query with its index within the query.
2520indexed :: Query a -> Query (Expr Int64, a)
26−indexed = mapOpaleye $ \f -> Opaleye.stateQueryArr $ \_ tag ->
27− let
28− (a, query, tag') = Opaleye.runStateQueryArr f () tag
29− tag'' = Opaleye.next tag'
30− window = Opaleye.ConstExpr $ Opaleye.OtherLit "ROW_NUMBER() OVER () - 1"
31− (index, bindings) = Opaleye.run $ Opaleye.extractAttr "index" tag' window
32− query' = query <> Opaleye.aRebind bindings
33− in
34− ((fromPrimExpr index, a), query', tag'')
21+indexed = window (liftA2 (,) (subtract 1 <$> rowNumber) currentRow)
src/Rel8/Query/Window.hsnew file+26
@@ -0,0 +1,26 @@
1+module Rel8.Query.Window
2+ ( window
3+ )
4+where
5+
6+-- base
7+import Prelude ()
8+
9+-- opaleye
10+import qualified Opaleye.Window as Opaleye
11+
12+-- rel8
13+import Rel8.Query ( Query )
14+import Rel8.Query.Opaleye ( mapOpaleye )
15+import Rel8.Window ( Window( Window ) )
16+
17+
18+-- | 'window' runs a query composed of expressions containing
19+-- [window functions](https://www.postgresql.org/docs/current/tutorial-window.html).
20+-- 'window' is similar to 'Rel8.aggregate', with the main difference being
21+-- that in a window query, each input row corresponds to one output row,
22+-- whereas aggregation queries fold the entire input query down into a single
23+-- row. To put this into a Haskell context, 'Rel8.aggregate' is to 'foldl' as
24+-- 'window' is to 'scanl'.
25+window :: Window a b -> Query a -> Query b
26+window (Window a) = mapOpaleye (Opaleye.runWindows a)
src/Rel8/Schema/HTable.hs+29−2
@@ -16,11 +16,12 @@
1616module Rel8.Schema.HTable
1717 ( HTable (HField, HConstrainTable)
1818 , hfield, htabulate, htraverse, hdicts, hspecs
19− , hmap, htabulateA
19+ , hfoldMap, hmap, htabulateA, htraverseP, htraversePWithField
2020 )
2121where
2222
2323-- base
24+import Data.Functor.Const ( Const( Const ), getConst )
2425import Data.Kind ( Constraint, Type )
2526import Data.Functor.Compose ( Compose( Compose ), getCompose )
2627import Data.Proxy ( Proxy )
@@ -32,6 +33,12 @@ import GHC.Generics
3233 )
3334import Prelude
3435
36+-- profunctors
37+import Data.Profunctor ( rmap, Profunctor (lmap) )
38+
39+-- product-profunctors
40+import Data.Profunctor.Product ( ProductProfunctor ((****)) )
41+
3542-- rel8
3643import Rel8.Schema.Dict ( Dict )
3744import Rel8.Schema.Spec ( Spec )
@@ -41,7 +48,6 @@ import qualified Rel8.Schema.Kind as K
4148-- semigroupoids
4249import Data.Functor.Apply ( Apply, (<.>) )
4350
44−
4551-- | A @HTable@ is a functor-indexed/higher-kinded data type that is
4652-- representable ('htabulate'/'hfield'), constrainable ('hdicts'), and
4753-- specified ('hspecs').
@@ -114,6 +120,11 @@ class HTable t where
114120 {-# INLINABLE hspecs #-}
115121
116122
123+hfoldMap :: (HTable t, Semigroup s)
124+ => (forall a. context a -> s) -> t context -> s
125+hfoldMap f a = getConst $ htraverse (Const . f) a
126+
127+
117128hmap :: HTable t
118129 => (forall a. context a -> context' a) -> t context -> t context'
119130hmap f a = htabulate $ \field -> f (hfield a field)
@@ -124,6 +135,22 @@ htabulateA :: (HTable t, Apply m)
124135htabulateA f = htraverse getCompose $ htabulate $ Compose . f
125136{-# INLINABLE htabulateA #-}
126137
138+newtype ApplyP p a b = ApplyP { unApplyP :: p a b }
139+
140+instance Profunctor p => Functor (ApplyP p a) where
141+ fmap f = ApplyP . rmap f . unApplyP
142+
143+instance ProductProfunctor p => Apply (ApplyP p a) where
144+ ApplyP f <.> ApplyP x = ApplyP (rmap id f **** x)
145+
146+htraverseP :: (HTable t, ProductProfunctor p)
147+ => (forall a. p (f a) (g a)) -> p (t f) (t g)
148+htraverseP f = htraversePWithField (const f)
149+
150+htraversePWithField :: (HTable t, ProductProfunctor p)
151+ => (forall a. HField t a -> p (f a) (g a)) -> p (t f) (t g)
152+htraversePWithField f = unApplyP $ htabulateA $ \field -> ApplyP $
153+ lmap (flip hfield field) (f field)
127154
128155type GHField :: K.HTable -> Type -> Type
129156newtype GHField t a = GHField (HField (GHColumns (Rep (t Proxy))) a)
src/Rel8/Statement/Select.hs+2−3
@@ -19,7 +19,6 @@ where
1919-- base
2020import Data.Foldable ( toList )
2121import Data.Kind ( Type )
22−import Data.List.NonEmpty ( NonEmpty( (:|) ) )
2322import Data.Void ( Void )
2423import Prelude hiding ( undefined )
2524
@@ -92,7 +91,7 @@ ppSelect query =
9291ppRows :: Table Expr a => Query a -> Doc
9392ppRows query = case optimize primQuery of
9493 -- Special case VALUES because we can't use DEFAULT inside a SELECT
95− Optimized (Opaleye.Product ((_, Opaleye.Values symbols rows) :| []) [])
94+ Optimized (Opaleye.Values symbols rows)
9695 | eqSymbols symbols (toList (T.exprs a)) ->
9796 Opaleye.ppValues_ (map Opaleye.sqlExpr <$> toList rows)
9897 _ -> ppSelect query
@@ -120,7 +119,7 @@ ppPrimSelect query =
120119
121120type Optimized :: Type -> Type
122121data Optimized a = Empty | Unit | Optimized a
123− deriving stock (Functor, Foldable, Traversable)
122+ deriving stock (Functor, Foldable, Traversable, Show)
124123
125124
126125optimize :: Opaleye.PrimQuery' a -> Optimized (Opaleye.PrimQuery' Void)
src/Rel8/Statement/View.hs+30−5
@@ -3,6 +3,7 @@
33
44module Rel8.Statement.View
55 ( createView
6+ , createOrReplaceView
67 )
78where
89
@@ -29,25 +30,49 @@ import qualified Data.Text as Text
2930import Data.Text.Encoding ( encodeUtf8 )
3031
3132
33+data CreateView = Create | CreateOrReplace
34+
35+
3236-- | Given a 'TableSchema' and 'Query', @createView@ runs a @CREATE VIEW@
3337-- statement that will save the given query as a view. This can be useful if
3438-- you want to share Rel8 queries with other applications.
3539createView :: Selects names exprs
3640 => TableSchema names -> Query exprs -> Hasql.Statement () ()
37−createView schema query = Hasql.Statement bytes params decode prepare
41+createView =
42+ createViewGeneric Create
43+
44+
45+-- | Given a 'TableSchema' and 'Query', @createOrReplaceView@ runs a
46+-- @CREATE OR REPLACE VIEW@ statement that will save the given query
47+-- as a view, replacing the current view definition if it exists and
48+-- adheres to the restrictions in place for replacing a view in
49+-- PostgreSQL.
50+createOrReplaceView :: Selects names exprs
51+ => TableSchema names -> Query exprs -> Hasql.Statement () ()
52+createOrReplaceView =
53+ createViewGeneric CreateOrReplace
54+
55+
56+createViewGeneric :: Selects names exprs
57+ => CreateView -> TableSchema names -> Query exprs -> Hasql.Statement () ()
58+createViewGeneric replace schema query =
59+ Hasql.Statement bytes params decode prepare
3860 where
3961 bytes = encodeUtf8 (Text.pack sql)
4062 params = Hasql.noParams
4163 decode = Hasql.noResult
4264 prepare = False
4365 sql = show doc
44− doc = ppCreateView schema query
66+ doc = ppCreateView schema query replace
4567
4668
4769ppCreateView :: Selects names exprs
48− => TableSchema names -> Query exprs -> Doc
49−ppCreateView schema query =
50− text "CREATE VIEW" <+>
70+ => TableSchema names -> Query exprs -> CreateView -> Doc
71+ppCreateView schema query replace =
72+ createOrReplace replace <+>
5173 ppInto schema $$
5274 text "AS" <+>
5375 ppSelect query
76+ where
77+ createOrReplace Create = text "CREATE VIEW"
78+ createOrReplace CreateOrReplace = text "CREATE OR REPLACE VIEW"
src/Rel8/Table/Opaleye.hs+28−46
@@ -28,17 +28,15 @@ where
2828-- base
2929import Data.Functor.Const ( Const( Const ), getConst )
3030import Data.List.NonEmpty ( NonEmpty )
31−import Prelude hiding ( undefined )
31+import Prelude
3232
3333-- opaleye
34+import qualified Opaleye.Adaptors as Opaleye
35+import qualified Opaleye.Field as Opaleye ( Field_ )
3436import qualified Opaleye.Internal.Aggregate as Opaleye
35−import qualified Opaleye.Internal.Binary as Opaleye
36−import qualified Opaleye.Internal.Distinct as Opaleye
3737import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
38−import qualified Opaleye.Internal.PackMap as Opaleye
39−import qualified Opaleye.Internal.Unpackspec as Opaleye
4038import qualified Opaleye.Internal.Values as Opaleye
41−import qualified Opaleye.Internal.Table as Opaleye
39+import qualified Opaleye.Table as Opaleye
4240
4341-- profunctors
4442import Data.Profunctor ( dimap, lmap )
@@ -48,27 +46,25 @@ import Rel8.Aggregate ( Aggregate( Aggregate ), Aggregates )
4846import Rel8.Expr ( Expr )
4947import Rel8.Expr.Opaleye
5048 ( fromPrimExpr, toPrimExpr
51− , traversePrimExpr
52− , fromColumn, toColumn
53− , scastExpr
49+ , scastExpr, traverseFieldP
5450 )
55−import Rel8.Schema.HTable ( htabulateA, hfield, htraverse, hspecs, htabulate )
51+import Rel8.Schema.HTable ( htabulateA, hfield, hspecs, htabulate,
52+ htraverseP, htraversePWithField )
5653import Rel8.Schema.Name ( Name( Name ), Selects, ppColumn )
5754import Rel8.Schema.Spec ( Spec(..) )
5855import Rel8.Schema.Table ( TableSchema(..), ppTable )
5956import Rel8.Table ( Table, fromColumns, toColumns )
60−import Rel8.Table.Undefined ( undefined )
57+import Rel8.Type.Information ( typeName )
6158
6259-- semigroupoids
6360import Data.Functor.Apply ( WrappedApplicative(..) )
61+import Data.Profunctor.Product ( ProductProfunctor )
6462
6563
6664aggregator :: Aggregates aggregates exprs => Opaleye.Aggregator aggregates exprs
67−aggregator = Opaleye.Aggregator $ Opaleye.PackMap $ \f aggregates ->
68− fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->
69− WrapApplicative $ case hfield (toColumns aggregates) field of
70− Aggregate (Opaleye.Aggregator (Opaleye.PackMap inner)) ->
71− inner f ()
65+aggregator = dimap toColumns fromColumns $
66+ htraverseP $
67+ lmap (\(Aggregate a) -> (a, ())) Opaleye.aggregatorApply
7268
7369
7470attributes :: Selects names exprs => TableSchema names -> exprs
@@ -79,22 +75,19 @@ attributes schema@TableSchema {columns} = fromColumns $ htabulate $ \field ->
7975 show (ppTable schema) <> "." <> show (ppColumn column)
8076
8177
78+fromOpaleyespec :: (ProductProfunctor p, Table Expr a)
79+ => p (Opaleye.Field_ n x) (Opaleye.Field_ n x)
80+ -> p a a
81+fromOpaleyespec x =
82+ dimap toColumns fromColumns (htraverseP (traverseFieldP x))
83+
84+
8285binaryspec :: Table Expr a => Opaleye.Binaryspec a a
83−binaryspec = Opaleye.Binaryspec $ Opaleye.PackMap $ \f (as, bs) ->
84− fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->
85− WrapApplicative $
86− case (hfield (toColumns as) field, hfield (toColumns bs) field) of
87− (a, b) -> fromPrimExpr <$> f (toPrimExpr a, toPrimExpr b)
86+binaryspec = fromOpaleyespec Opaleye.binaryspecField
8887
8988
9089distinctspec :: Table Expr a => Opaleye.Distinctspec a a
91−distinctspec =
92− Opaleye.Distinctspec $ Opaleye.Aggregator $ Opaleye.PackMap $ \f ->
93− fmap fromColumns .
94− unwrapApplicative .
95− htraverse
96− (\a -> WrapApplicative $ fromPrimExpr <$> f (Nothing, toPrimExpr a)) .
97− toColumns
90+distinctspec = fromOpaleyespec Opaleye.distinctspecField
9891
9992
10093exprs :: Table Expr a => a -> NonEmpty Opaleye.PrimExpr
@@ -113,8 +106,8 @@ exprsWithNames names as = getConst $ htabulateA $ \field ->
113106table :: Selects names exprs => TableSchema names -> Opaleye.Table exprs exprs
114107table (TableSchema name schema columns) =
115108 case schema of
116− Nothing -> Opaleye.Table name (tableFields columns)
117− Just schemaName -> Opaleye.TableWithSchema schemaName name (tableFields columns)
109+ Nothing -> Opaleye.table name (tableFields columns)
110+ Just schemaName -> Opaleye.tableWithSchema schemaName name (tableFields columns)
118111
119112
120113tableFields :: Selects names exprs
@@ -126,21 +119,19 @@ tableFields (toColumns -> names) = dimap toColumns fromColumns $
126119 where
127120 go :: Name a -> Opaleye.TableFields (Expr a) (Expr a)
128121 go (Name name) =
129− dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $
122+ traverseFieldP $
130123 Opaleye.requiredTableField name
131124
132125
133126unpackspec :: Table Expr a => Opaleye.Unpackspec a a
134−unpackspec = Opaleye.Unpackspec $ Opaleye.PackMap $ \f ->
135− fmap fromColumns .
136− unwrapApplicative .
137− htraverse (WrapApplicative . traversePrimExpr f) .
138− toColumns
127+unpackspec = fromOpaleyespec Opaleye.unpackspecField
139128{-# INLINABLE unpackspec #-}
140129
141130
142131valuesspec :: Table Expr a => Opaleye.Valuesspec a a
143−valuesspec = Opaleye.ValuesspecSafe (toPackMap undefined) unpackspec
132+valuesspec = dimap toColumns fromColumns $
133+ htraversePWithField (traverseFieldP . Opaleye.valuesspecFieldType . typeName)
134+ where typeName = Rel8.Type.Information.typeName . info . hfield hspecs
144135
145136
146137view :: Selects names exprs => names -> exprs
@@ -149,15 +140,6 @@ view columns = fromColumns $ htabulate $ \field ->
149140 Name column -> fromPrimExpr $ Opaleye.BaseTableAttrExpr column
150141
151142
152−toPackMap :: Table Expr a
153− => a -> Opaleye.PackMap Opaleye.PrimExpr Opaleye.PrimExpr () a
154−toPackMap as = Opaleye.PackMap $ \f () ->
155− fmap fromColumns $
156− unwrapApplicative .
157− htraverse (WrapApplicative . traversePrimExpr f) $
158− toColumns as
159−
160−
161143-- | Transform a table by adding 'CAST' to all columns. This is most useful for
162144-- finalising a SELECT or RETURNING statement, guaranteed that the output
163145-- matches what is encoded in each columns TypeInformation.
src/Rel8/Table/These.hs+14−3
@@ -20,6 +20,7 @@ module Rel8.Table.These
2020 , isThisTable, isThatTable, isThoseTable
2121 , hasHereTable, hasThereTable
2222 , justHereTable, justThereTable
23+ , alignMaybeTable
2324 , aggregateTheseTable
2425 , nameTheseTable
2526 )
@@ -29,13 +30,13 @@ where
2930import Data.Bifunctor ( Bifunctor, bimap )
3031import Data.Kind ( Type )
3132import Data.Maybe ( isJust )
32−import Prelude hiding ( undefined )
33+import Prelude hiding ( null, undefined )
3334
3435-- rel8
3536import Rel8.Aggregate ( Aggregate )
3637import Rel8.Expr ( Expr )
37−import Rel8.Expr.Bool ( (&&.), not_ )
38−import Rel8.Expr.Null ( isNonNull )
38+import Rel8.Expr.Bool ( (&&.), (||.), boolExpr, not_ )
39+import Rel8.Expr.Null ( null, isNonNull )
3940import Rel8.Kind.Context ( Reifiable )
4041import Rel8.Schema.Context.Nullify ( Nullifiable )
4142import Rel8.Schema.Dict ( Dict( Dict ) )
@@ -288,6 +289,16 @@ justThereTable :: TheseTable context a b -> MaybeTable context b
288289justThereTable = there
289290
290291
292+-- | Construct a @TheseTable@ from two 'MaybeTable's.
293+alignMaybeTable :: ()
294+ => MaybeTable Expr a
295+ -> MaybeTable Expr b
296+ -> MaybeTable Expr (TheseTable Expr a b)
297+alignMaybeTable a b = MaybeTable tag (pure (TheseTable a b))
298+ where
299+ tag = boolExpr null mempty (isJustTable a ||. isJustTable b)
300+
301+
291302-- | Construct a @TheseTable@. Corresponds to 'This'.
292303thisTable :: Table Expr b => a -> TheseTable Expr a b
293304thisTable a = TheseTable (justTable a) nothingTable
src/Rel8/Table/Window.hsnew file+43
@@ -0,0 +1,43 @@
1+{-# language MonoLocalBinds #-}
2+
3+module Rel8.Table.Window
4+ ( cumulative
5+ , cumulative_
6+ , currentRow
7+ )
8+where
9+
10+-- base
11+import Prelude
12+
13+-- opaleye
14+import qualified Opaleye.Window as Opaleye
15+
16+-- rel8
17+import Rel8.Aggregate ( Aggregates )
18+import qualified Rel8.Expr.Window as Expr
19+import Rel8.Schema.HTable ( hfield, htabulateA )
20+import Rel8.Table ( fromColumns, toColumns )
21+import Rel8.Window ( Window( Window ) )
22+
23+
24+-- | 'cumulative' allows the use of aggregation functions in 'Window'
25+-- expressions. In particular, @'cumulative' 'Rel8.sum'@
26+-- (when combined with 'Rel8.Window.orderPartitionBy') gives a running total,
27+-- also known as a \"cumulative sum\", hence the name @cumulative@.
28+cumulative :: Aggregates aggregates exprs => (a -> aggregates) -> Window a exprs
29+cumulative f =
30+ fmap fromColumns $
31+ htabulateA $ \field ->
32+ Expr.cumulative ((`hfield` field) . toColumns . f)
33+
34+
35+-- | A version of 'cumulative' for use with nullary aggregators like
36+-- 'Rel8.Expr.Aggregate.countStar'.
37+cumulative_ :: Aggregates aggregates exprs => aggregates -> Window a exprs
38+cumulative_ = cumulative . const
39+
40+
41+-- | Return every column of the current row of a window query.
42+currentRow :: Window a a
43+currentRow = Window $ Opaleye.over (Opaleye.noWindowFunction id) mempty mempty
src/Rel8/Tabulate.hs+2−1
@@ -93,6 +93,7 @@ import Rel8.Query.Filter ( where_ )
9393import Rel8.Query.List ( catNonEmptyTable )
9494import qualified Rel8.Query.Maybe as Q ( optional )
9595import Rel8.Query.Opaleye ( mapOpaleye, unsafePeekQuery )
96+import Rel8.Query.Rebind ( rebind )
9697import Rel8.Query.These ( alignBy )
9798import Rel8.Table ( Table, fromColumns, toColumns )
9899import Rel8.Table.Aggregate ( hgroupBy, listAgg, nonEmptyAgg )
@@ -508,8 +509,8 @@ alignWith :: EqTable k
508509 -> Tabulation k a -> Tabulation k b -> Tabulation k c
509510alignWith f (Tabulation as) (Tabulation bs) = Tabulation $ \p -> do
510511 tkab <- liftF2 (alignBy condition) as bs p
512+ k <- traverse (rebind "key") $ recover $ bimap fst fst tkab
511513 let
512− k = recover $ bimap fst fst tkab
513514 tab = bimap snd snd tkab
514515 pure (k, f tab)
515516 where
src/Rel8/Window.hsnew file+97
@@ -0,0 +1,97 @@
1+{-# language DerivingVia #-}
2+{-# language FlexibleContexts #-}
3+{-# language GeneralizedNewtypeDeriving #-}
4+{-# language ScopedTypeVariables #-}
5+{-# language StandaloneKindSignatures #-}
6+{-# language TypeApplications #-}
7+
8+module Rel8.Window
9+ ( Window(..)
10+ , Partition
11+ , over
12+ , partitionBy
13+ , orderPartitionBy
14+ )
15+where
16+
17+-- base
18+import Data.Functor.Const ( Const( Const ), getConst )
19+import Data.Functor.Contravariant ( Contravariant, contramap )
20+import Data.Kind ( Type )
21+import Prelude
22+
23+-- opaleye
24+import qualified Opaleye.Internal.Window as Opaleye
25+import qualified Opaleye.Internal.PackMap as Opaleye
26+
27+-- profunctors
28+import Data.Profunctor ( Profunctor )
29+
30+-- product-profunctors
31+import Data.Profunctor.Product ( ProductProfunctor, (****), purePP )
32+
33+-- rel8
34+import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )
35+import Rel8.Order( Order( Order ) )
36+import Rel8.Schema.HTable ( hfield, htabulateA )
37+import Rel8.Table ( Columns, toColumns )
38+import Rel8.Table.Eq ( EqTable )
39+
40+-- semigroupoids
41+import Data.Functor.Apply ( Apply, WrappedApplicative(..) )
42+
43+
44+-- | 'Window' is an applicative functor that represents expressions that
45+-- contain
46+-- [window functions](https://www.postgresql.org/docs/current/tutorial-window.html).
47+-- 'Rel8.Query.Window.window' can be used to
48+-- evaluate these expressions over a particular query.
49+type Window :: Type -> Type -> Type
50+newtype Window a b = Window (Opaleye.Windows a b)
51+ deriving newtype (Profunctor)
52+ deriving newtype (Functor, Applicative)
53+ deriving (Apply) via (WrappedApplicative (Window a))
54+
55+
56+instance ProductProfunctor Window where
57+ purePP = pure
58+ (****) = (<*>)
59+
60+
61+-- | In PostgreSQL, window functions must specify the \"window\" or
62+-- \"partition\" over which they operate. The syntax for this looks like:
63+-- @SUM(salary) OVER (PARTITION BY department)@. The Rel8 type 'Partition'
64+-- represents everything that comes after @OVER@.
65+--
66+-- 'Partition' is a 'Monoid', so 'Window's created with 'partitionBy' and
67+-- 'orderWindowBy' can be combined using '<>'.
68+type Partition :: Type -> Type
69+newtype Partition a = Partition (Opaleye.Window a)
70+ deriving newtype (Contravariant, Semigroup, Monoid)
71+
72+
73+-- | 'over' adds a 'Partition' to a 'Window' expression.
74+--
75+-- @@@
76+-- 'Rel8.Table.Window.cumulative' ('Rel8.Expr.Aggregate.sum' . salary) `over` 'partitionBy' department <> 'orderPartitionBy' (salary >$< 'Rel8.desc')
77+-- @@@
78+over :: Window a b -> Partition a -> Window a b
79+over (Window (Opaleye.Windows (Opaleye.PackMap w))) (Partition p) =
80+ Window $ Opaleye.Windows $ Opaleye.PackMap $ \f ->
81+ w (\(o, p') -> f (o, p' <> p))
82+infixl 1 `over`
83+
84+
85+-- | Restricts a window function to operate only the group of rows that share
86+-- the same value(s) for the given expression(s).
87+partitionBy :: forall b a. EqTable b => (a -> b) -> Partition a
88+partitionBy f =
89+ Partition $ contramap (toColumns . f) $ getConst $
90+ htabulateA @(Columns b) $ \field ->
91+ Const $ Opaleye.partitionBy (toColumn . toPrimExpr . (`hfield` field))
92+
93+
94+-- | Controls the order in which rows are processed by window functions. This
95+-- does not need to match the ordering of the overall query.
96+orderPartitionBy :: Order a -> Partition a
97+orderPartitionBy (Order ordering) = Partition $ Opaleye.orderPartitionBy ordering
tests/Rel8/Generic/Rel8able/Test.hs+10−1
@@ -5,6 +5,7 @@
55{-# language DuplicateRecordFields #-}
66{-# language FlexibleInstances #-}
77{-# language MultiParamTypeClasses #-}
8+{-# language StandaloneKindSignatures #-}
89{-# language TypeFamilies #-}
910{-# language UndecidableInstances #-}
1011
@@ -171,9 +172,17 @@ data NestedTableTestB f = NestedTableTestB
171172 deriving anyclass Rel8able
172173
173174
174−
175175newtype IdRecord a f = IdRecord { recordId :: Column f a }
176176 deriving stock Generic
177177
178178
179179instance DBType a => Rel8able (IdRecord a)
180+
181+
182+type Nest :: KRel8able -> KRel8able -> KRel8able
183+data Nest t u f = Nest
184+ { foo :: t f
185+ , bar :: u f
186+ }
187+ deriving stock Generic
188+ deriving anyclass Rel8able