on master help sign in
56 files changed+1277−311
since splitsnapshots
unifiedsplit
.github/workflows/build.yaml+1−1 Changelog.md+56 cabal.project.haskell-nix−7 default.nix+1−1 docs/cookbook.rst+9−7 nix/sources.json+9−9 nix/sources.nix+21−1 rel8.cabal+13−4 shell.nix+1−1 src/Rel8.hs+268−6 src/Rel8/Aggregate.hs+11−19 src/Rel8/Column/Null.hs+26 src/Rel8/Expr/Aggregate.hs+25−64 src/Rel8/Expr/Num.hs+39−6 src/Rel8/Expr/Opaleye.hs+12−3 src/Rel8/Expr/Sequence.hs+2−1 src/Rel8/Expr/Text.hs+23−2 src/Rel8/Expr/Window.hs+121 src/Rel8/Generic/Record.hs+1 src/Rel8/Generic/Rel8able.hs+6−1 src/Rel8/Order.hs+1−8 src/Rel8/Query.hs+23−10 src/Rel8/Query/Aggregate.hs+19 src/Rel8/Query/Distinct.hs+5−10 src/Rel8/Query/Exists.hs+1−1 src/Rel8/Query/Indexed.hs+5−18 src/Rel8/Query/Null.hs+15 src/Rel8/Query/Opaleye.hs+11−11 src/Rel8/Query/Rebind.hs+5−13 src/Rel8/Query/Set.hs+6−6 src/Rel8/Query/These.hs+8−8 src/Rel8/Query/Window.hs+26 src/Rel8/Schema/HTable.hs+29−2 src/Rel8/Schema/HTable/Vectorize.hs+2−1 src/Rel8/Schema/Table.hs+3 src/Rel8/Statement/Select.hs+5−3 src/Rel8/Statement/View.hs+30−5 src/Rel8/Table/Aggregate.hs+12 src/Rel8/Table/HKD.hs+1 src/Rel8/Table/Maybe.hs+6 src/Rel8/Table/Null.hs+147 src/Rel8/Table/Nullify.hs+27 src/Rel8/Table/Opaleye.hs+31−47 src/Rel8/Table/Ord.hs+2−2 src/Rel8/Table/These.hs+14−3 src/Rel8/Table/Window.hs+43 src/Rel8/Tabulate.hs+23−20 src/Rel8/Type.hs+8−8 src/Rel8/Type/Enum.hs+1 src/Rel8/Type/JSONBEncoded.hs+4 src/Rel8/Type/JSONEncoded.hs+4 src/Rel8/Type/Num.hs+4−1 src/Rel8/Type/ReadShow.hs+3 src/Rel8/Type/Tag.hs+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+56
@@ -1,3 +1,59 @@
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+
24+# 1.3.1.0 (2022-01-20)
25+
26+## Other
27+
28+* Rel8 now requires Opaleye >= 0.9.1. ([#165](https://github.com/circuithub/rel8/pull/165))
29+
30+# 1.3.0.0 (2022-01-31)
31+
32+## Breaking changes
33+
34+* `div` and `mod` have been changed to match Haskell semantics. If you need the PostgreSQL `div()` and `mod()` functions, use `quot` and `rem`. While this is not an API change, we feel this is a breaking change in semantics and have bumped the major version number. ([#155](https://github.com/circuithub/rel8/pull/155))
35+
36+## New features
37+
38+* `divMod` and `quotRem` functions have been added, matching Haskell's `Prelude` functions. ([#155](https://github.com/circuithub/rel8/pull/155))
39+* `avg` and `mode` aggregation functions to find the mean value of an expression, or the most common row in a query, respectively. ([#152](https://github.com/circuithub/rel8/pull/152))
40+* The full `EqTable` and `OrdTable` classes have been exported, allowing for instances to be manually created. ([#157](https://github.com/circuithub/rel8/pull/157))
41+* Added `like` and `ilike` (for the `LIKE` and `ILIKE` operators). ([#146](https://github.com/circuithub/rel8/pull/146))
42+
43+## Other
44+
45+* Rel8 now requires Opaleye 0.9. ([#158](https://github.com/circuithub/rel8/pull/158))
46+* Rel8's test suite supports Hedgehog 1.1. ([#160](https://github.com/circuithub/rel8/pull/160))
47+* The documentation for binary operations has been corrected. ([#162](https://github.com/circuithub/rel8/pull/162))
48+
49+# 1.2.2.0 (2021-11-21)
50+
51+## Other
52+
53+* Support GHC 9.2 ([#145](https://github.com/circuithub/rel8/pull/145))
54+* Correct the documentation for `except` ([#147](https://github.com/circuithub/rel8/pull/147))
55+* Support `hasql` 1.5 ([#149](https://github.com/circuithub/rel8/pull/149))
56+
157# 1.2.1.0 (2021-11-21)
258
359## New features
cabal.project.haskell-nix−7
@@ -2,10 +2,3 @@
22-- will interpret them as local packages, and try to build them when we cabal
33-- build. The only reason we have to specify these is for Haskell.nix to know to
44-- override these packages by fetching them rather than using Hackage.
5−
6−source-repository-package
7− type: git
8− location: https://github.com/patrickt/haskell-hedgehog
9− tag: 94dd5b81e46d4a636521acf08039c8e3d848ef37
10− subdir: hedgehog
11− --sha256: 1iaza4hjq1897bchb6i6adk7hggbald18ahbn1fn9pkw5imsy2a7
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
docs/cookbook.rst+9−7
@@ -142,23 +142,25 @@ rows, but can also return *tree*\s.
142142To understand what this means, we'll consider a small example query for blog
143143posts. We want our query to return:
144144
145−1. The latest 5 blog posts.
145+1. The latest 5 blog posts that have at least one tag each.
1461462. For each blog post, all tags.
147−3. For each blog post, the latest 3 comments.
147+3. For each blog post, the latest 3 comments if they exist.
148148
149149In Rel8, we can write this query as::
150150
151151 latestBlogPosts = do
152152 post <- each postSchema
153153
154− tags <- aggregate do
154+ -- Returns a `NonEmptyTable a` which ends up as a `Data.List.NonEmpty a` after the query is run
155+ tags <- some $ do
155156 tag <- each tagSchema
156157 where_ (tagPostId tag ==. postId post)
157− return (listAgg (tagName tag))
158+ return (tagName tag)
158159
159− latestComments <-
160− many $
161− limit 3 $
160+ -- Returns a `ListTable a` which ends up as a `[a]` after the query is run
161+ latestComments <-
162+ many $
163+ limit 3 $
162164 orderBy (commentCreatedAt >$< desc) do
163165 comment <- each commentSchema
164166 where_ (commentPostId comment ==. postId post)
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": "390926776d35a889852c6de9312661511fade9ed",
9− "sha256": "1dbvpkk0bgg3cirihzwj1s0m6xvjz66rw954ah8661bq96qlfqbr",
8+ "rev": "0837156c56cb5350dd9bd84eb424187e00aa1e8a",
9+ "sha256": "1djmv5a0vfj78csw2cad6nicrs8iqrp928b9b3v4h7lwwhhzliwl",
1010 "type": "tarball",
11− "url": "https://github.com/input-output-hk/haskell.nix/archive/390926776d35a889852c6de9312661511fade9ed.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+13−4
@@ -1,6 +1,6 @@
11cabal-version: 2.0
22name: rel8
3−version: 1.2.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
30− , opaleye ^>= 0.8.0.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
@@ -46,6 +46,7 @@ library
4646 -Wno-missing-import-lists -Wno-prepositive-qualified-module
4747 -Wno-monomorphism-restriction
4848 -Wno-missing-local-signatures
49+ -Wno-missing-kind-signatures
4950 hs-source-dirs:
5051 src
5152 exposed-modules:
@@ -65,6 +66,7 @@ library
6566 Rel8.Column.List
6667 Rel8.Column.Maybe
6768 Rel8.Column.NonEmpty
69+ Rel8.Column.Null
6870 Rel8.Column.These
6971
7072 Rel8.Expr
@@ -80,6 +82,7 @@ library
8082 Rel8.Expr.Order
8183 Rel8.Expr.Sequence
8284 Rel8.Expr.Serialize
85+ Rel8.Expr.Window
8386
8487 Rel8.FCF
8588
@@ -118,6 +121,7 @@ library
118121 Rel8.Query.SQL
119122 Rel8.Query.These
120123 Rel8.Query.Values
124+ Rel8.Query.Window
121125
122126 Rel8.Schema.Context.Nullify
123127 Rel8.Schema.Dict
@@ -166,6 +170,7 @@ library
166170 Rel8.Table.Maybe
167171 Rel8.Table.Name
168172 Rel8.Table.NonEmpty
173+ Rel8.Table.Null
169174 Rel8.Table.Nullify
170175 Rel8.Table.Opaleye
171176 Rel8.Table.Ord
@@ -176,6 +181,7 @@ library
176181 Rel8.Table.These
177182 Rel8.Table.Transpose
178183 Rel8.Table.Undefined
184+ Rel8.Table.Window
179185
180186 Rel8.Type
181187 Rel8.Type.Array
@@ -194,6 +200,9 @@ library
194200 Rel8.Type.Sum
195201 Rel8.Type.Tag
196202
203+ Rel8.Window
204+
205+
197206test-suite tests
198207 type: exitcode-stdio-1.0
199208 build-depends:
@@ -203,7 +212,7 @@ test-suite tests
203212 , containers
204213 , hasql
205214 , hasql-transaction
206− , hedgehog ^>=1.0.2
215+ , hedgehog ^>= 1.0 || ^>= 1.1
207216 , mmorph
208217 , rel8
209218 , scientific
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+268−6
@@ -38,6 +38,7 @@ module Rel8
3838 , HMaybe
3939 , HList
4040 , HNonEmpty
41+ , HNull
4142 , HThese
4243 , Lift
4344
@@ -46,8 +47,8 @@ module Rel8
4647 , Transposes
4748 , AltTable((<|>:))
4849 , AlternativeTable( emptyTable )
49− , EqTable, (==:), (/=:)
50− , OrdTable, (<:), (<=:), (>:), (>=:), ascTable, descTable, greatest, least
50+ , EqTable(..), (==:), (/=:)
51+ , OrdTable(..), (<:), (<=:), (>:), (>=:), ascTable, descTable, greatest, least
5152 , lit
5253 , bool
5354 , case_
@@ -57,6 +58,7 @@ module Rel8
5758 , MaybeTable
5859 , maybeTable, ($?), nothingTable, justTable
5960 , isNothingTable, isJustTable
61+ , fromMaybeTable
6062 , optional
6163 , catMaybeTable
6264 , traverseMaybeTable
@@ -79,6 +81,7 @@ module Rel8
7981 , isThisTable, isThatTable, isThoseTable
8082 , hasHereTable, hasThereTable
8183 , justHereTable, justThereTable
84+ , alignMaybeTable
8285 , alignBy
8386 , keepHereTable, loseHereTable
8487 , keepThereTable, loseThereTable
@@ -107,14 +110,37 @@ module Rel8
107110 , catNonEmptyTable
108111 , catNonEmpty
109112
110− -- ** @ADT@
113+ -- ** @NullTable@
114+ , NullTable
115+ , nullableTable, nullTable, nullifyTable
116+ , isNullTable, isNonNullTable
117+ , catNullTable
118+ , nameNullTable
119+ , toNullTable, toMaybeTable
120+
121+ -- ** Algebraic data types / sum types
122+ -- $adts
123+
124+ -- *** Naming of ADTs
125+ -- $naming
126+ , NameADT, nameADT
111127 , ADT, ADTable
128+
129+ -- *** Deconstruction of ADTs
130+ -- $deconstruction
131+ , DeconstructADT, deconstructADT
132+
133+ -- *** Construction of ADTs
134+ -- $construction
112135 , BuildADT, buildADT
113136 , ConstructADT, constructADT
114− , DeconstructADT, deconstructADT
115− , NameADT, nameADT
137+
138+ -- *** Other ADT operations
116139 , AggregateADT, aggregateADT
117140
141+ -- *** Miscellaneous notes
142+ -- $misc-notes
143+
118144 -- ** @HKD@
119145 , HKD, HKDable
120146 , BuildHKD, buildHKD
@@ -139,6 +165,7 @@ module Rel8
139165 -- ** @null@
140166 , NotNull
141167 , Nullable
168+ , Homonullable
142169 , null
143170 , nullify
144171 , nullable
@@ -157,6 +184,7 @@ module Rel8
157184 , (==.), (/=.), (==?), (/=?)
158185 , in_
159186 , boolExpr, caseExpr
187+ , like, ilike
160188
161189 -- ** Ordering
162190 , DBOrd
@@ -225,10 +253,11 @@ module Rel8
225253 , countRows
226254 , groupBy
227255 , listAgg, listAggExpr
256+ , mode
228257 , nonEmptyAgg, nonEmptyAggExpr
229258 , DBMax, max
230259 , DBMin, min
231− , DBSum, sum, sumWhere
260+ , DBSum, sum, sumWhere, avg
232261 , DBString, stringAgg
233262 , count
234263 , countStar
@@ -246,6 +275,26 @@ module Rel8
246275 , nullsLast
247276
248277 -- ** 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
249298 , indexed
250299
251300 -- ** Bindings
@@ -285,6 +334,7 @@ module Rel8
285334
286335 -- ** @CREATE VIEW@
287336 , createView
337+ , createOrReplaceView
288338
289339 -- ** Sequences
290340 , nextval
@@ -303,6 +353,7 @@ import Rel8.Column.Lift
303353import Rel8.Column.List
304354import Rel8.Column.Maybe
305355import Rel8.Column.NonEmpty
356+import Rel8.Column.Null
306357import Rel8.Column.These
307358import Rel8.Expr
308359import Rel8.Expr.Aggregate
@@ -316,6 +367,8 @@ import Rel8.Expr.Ord
316367import Rel8.Expr.Order
317368import Rel8.Expr.Serialize
318369import Rel8.Expr.Sequence
370+import Rel8.Expr.Text ( like, ilike )
371+import Rel8.Expr.Window hiding ( cumulative )
319372import Rel8.Generic.Rel8able ( KRel8able, Rel8able )
320373import Rel8.Order
321374import Rel8.Query
@@ -337,6 +390,7 @@ import Rel8.Query.SQL (showQuery)
337390import Rel8.Query.Set
338391import Rel8.Query.These
339392import Rel8.Query.Values
393+import Rel8.Query.Window
340394import Rel8.Schema.Field
341395import Rel8.Schema.HTable
342396import Rel8.Schema.Name
@@ -363,6 +417,7 @@ import Rel8.Table.List
363417import Rel8.Table.Maybe
364418import Rel8.Table.Name
365419import Rel8.Table.NonEmpty
420+import Rel8.Table.Null
366421import Rel8.Table.Opaleye ( castTable )
367422import Rel8.Table.Ord
368423import Rel8.Table.Order
@@ -371,6 +426,7 @@ import Rel8.Table.Rel8able ()
371426import Rel8.Table.Serialize
372427import Rel8.Table.These
373428import Rel8.Table.Transpose
429+import Rel8.Table.Window
374430import Rel8.Type
375431import Rel8.Type.Composite
376432import Rel8.Type.Eq
@@ -385,6 +441,7 @@ import Rel8.Type.ReadShow
385441import Rel8.Type.Semigroup
386442import Rel8.Type.String
387443import Rel8.Type.Sum
444+import Rel8.Window
388445
389446
390447-- $running
@@ -392,3 +449,208 @@ import Rel8.Type.Sum
392449-- provides 'select', 'insert', 'update' and 'delete' functions. Note that
393450-- 'insert', 'update' and 'delete' will generally need the
394451-- `DuplicateRecordFields` language extension enabled.
452+
453+-- $adts
454+-- Algebraic data types can be modelled between Haskell and SQL.
455+--
456+-- * Your SQL table needs a certain text field that tags which Haskell constructor is in use.
457+-- * You have to use a few combinators to specify the sum type's individual constructors.
458+-- * If you want to do case analysis at the @Expr@ (SQL) level, you can use 'maybe'/'either'-like eliminators.
459+--
460+-- The documentation in this section will assume a set of database types like this:
461+--
462+-- @
463+-- data Thing f = ThingEmployer (Employer f) | ThingPotato (Potato f) | Nullary
464+-- deriving stock Generic
465+--
466+-- data Employer f = Employer { employerId :: f Int32, employerName :: f Text}
467+-- deriving stock Generic
468+-- deriving anyclass Rel8able
469+--
470+-- data Potato f = Potato { size :: f Int32, grower :: f Text }
471+-- deriving stock Generic
472+-- deriving anyclass Rel8able
473+-- @
474+
475+-- $naming
476+--
477+-- First, in your 'TableSchema', name your type like this:
478+--
479+-- @
480+-- thingSchema :: TableSchema (ADT Thing Name)
481+-- thingSchema =
482+-- TableSchema
483+-- { schema = Nothing,
484+-- name = \"thing\",
485+-- columns =
486+-- nameADT @Thing
487+-- \"tag\"
488+-- Employer
489+-- { employerName = \"name\",
490+-- employerId = \"id\"
491+-- }
492+-- Potato {size = \"size\", grower = \"Mary\"}
493+-- }
494+-- @
495+--
496+-- Note that @nameADT \@Thing "tag"@ is variadic: it accepts one
497+-- argument per constructor, except the nullary ones (Nullary) because
498+-- there's nothing to do for them.
499+
500+-- $deconstruction
501+--
502+-- To deconstruct sum types at the SQL level, use 'deconstructADT',
503+-- which is also variadic, and has one argument for each
504+-- constructor. Similar to 'maybe'.
505+--
506+-- @
507+-- query :: Query (ADT Thing Expr)
508+-- query = do
509+-- thingExpr <- each thingSchema
510+-- where_ $
511+-- deconstructADT @Thing
512+-- (\employer -> employerName employer ==. lit \"Mary\")
513+-- (\potato -> grower potato ==. lit \"Mary\")
514+-- (lit False) -- Nullary case
515+-- thingExpr
516+-- pure thingExpr
517+-- @
518+--
519+-- SQL output:
520+--
521+-- @
522+-- SELECT
523+-- CAST("tag0_1" AS text) as "tag",
524+-- CAST("id1_1" AS int4) as "ThingEmployer/_1/employerId",
525+-- CAST("name2_1" AS text) as "ThingEmployer/_1/employerName",
526+-- CAST("size3_1" AS int4) as "ThingPotato/_1/size",
527+-- CAST("Mary4_1" AS text) as "ThingPotato/_1/grower"
528+-- FROM (SELECT
529+-- *
530+-- FROM (SELECT
531+-- "tag" as "tag0_1",
532+-- "id" as "id1_1",
533+-- "name" as "name2_1",
534+-- "size" as "size3_1",
535+-- "Mary" as "Mary4_1"
536+-- FROM "thing" as "T1") as "T1"
537+-- WHERE (CASE WHEN ("tag0_1") = (CAST(E'ThingPotato' AS text)) THEN ("Mary4_1") = (CAST(E'Mary' AS text))
538+-- WHEN ("tag0_1") = (CAST(E'Nullary' AS text)) THEN CAST(FALSE AS bool) ELSE ("name2_1") = (CAST(E'Mary' AS text)) END)) as "T1"
539+-- @
540+
541+-- $construction
542+--
543+-- To construct an ADT, you can use 'buildADT' or 'constructADT'. Consider the following type:
544+--
545+-- @
546+-- data Task f = Pending | Complete (CompletedTask f)
547+-- @
548+--
549+-- 'buildADT' is for constructing values of 'Task' in the 'Expr'
550+-- context. 'buildADT' needs two type-level arguments before its type
551+-- makes any sense. The first argument is the type of the "ADT", which
552+-- in our case is 'Task'. The second is the name of the constructor we
553+-- want to use. So that means we have the following possible
554+-- instantiations of 'buildADT' for 'Task':
555+--
556+-- @
557+-- > :t buildADT @Task @\"Pending\"
558+-- buildADT @Task @\"Pending\" :: ADT Task Expr
559+-- > :t buildADT @Task @\"Complete\"
560+-- buildADT @Task @\"Complete\" :: CompletedTask Expr -> ADT Task Expr
561+-- @
562+--
563+-- Note that as the "Pending" constructor has no fields, @buildADT
564+-- \@Task \@"Pending"@ is equivalent to @lit Pending@. But @buildADT
565+-- \@Task \@"Complete"@ is not the same as @lit . Complete@:
566+--
567+-- @
568+-- > :t lit . Complete
569+-- lit . Complete :: CompletedTask Result -> ADT Task Expr
570+-- @
571+--
572+--
573+-- Note that the former takes a @CompletedTask Expr@ while the latter
574+-- takes a @CompletedTask Result@. The former is more powerful because
575+-- you can construct @Task@s using dynamic values coming a database
576+-- query.
577+--
578+-- To show what this can look like in SQL, consider:
579+--
580+-- @
581+-- > :{
582+-- showQuery $ values
583+-- [ buildADT @Task @\"Pending\"
584+-- , buildADT @Task @\"Complete\" CompletedTask {date = Rel8.Expr.Time.now}
585+-- ]
586+-- :}
587+-- @
588+--
589+-- This produces the following SQL:
590+--
591+-- @
592+-- SELECT
593+-- CAST(\"values0_1\" AS text) as \"tag\",
594+-- CAST(\"values1_1\" AS timestamptz) as \"Complete/_1/date\"
595+-- FROM (SELECT
596+-- *
597+-- FROM (SELECT \"column1\" as \"values0_1\",
598+-- \"column2\" as \"values1_1\"
599+-- FROM
600+-- (VALUES
601+-- (CAST(E'Pending' AS text),CAST(NULL AS timestamptz)),
602+-- (CAST(E'Complete' AS text),CAST(now() AS timestamptz))) as \"V\") as \"T1\") as \"T1\"
603+-- @
604+--
605+-- This is what you get if you run it in @psql@:
606+--
607+--
608+-- @
609+-- tag | Complete/_1/date
610+-- ----------+-------------------------------
611+-- Pending |
612+-- Complete | 2022-05-19 21:28:23.969065+00
613+-- (2 rows)
614+-- @
615+--
616+-- "constructADT" is less convenient but more general alternative to
617+-- "buildADT". It requires only one type-level argument for its type
618+-- to make sense:
619+--
620+-- @
621+-- > :t constructADT @Task
622+-- constructADT @Task
623+-- :: (forall r. r -> (CompletedTask Expr -> r) -> r) -> ADT Task Expr
624+-- @
625+--
626+-- This might still seem a bit opaque, but basically it gives you a
627+-- Church-encoded constructor for arbitrary algebraic data types. You
628+-- might use it as follows:
629+--
630+-- @
631+-- let
632+-- pending :: ADT Task Expr
633+-- pending = constructADT @Task $ \pending _complete -> pending
634+--
635+-- complete :: ADT Task Expr
636+-- complete = constructADT @Task $ \_pending complete -> complete CompletedTask {date = Rel8.Expr.Time.now}
637+-- @
638+--
639+-- These values are otherwise identical to the ones we saw above with
640+-- @buildADT@, it's just a different style of constructing them.
641+--
642+
643+-- $misc-notes
644+--
645+-- 1. Note that the order of the arguments for all of these functions
646+-- is determined by the order of the constructors in the data
647+-- definition. If it were @data Task = Complete (CompletedTask f) |
648+-- Pending@ then the order of all the invocations of @constructADT@
649+-- and @deconstructADT@ would need to change.
650+--
651+-- 2. Maybe this is obvious, but just to spell it out: once you're in
652+-- the @Result@ context, you can of course construct @Task@ values
653+-- normally and use standard Haskell pattern-matching. @constructADT@
654+-- and @deconstructADT@ are specifically only needed in the @Expr@
655+-- context, and they allow you to do the equivalent of pattern
656+-- matching in PostgreSQL.
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/Column/Null.hsnew file+26
@@ -0,0 +1,26 @@
1+{-# language DataKinds #-}
2+{-# language StandaloneKindSignatures #-}
3+{-# language TypeFamilyDependencies #-}
4+
5+module Rel8.Column.Null
6+ ( HNull
7+ )
8+where
9+
10+-- base
11+import Data.Kind ( Type )
12+import Prelude
13+
14+-- rel8
15+import qualified Rel8.Schema.Kind as K
16+import Rel8.Schema.Result ( Result )
17+import Rel8.Table.Null ( NullTable )
18+
19+
20+-- | Nest a 'Null' value within a 'Rel8able'. @HNull f a@ will produce a
21+-- 'NullTable' @a@ in the 'Expr' context, and a @'Maybe' a@ in the 'Result'
22+-- context.
23+type HNull :: K.Context -> Type -> Type
24+type family HNull context = maybe | maybe -> context where
25+ HNull Result = Maybe
26+ HNull context = NullTable context
src/Rel8/Expr/Aggregate.hs+25−64
@@ -10,6 +10,7 @@ module Rel8.Expr.Aggregate
1010 , and, or
1111 , min, max
1212 , sum, sumWhere
13+ , avg
1314 , stringAgg
1415 , groupByExpr
1516 , listAggExpr, nonEmptyAggExpr
@@ -23,10 +24,12 @@ import Data.List.NonEmpty ( NonEmpty )
2324import Prelude hiding ( and, max, min, null, or, sum )
2425
2526-- opaleye
26−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
2730
2831-- rel8
29−import Rel8.Aggregate ( Aggregate, Aggregator(..), unsafeMakeAggregate )
32+import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )
3033import Rel8.Expr ( Expr )
3134import Rel8.Expr.Bool ( caseExpr )
3235import Rel8.Expr.Opaleye
@@ -50,23 +53,13 @@ import Rel8.Type.Sum ( DBSum )
5053
5154-- | Count the occurances of a single column. Corresponds to @COUNT(a)@
5255count :: Expr a -> Aggregate Int64
53−count = unsafeMakeAggregate toPrimExpr fromPrimExpr $
54− Just Aggregator
55− { operation = Opaleye.AggrCount
56− , ordering = []
57− , distinction = Opaleye.AggrAll
58− }
59−
56+count = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.count
6057
6158-- | Count the number of distinct occurances of a single column. Corresponds to
6259-- @COUNT(DISTINCT a)@
6360countDistinct :: Sql DBEq a => Expr a -> Aggregate Int64
6461countDistinct = unsafeMakeAggregate toPrimExpr fromPrimExpr $
65− Just Aggregator
66− { operation = Opaleye.AggrCount
67− , ordering = []
68− , distinction = Opaleye.AggrDistinct
69− }
62+ Opaleye.distinctAggregator Opaleye.count
7063
7164
7265-- | Corresponds to @COUNT(*)@.
@@ -81,56 +74,39 @@ countWhere condition = count (caseExpr [(condition, litExpr (Just True))] null)
8174
8275-- | Corresponds to @bool_and@.
8376and :: Expr Bool -> Aggregate Bool
84−and = unsafeMakeAggregate toPrimExpr fromPrimExpr $
85− Just Aggregator
86− { operation = Opaleye.AggrBoolAnd
87− , ordering = []
88− , distinction = Opaleye.AggrAll
89− }
77+and = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolAnd
9078
9179
9280-- | Corresponds to @bool_or@.
9381or :: Expr Bool -> Aggregate Bool
94−or = unsafeMakeAggregate toPrimExpr fromPrimExpr $
95− Just Aggregator
96− { operation = Opaleye.AggrBoolOr
97− , ordering = []
98− , distinction = Opaleye.AggrAll
99− }
82+or = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.boolOr
10083
10184
10285-- | Produce an aggregation for @Expr a@ using the @max@ function.
10386max :: Sql DBMax a => Expr a -> Aggregate a
104−max = unsafeMakeAggregate toPrimExpr fromPrimExpr $
105− Just Aggregator
106− { operation = Opaleye.AggrMax
107− , ordering = []
108− , distinction = Opaleye.AggrAll
109− }
87+max = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMax
11088
11189
11290-- | Produce an aggregation for @Expr a@ using the @max@ function.
11391min :: Sql DBMin a => Expr a -> Aggregate a
114−min = unsafeMakeAggregate toPrimExpr fromPrimExpr $
115− Just Aggregator
116− { operation = Opaleye.AggrMin
117− , ordering = []
118− , distinction = Opaleye.AggrAll
119− }
92+min = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.unsafeMin
12093
12194-- | Corresponds to @sum@. Note that in SQL, @sum@ is type changing - for
12295-- example the @sum@ of @integer@ returns a @bigint@. Rel8 doesn't support
123−-- this, and will add explicit cast back to the original input type. This can
96+-- this, and will add explicit casts back to the original input type. This can
12497-- lead to overflows, and if you anticipate very large sums, you should upcast
12598-- your input.
12699sum :: Sql DBSum a => Expr a -> Aggregate a
127−sum = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $
128− Just Aggregator
129− { operation = Opaleye.AggrSum
130− , ordering = []
131− , distinction = Opaleye.AggrAll
132− }
100+sum = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) Opaleye.unsafeSum
101+
133102
103+-- | Corresponds to @avg@. Note that in SQL, @avg@ is type changing - for
104+-- example, the @avg@ of @integer@ returns a @numeric@. Rel8 doesn't support
105+-- this, and will add explicit casts back to the original input type. If you
106+-- need a fractional result on an integral column, you should cast your input
107+-- to 'Double' or 'Data.Scientific.Scientific' before calling 'avg'.
108+avg :: Sql DBSum a => Expr a -> Aggregate a
109+avg = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) Opaleye.unsafeAvg
134110
135111-- | Take the sum of all expressions that satisfy a predicate.
136112sumWhere :: (Sql DBNum a, Sql DBSum a)
@@ -142,17 +118,12 @@ sumWhere condition a = sum (caseExpr [(condition, a)] 0)
142118stringAgg :: Sql DBString a
143119 => Expr db -> Expr a -> Aggregate a
144120stringAgg delimiter =
145− unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $
146− Just Aggregator
147− { operation = Opaleye.AggrStringAggr (toPrimExpr delimiter)
148− , ordering = []
149− , distinction = Opaleye.AggrAll
150− }
121+ unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) (Opaleye.stringAgg (Column (toPrimExpr delimiter)))
151122
152123
153124-- | Aggregate a value by grouping by it.
154125groupByExpr :: Sql DBEq a => Expr a -> Aggregate a
155−groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Nothing
126+groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Opaleye.groupBy
156127
157128
158129-- | Collect expressions values as a list.
@@ -167,23 +138,13 @@ nonEmptyAggExpr = snonEmptyAggExpr typeInformation
167138
168139slistAggExpr :: ()
169140 => TypeInformation (Unnullify a) -> Expr a -> Aggregate [a]
170−slistAggExpr info = unsafeMakeAggregate to fromPrimExpr $ Just
171− Aggregator
172− { operation = Opaleye.AggrArr
173− , ordering = []
174− , distinction = Opaleye.AggrAll
175− }
141+slistAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg
176142 where
177143 to = encodeArrayElement info . toPrimExpr
178144
179145
180146snonEmptyAggExpr :: ()
181147 => TypeInformation (Unnullify a) -> Expr a -> Aggregate (NonEmpty a)
182−snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr $ Just
183− Aggregator
184− { operation = Opaleye.AggrArr
185− , ordering = []
186− , distinction = Opaleye.AggrAll
187− }
148+snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr Opaleye.arrayAgg
188149 where
189150 to = encodeArrayElement info . toPrimExpr
src/Rel8/Expr/Num.hs+39−6
@@ -4,18 +4,24 @@
44{-# options_ghc -fno-warn-redundant-constraints #-}
55
66module Rel8.Expr.Num
7− ( fromIntegral, realToFrac, div, mod, ceiling, floor, round, truncate
7+ ( fromIntegral
8+ , realToFrac
9+ , div, mod, divMod
10+ , quot, rem, quotRem
11+ , ceiling, floor, round, truncate
812 )
913where
1014
1115-- base
12−import Prelude ()
16+import Prelude ( (+), (-), fst, negate, signum, snd )
1317
1418-- rel
1519import Rel8.Expr ( Expr( Expr ) )
20+import Rel8.Expr.Eq ( (==.) )
1621import Rel8.Expr.Function ( function )
1722import Rel8.Expr.Opaleye ( castExpr )
1823import Rel8.Schema.Null ( Homonullable, Sql )
24+import Rel8.Table.Bool ( bool )
1925import Rel8.Type.Num ( DBFractional, DBIntegral, DBNum )
2026
2127
@@ -42,14 +48,41 @@ ceiling :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b)
4248ceiling = function "ceiling"
4349
4450
45−-- | Perform integral division. Corresponds to the @div()@ function.
51+-- | Emulates the behaviour of the Haskell function 'Prelude.div' in
52+-- PostgreSQL.
4653div :: Sql DBIntegral a => Expr a -> Expr a -> Expr a
47−div = function "div"
54+div n d = fst (divMod n d)
4855
4956
50−-- | Corresponds to the @mod()@ function.
57+-- | Emulates the behaviour of the Haskell function 'Prelude.mod' in
58+-- PostgreSQL.
5159mod :: Sql DBIntegral a => Expr a -> Expr a -> Expr a
52−mod = function "mod"
60+mod n d = snd (divMod n d)
61+
62+
63+-- | Simultaneous 'div' and 'mod'.
64+divMod :: Sql DBIntegral a => Expr a -> Expr a -> (Expr a, Expr a)
65+divMod n d = bool qr (q - 1, r + d) (signum r ==. negate (signum d))
66+ where
67+ qr@(q, r) = quotRem n d
68+
69+
70+-- | Perform integral division. Corresponds to the @div()@ function in
71+-- PostgreSQL, which behaves like Haskell's 'Prelude.quot' rather than
72+-- 'Prelude.div'.
73+quot :: Sql DBIntegral a => Expr a -> Expr a -> Expr a
74+quot = function "div"
75+
76+
77+-- | Corresponds to the @mod()@ function in PostgreSQL, which behaves like
78+-- Haskell's 'Prelude.rem' rather than 'Prelude.mod'.
79+rem :: Sql DBIntegral a => Expr a -> Expr a -> Expr a
80+rem = function "mod"
81+
82+
83+-- | Simultaneous 'quot' and 'rem'.
84+quotRem :: Sql DBIntegral a => Expr a -> Expr a -> (Expr a, Expr a)
85+quotRem n d = (quot n d, rem n d)
5386
5487
5588-- | Round a 'DFractional' to a 'DBIntegral' by rounding to the nearest smaller
src/Rel8/Expr/Opaleye.hs+12−3
@@ -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,9 +83,15 @@ traversePrimExpr :: Functor f
8083traversePrimExpr f = fmap fromPrimExpr . f . toPrimExpr
8184
8285
83−toColumn :: Opaleye.PrimExpr -> Opaleye.Column b
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+
92+toColumn :: Opaleye.PrimExpr -> Opaleye.Field_ n b
8493toColumn = Opaleye.Column
8594
8695
87−fromColumn :: Opaleye.Column b -> Opaleye.PrimExpr
96+fromColumn :: Opaleye.Field_ n b -> Opaleye.PrimExpr
8897fromColumn (Opaleye.Column a) = a
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/Text.hs+23−2
@@ -17,6 +17,9 @@ module Rel8.Expr.Text
1717 , pgClientEncoding, quoteIdent, quoteLiteral, quoteNullable, regexpReplace
1818 , regexpSplitToArray, repeat, replace, reverse, right, rpad, rtrim
1919 , splitPart, strpos, substr, translate
20+
21+ -- * @LIKE@ and @ILIKE@
22+ , like, ilike
2023 )
2124where
2225
@@ -24,7 +27,7 @@ where
2427import Data.Bool ( Bool )
2528import Data.Int ( Int32 )
2629import Data.Maybe ( Maybe( Nothing, Just ) )
27−import Prelude ()
30+import Prelude ( flip )
2831
2932-- bytestring
3033import Data.ByteString ( ByteString )
@@ -49,7 +52,7 @@ infixr 6 ++.
4952
5053
5154-- | Matches regular expression, case sensitive
52−--
55+--
5356-- Corresponds to the @~.@ operator.
5457(~.) :: Expr Text -> Expr Text -> Expr Bool
5558(~.) = binaryOperator "~."
@@ -273,3 +276,21 @@ substr a b Nothing = function "substr" a b
273276-- | Corresponds to the @translate@ function.
274277translate :: Expr Text -> Expr Text -> Expr Text -> Expr Text
275278translate = function "translate"
279+
280+
281+-- | @like x y@ corresponds to the expression @y LIKE x@.
282+--
283+-- Note that the arguments to @like@ are swapped. This is to aid currying, so
284+-- you can write expressions like
285+-- @filter (like "Rel%" . packageName) =<< each haskellPackages@
286+like :: Expr Text -> Expr Text -> Expr Bool
287+like = flip (binaryOperator "LIKE")
288+
289+
290+-- | @ilike x y@ corresponds to the expression @y ILIKE x@.
291+--
292+-- Note that the arguments to @ilike@ are swapped. This is to aid currying, so
293+-- you can write expressions like
294+-- @filter (ilike "Rel%" . packageName) =<< each haskellPackages@
295+ilike :: Expr Text -> Expr Text -> Expr Bool
296+ilike = flip (binaryOperator "ILIKE")
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/Record.hs+1
@@ -142,6 +142,7 @@ instance {-# OVERLAPPABLE #-} Snd (Count n rep) ~ rep => Countable n rep where
142142 uncount = id
143143
144144
145+type Record :: Type -> Type
145146newtype Record a = Record
146147 { unrecord :: a
147148 }
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+23−10
@@ -1,4 +1,6 @@
1+{-# language FlexibleContexts #-}
12{-# language StandaloneKindSignatures #-}
3+{-# language UndecidableInstances #-}
24
35module Rel8.Query
46 ( Query( Query )
@@ -15,15 +17,16 @@ import Prelude
1517-- opaleye
1618import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
1719import qualified Opaleye.Internal.PackMap as Opaleye
18−import qualified Opaleye.Internal.PrimQuery as Opaleye
20+import qualified Opaleye.Internal.PrimQuery as Opaleye hiding (lateral)
1921import 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
@@ -175,14 +178,14 @@ instance Bind Query where
175178
176179
177180instance Monad Query where
178− Query q >>= f = Query $ \dummies -> Opaleye.QueryArr $ \(_, tag) ->
181+ Query q >>= f = Query $ \dummies -> Opaleye.stateQueryArr $ \_ tag ->
179182 let
180− Opaleye.QueryArr qa = q dummies
181− ((m, a), query, tag') = qa ((), tag)
183+ qa = q dummies
184+ ((m, a), query, tag') = Opaleye.runStateQueryArr qa () tag
182185 Query q' = f a
183186 (dummies', query', tag'') =
184187 ( dummy : dummies
185− , \lateral -> Opaleye.Rebind True bindings . query lateral
188+ , query <> Opaleye.aRebind bindings
186189 , Opaleye.next tag'
187190 )
188191 where
@@ -190,11 +193,11 @@ instance Monad Query where
190193 where
191194 random = Opaleye.FunExpr "random" []
192195 name = Opaleye.extractAttr "dummy" tag'
193− Opaleye.QueryArr qa' = Opaleye.lateral $ \_ -> q' dummies'
194− ((m'@(Any needsDummies), b), query'', tag''') = qa' ((), tag'')
196+ qa' = Opaleye.lateral $ \_ -> q' dummies'
197+ ((m'@(Any needsDummies), b), query'', tag''') = Opaleye.runStateQueryArr qa' () tag''
195198 query'''
196− | needsDummies = \lateral -> query'' lateral . query' lateral
197− | otherwise = \lateral -> query'' lateral . query lateral
199+ | needsDummies = query' <> query''
200+ | otherwise = query <> query''
198201 m'' = m <> m'
199202 in
200203 ((m'', b), query''', tag''')
@@ -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/Aggregate.hs+19
@@ -1,13 +1,17 @@
11{-# language FlexibleContexts #-}
22{-# language MonoLocalBinds #-}
3+{-# language ScopedTypeVariables #-}
4+{-# language TypeApplications #-}
35
46module Rel8.Query.Aggregate
57 ( aggregate
68 , countRows
9+ , mode
710 )
811where
912
1013-- base
14+import Data.Functor.Contravariant ( (>$<) )
1115import Data.Int ( Int64 )
1216import Prelude
1317
@@ -18,9 +22,16 @@ import qualified Opaleye.Aggregate as Opaleye
1822import Rel8.Aggregate ( Aggregates )
1923import Rel8.Expr ( Expr )
2024import Rel8.Expr.Aggregate ( countStar )
25+import Rel8.Expr.Order ( desc )
2126import Rel8.Query ( Query )
27+import Rel8.Query.Limit ( limit )
2228import Rel8.Query.Maybe ( optional )
2329import Rel8.Query.Opaleye ( mapOpaleye )
30+import Rel8.Query.Order ( orderBy )
31+import Rel8.Table ( toColumns )
32+import Rel8.Table.Aggregate ( hgroupBy )
33+import Rel8.Table.Cols ( Cols( Cols ), fromCols )
34+import Rel8.Table.Eq ( EqTable, eqTable )
2435import Rel8.Table.Opaleye ( aggregator )
2536import Rel8.Table.Maybe ( maybeTable )
2637
@@ -35,3 +46,11 @@ aggregate = mapOpaleye (Opaleye.aggregate aggregator)
3546-- will return @0@.
3647countRows :: Query a -> Query (Expr Int64)
3748countRows = fmap (maybeTable 0 id) . optional . aggregate . fmap (const countStar)
49+
50+
51+-- | Return the most common row in a query.
52+mode :: forall a. EqTable a => Query a -> Query a
53+mode rows = limit 1 $ fmap (fromCols . snd) $ orderBy (fst >$< desc) $ do
54+ aggregate $ do
55+ row <- toColumns <$> rows
56+ pure (countStar, Cols $ hgroupBy (eqTable @a) row)
src/Rel8/Query/Distinct.hs+5−10
@@ -1,5 +1,3 @@
1−{-# options_ghc -fno-warn-redundant-constraints #-}
2−
31module Rel8.Query.Distinct
42 ( distinct
53 , distinctOn
@@ -8,12 +6,11 @@ module Rel8.Query.Distinct
86where
97
108-- base
11−import Prelude
9+import Prelude ()
1210
1311-- opaleye
14−import qualified Opaleye.Distinct as Opaleye hiding ( distinctOn, distinctOnBy )
15−import qualified Opaleye.Internal.Order as Opaleye
16−import qualified Opaleye.Internal.QueryArr as Opaleye
12+import qualified Opaleye.Distinct as Opaleye
13+import qualified Opaleye.Order as Opaleye
1714
1815-- rel8
1916import Rel8.Order ( Order( Order ) )
@@ -33,13 +30,11 @@ distinct = mapOpaleye (Opaleye.distinctExplicit distinctspec)
3330-- to a projection. If multiple rows have the same projection, it is
3431-- unspecified which row will be returned. If this matters, use 'distinctOnBy'.
3532distinctOn :: EqTable b => (a -> b) -> Query a -> Query a
36−distinctOn proj =
37− mapOpaleye (\q -> Opaleye.productQueryArr (Opaleye.distinctOn unpackspec proj . Opaleye.runSimpleQueryArr q))
33+distinctOn proj = mapOpaleye (Opaleye.distinctOnExplicit unpackspec proj)
3834
3935
4036-- | Select all distinct rows from a query, where rows are equivalent according
4137-- to a projection. If there are multiple rows with the same projection, the
4238-- first row according to the specified 'Order' will be returned.
4339distinctOnBy :: EqTable b => (a -> b) -> Order a -> Query a -> Query a
44−distinctOnBy proj (Order order) =
45− mapOpaleye (\q -> Opaleye.productQueryArr (Opaleye.distinctOnBy unpackspec proj order . Opaleye.runSimpleQueryArr q))
40+distinctOnBy proj (Order order) = mapOpaleye (Opaleye.distinctOnByExplicit unpackspec proj order)
src/Rel8/Query/Exists.hs+1−1
@@ -12,7 +12,7 @@ import Prelude hiding ( filter )
1212
1313-- opaleye
1414import qualified Opaleye.Exists as Opaleye
15−import qualified Opaleye.Operators as Opaleye hiding ( exists )
15+import qualified Opaleye.Operators as Opaleye
1616
1717-- rel8
1818import Rel8.Expr ( Expr )
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 $ \(Opaleye.QueryArr f) -> Opaleye.QueryArr $ \(_, tag) ->
27− let
28− (a, query, tag') = 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' lateral = Opaleye.Rebind True bindings . query lateral
33− in
34− ((fromPrimExpr index, a), query', tag'')
21+indexed = window (liftA2 (,) (subtract 1 <$> rowNumber) currentRow)
src/Rel8/Query/Null.hs+15
@@ -1,5 +1,8 @@
1+{-# language FlexibleContexts #-}
2+
13module Rel8.Query.Null
24 ( catNull
5+ , catNullTable
36 )
47where
58
@@ -9,6 +12,8 @@ import Prelude
912-- rel8
1013import Rel8.Expr ( Expr )
1114import Rel8.Expr.Null ( isNonNull, unsafeUnnullify )
15+import Rel8.Table ( Table )
16+import Rel8.Table.Null ( NullTable, isNonNullTable, unsafeUnnullifyTable )
1217import Rel8.Query ( Query )
1318import Rel8.Query.Filter ( where_ )
1419
@@ -21,3 +26,13 @@ catNull :: Expr (Maybe a) -> Query (Expr a)
2126catNull a = do
2227 where_ $ isNonNull a
2328 pure $ unsafeUnnullify a
29+
30+
31+-- | Filter a 'Query' that might return @nullTable@ to a 'Query' without any
32+-- @nullTable@s.
33+--
34+-- Corresponds to 'Data.Maybe.catMaybes'.
35+catNullTable :: Table Expr a => NullTable Expr a -> Query a
36+catNullTable a = do
37+ where_ $ isNonNullTable a
38+ pure $ unsafeUnnullifyTable a
src/Rel8/Query/Opaleye.hs+11−11
@@ -41,30 +41,30 @@ zipOpaleyeWith f (Query a) (Query b) = Query $ liftA2 (zipping f) a b
4141
4242unsafePeekQuery :: Query a -> a
4343unsafePeekQuery (Query q) = case q mempty of
44− Opaleye.QueryArr f -> case f ((), Opaleye.start) of
44+ f -> case Opaleye.runStateQueryArr f () Opaleye.start of
4545 ((_, a), _, _) -> a
4646
4747
4848mapping :: ()
4949 => (Opaleye.Select a -> Opaleye.Select b)
5050 -> Opaleye.Select (m, a) -> Opaleye.Select (m, b)
51−mapping f q@(Opaleye.QueryArr qa) = Opaleye.QueryArr $ \(_, tag) ->
51+mapping f q = Opaleye.stateQueryArr $ \_ tag ->
5252 let
53− ((m, _), _, _) = qa ((), tag)
54− Opaleye.QueryArr qa' = (m,) <$> f (snd <$> q)
53+ ((m, _), _, _) = Opaleye.runStateQueryArr q () tag
54+ q' = (m,) <$> f (snd <$> q)
5555 in
56− qa' ((), tag)
56+ Opaleye.runStateQueryArr q' () tag
5757
5858
5959zipping :: Semigroup m
6060 => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)
6161 -> Opaleye.Select (m, a) -> Opaleye.Select (m, b) -> Opaleye.Select (m, c)
62−zipping f q@(Opaleye.QueryArr qa) q'@(Opaleye.QueryArr qa') =
63− Opaleye.QueryArr $ \(_, tag) ->
62+zipping f q q' =
63+ Opaleye.stateQueryArr $ \_ tag ->
6464 let
65− ((m, _), _, _) = qa ((), tag)
66− ((m', _), _, _) = qa' ((), tag)
65+ ((m, _), _, _) = Opaleye.runStateQueryArr q () tag
66+ ((m', _), _, _) = Opaleye.runStateQueryArr q' () tag
6767 m'' = m <> m'
68− Opaleye.QueryArr qa'' = (m'',) <$> f (snd <$> q) (snd <$> q')
68+ q'' = (m'',) <$> f (snd <$> q) (snd <$> q')
6969 in
70− qa'' ((), tag)
70+ Opaleye.runStateQueryArr q'' () tag
src/Rel8/Query/Rebind.hs+5−13
@@ -7,29 +7,21 @@ where
77
88-- base
99import Prelude
10+import Control.Arrow ((<<<))
1011
1112-- 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−import qualified Opaleye.Internal.Unpackspec as Opaleye
13+import qualified Opaleye.Internal.Rebind as Opaleye
1714
1815-- rel8
1916import Rel8.Expr ( Expr )
20−import Rel8.Query ( Query( Query ) )
17+import Rel8.Query ( Query )
2118import Rel8.Table ( Table )
2219import Rel8.Table.Opaleye ( unpackspec )
20+import Rel8.Query.Opaleye (fromOpaleye)
2321
2422
2523-- | 'rebind' takes a variable name, some expressions, and binds each of them
2624-- to a new variable in the SQL. The @a@ returned consists only of these
2725-- variables. It's essentially a @let@ binding for Postgres expressions.
2826rebind :: Table Expr a => String -> a -> Query a
29−rebind prefix a = Query $ \_ -> Opaleye.QueryArr $ \(_, tag) ->
30− let
31− tag' = Opaleye.next tag
32− (a', bindings) = Opaleye.run $
33− Opaleye.runUnpackspec unpackspec (Opaleye.extractAttr prefix tag) a
34− in
35− ((mempty, a'), \_ -> Opaleye.Rebind True bindings, tag')
27+rebind prefix a = fromOpaleye (Opaleye.rebindExplicitPrefix prefix unpackspec <<< pure a)
src/Rel8/Query/Set.hs+6−6
@@ -23,36 +23,36 @@ import Rel8.Table.Opaleye ( binaryspec )
2323
2424
2525-- | Combine the results of two queries of the same type, collapsing
26−-- duplicates. @union a b@ is the same as the SQL statement @x UNION b@.
26+-- duplicates. @union a b@ is the same as the SQL statement @a UNION b@.
2727union :: EqTable a => Query a -> Query a -> Query a
2828union = zipOpaleyeWith (Opaleye.unionExplicit binaryspec)
2929
3030
3131-- | Combine the results of two queries of the same type, retaining duplicates.
32−-- @unionAll a b@ is the same as the SQL statement @x UNION ALL b@.
32+-- @unionAll a b@ is the same as the SQL statement @a UNION ALL b@.
3333unionAll :: Table Expr a => Query a -> Query a -> Query a
3434unionAll = zipOpaleyeWith (Opaleye.unionAllExplicit binaryspec)
3535
3636
3737-- | Find the intersection of two queries, collapsing duplicates. @intersect a
38−-- b@ is the same as the SQL statement @x INTERSECT b@.
38+-- b@ is the same as the SQL statement @a INTERSECT b@.
3939intersect :: EqTable a => Query a -> Query a -> Query a
4040intersect = zipOpaleyeWith (Opaleye.intersectExplicit binaryspec)
4141
4242
4343-- | Find the intersection of two queries, retaining duplicates. @intersectAll
44−-- a b@ is the same as the SQL statement @x INTERSECT ALL b@.
44+-- a b@ is the same as the SQL statement @a INTERSECT ALL b@.
4545intersectAll :: EqTable a => Query a -> Query a -> Query a
4646intersectAll = zipOpaleyeWith (Opaleye.intersectAllExplicit binaryspec)
4747
4848
4949-- | Find the difference of two queries, collapsing duplicates @except a b@ is
50−-- the same as the SQL statement @x EXCEPT b@.
50+-- the same as the SQL statement @a EXCEPT b@.
5151except :: EqTable a => Query a -> Query a -> Query a
5252except = zipOpaleyeWith (Opaleye.exceptExplicit binaryspec)
5353
5454
5555-- | Find the difference of two queries, retaining duplicates. @exceptAll a b@
56−-- is the same as the SQL statement @x EXCEPT ALL b@.
56+-- is the same as the SQL statement @a EXCEPT ALL b@.
5757exceptAll :: EqTable a => Query a -> Query a -> Query a
5858exceptAll = zipOpaleyeWith (Opaleye.exceptAllExplicit binaryspec)
src/Rel8/Query/These.hs+8−8
@@ -48,11 +48,11 @@ import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ) )
4848alignBy :: ()
4949 => (a -> b -> Expr Bool)
5050 -> Query a -> Query b -> Query (TheseTable Expr a b)
51−alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.QueryArr $ \i -> case i of
52− (_, tag) -> (tab, join', tag''')
51+alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.stateQueryArr $ \_ t -> case t of
52+ tag -> (tab, join', tag''')
5353 where
54− (ma, left', tag') = Opaleye.runSimpleQueryArr (pure <$> left) ((), tag)
55− (mb, right', tag'') = Opaleye.runSimpleQueryArr (pure <$> right) ((), tag')
54+ (ma, left', tag') = Opaleye.runStateQueryArr (pure <$> left) () tag
55+ (mb, right', tag'') = Opaleye.runStateQueryArr (pure <$> right) () tag'
5656 MaybeTable hasHere a = ma
5757 MaybeTable hasThere b = mb
5858 (hasHere', lbindings) = Opaleye.run $ do
@@ -60,15 +60,15 @@ alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.QueryArr $ \i -> cas
6060 (hasThere', rbindings) = Opaleye.run $ do
6161 traversePrimExpr (Opaleye.extractAttr "hasThere" tag'') hasThere
6262 tag''' = Opaleye.next tag''
63− join lateral = Opaleye.Join Opaleye.FullJoin on left'' right''
63+ join = Opaleye.Join Opaleye.FullJoin on left'' right''
6464 where
6565 on = toPrimExpr $ condition (extract a) (extract b)
66− left'' = (lateral, Opaleye.Rebind True lbindings left')
67− right'' = (lateral, Opaleye.Rebind True rbindings right')
66+ left'' = (Opaleye.NonLateral, Opaleye.toPrimQuery (left' <> Opaleye.aRebind lbindings))
67+ right'' = (Opaleye.NonLateral, Opaleye.toPrimQuery (right' <> Opaleye.aRebind rbindings))
6868 ma' = MaybeTable hasHere' a
6969 mb' = MaybeTable hasThere' b
7070 tab = TheseTable {here = ma', there = mb'}
71− join' lateral input = Opaleye.times lateral input (join lateral)
71+ join' = Opaleye.aProduct join
7272
7373
7474keepHereTable :: TheseTable Expr a b -> Query (a, MaybeTable Expr b)
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/Schema/HTable/Vectorize.hs+2−1
@@ -27,7 +27,7 @@ module Rel8.Schema.HTable.Vectorize
2727where
2828
2929-- base
30−import Data.Kind ( Type )
30+import Data.Kind ( Constraint, Type )
3131import Data.List.NonEmpty ( NonEmpty )
3232import GHC.Generics (Generic)
3333import Prelude
@@ -53,6 +53,7 @@ import Rel8.Type.Information ( TypeInformation )
5353import Data.Zip ( Unzip, Zip, Zippy(..) )
5454
5555
56+type Vector :: (Type -> Type) -> Constraint
5657class Vector list where
5758 listNotNull :: proxy a -> Dict NotNull (list a)
5859 vectorTypeInformation :: ()
src/Rel8/Schema/Table.hs+3
@@ -2,6 +2,7 @@
22{-# language DerivingStrategies #-}
33{-# language DisambiguateRecordFields #-}
44{-# language NamedFieldPuns #-}
5+{-# language StandaloneKindSignatures #-}
56
67module Rel8.Schema.Table
78 ( TableSchema(..)
@@ -10,6 +11,7 @@ module Rel8.Schema.Table
1011where
1112
1213-- base
14+import Data.Kind ( Type )
1315import Prelude
1416
1517-- opaleye
@@ -26,6 +28,7 @@ import Text.PrettyPrint ( Doc )
2628--
2729-- For each selectable table in your database, you should provide a
2830-- @TableSchema@ in order to interact with the table via Rel8.
31+type TableSchema :: Type -> Type
2932data TableSchema names = TableSchema
3033 { name :: String
3134 -- ^ The name of the table.
src/Rel8/Statement/Select.hs+5−3
@@ -3,6 +3,7 @@
33{-# language FlexibleContexts #-}
44{-# language MonoLocalBinds #-}
55{-# language ScopedTypeVariables #-}
6+{-# language StandaloneKindSignatures #-}
67{-# language TypeApplications #-}
78
89module Rel8.Statement.Select
@@ -17,7 +18,7 @@ where
1718
1819-- base
1920import Data.Foldable ( toList )
20−import Data.List.NonEmpty ( NonEmpty( (:|) ) )
21+import Data.Kind ( Type )
2122import Data.Void ( Void )
2223import Prelude hiding ( undefined )
2324
@@ -90,7 +91,7 @@ ppSelect query =
9091ppRows :: Table Expr a => Query a -> Doc
9192ppRows query = case optimize primQuery of
9293 -- Special case VALUES because we can't use DEFAULT inside a SELECT
93− Optimized (Opaleye.Product ((_, Opaleye.Values symbols rows) :| []) [])
94+ Optimized (Opaleye.Values symbols rows)
9495 | eqSymbols symbols (toList (T.exprs a)) ->
9596 Opaleye.ppValues_ (map Opaleye.sqlExpr <$> toList rows)
9697 _ -> ppSelect query
@@ -116,8 +117,9 @@ ppPrimSelect query =
116117 (a, primQuery, _) = Opaleye.runSimpleQueryArrStart (toOpaleye query) ()
117118
118119
120+type Optimized :: Type -> Type
119121data Optimized a = Empty | Unit | Optimized a
120− deriving stock (Functor, Foldable, Traversable)
122+ deriving stock (Functor, Foldable, Traversable, Show)
121123
122124
123125optimize :: 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/Aggregate.hs+12
@@ -37,6 +37,18 @@ import Rel8.Type.Eq ( DBEq )
3737
3838-- | Group equal tables together. This works by aggregating each column in the
3939-- given table with 'groupByExpr'.
40+--
41+-- For example, if we have a table of items, we could group the items by the
42+-- order they belong to:
43+--
44+-- @
45+-- itemsByOrder :: Query (OrderId Expr, ListTable Expr (Item Expr))
46+-- itemsByOrder = aggregate $ do
47+-- item <- each itemSchema
48+-- let orderId = groupBy (itemOrderId item)
49+-- let orderItems = listAgg item
50+-- pure (orderId, orderItems)
51+-- @
4052groupBy :: forall exprs aggregates. (EqTable exprs, Aggregates aggregates exprs)
4153 => exprs -> aggregates
4254groupBy = fromColumns . hgroupBy (eqTable @exprs) . toColumns
src/Rel8/Table/HKD.hs+1
@@ -157,6 +157,7 @@ instance
157157 => HKDable a
158158
159159
160+type Top_ :: Constraint
160161class Top_
161162instance Top_
162163
src/Rel8/Table/Maybe.hs+6
@@ -15,6 +15,7 @@ module Rel8.Table.Maybe
1515 ( MaybeTable(..)
1616 , maybeTable, nothingTable, justTable
1717 , isNothingTable, isJustTable
18+ , fromMaybeTable
1819 , ($?)
1920 , aggregateMaybeTable
2021 , nameMaybeTable
@@ -206,6 +207,11 @@ justTable :: a -> MaybeTable Expr a
206207justTable = MaybeTable mempty . pure
207208
208209
210+-- | 'Data.Maybe.fromMaybe' for 'MaybeTable's.
211+fromMaybeTable :: Table Expr a => a -> MaybeTable Expr a -> a
212+fromMaybeTable fallback = maybeTable fallback id
213+
214+
209215-- | Project a single expression out of a 'MaybeTable'. You can think of this
210216-- operator like the '$' operator, but it also has the ability to return
211217-- @null@.
src/Rel8/Table/Null.hsnew file+147
@@ -0,0 +1,147 @@
1+{-# language DataKinds #-}
2+{-# language FlexibleContexts #-}
3+{-# language FlexibleInstances #-}
4+{-# language MultiParamTypeClasses #-}
5+{-# language ScopedTypeVariables #-}
6+{-# language StandaloneKindSignatures #-}
7+{-# language TypeApplications #-}
8+{-# language TypeFamilies #-}
9+{-# language UndecidableInstances #-}
10+
11+module Rel8.Table.Null
12+ ( NullTable(..)
13+ , nullableTable, nullTable, nullifyTable, unsafeUnnullifyTable
14+ , isNullTable, isNonNullTable
15+ , nameNullTable
16+ , toMaybeTable, toNullTable
17+ )
18+where
19+
20+-- base
21+import Data.Kind ( Type )
22+import Prelude hiding ( null, undefined )
23+
24+-- comonad
25+import Control.Comonad ( extract )
26+
27+-- rel8
28+import Rel8.Expr ( Expr )
29+import Rel8.Expr.Bool ( not_ )
30+import Rel8.Kind.Context ( Reifiable )
31+import qualified Rel8.Schema.Kind as K
32+import Rel8.Schema.Name ( Name )
33+import Rel8.Table
34+ ( Table, Columns, Context, fromColumns, toColumns
35+ , FromExprs, fromResult, toResult
36+ , Transpose
37+ )
38+import Rel8.Table.Alternative
39+ ( AltTable, (<|>:)
40+ , AlternativeTable, emptyTable
41+ )
42+import Rel8.Table.Bool ( bool )
43+import Rel8.Table.Eq ( EqTable, eqTable )
44+import Rel8.Table.Maybe ( MaybeTable, justTable, maybeTable, nothingTable )
45+import Rel8.Table.Nullify ( Nullify, isNull )
46+import Rel8.Table.Ord ( OrdTable, ordTable )
47+import Rel8.Table.Projection ( Projectable, project )
48+import Rel8.Table.Serialize ( ToExprs )
49+import Rel8.Table.Undefined ( undefined )
50+
51+
52+-- | @NullTable t@ is the table @t@, but where all the columns in @t@ have the
53+-- possibility of being 'Rel8.null'. This is very similar to
54+-- 'Rel8.MaybeTable', except that it does not use an extra tag field, so it
55+-- cannot distinguish between @Nothing@ and @Just Nothing@ if nested. In other
56+-- words, if all of the columns of the @t@ passed to @NullTable@ are already
57+-- nullable, then @NullTable@ has no effect.
58+type NullTable :: K.Context -> Type -> Type
59+newtype NullTable context a = NullTable (Nullify context a)
60+
61+
62+instance Projectable (NullTable context) where
63+ project f (NullTable a) = NullTable (project f a)
64+
65+
66+instance context ~ Expr => AltTable (NullTable context) where
67+ ma <|>: mb = bool ma mb (isNullTable ma)
68+
69+
70+instance context ~ Expr => AlternativeTable (NullTable context) where
71+ emptyTable = nullTable
72+
73+
74+instance (Table context a, Reifiable context, context ~ context') =>
75+ Table context' (NullTable context a)
76+ where
77+ type Columns (NullTable context a) = Columns (Nullify context a)
78+ type Context (NullTable context a) = Context (Nullify context a)
79+ type FromExprs (NullTable context a) = FromExprs (Nullify context a)
80+ type Transpose to (NullTable context a) = NullTable to (Transpose to a)
81+
82+ toColumns (NullTable a) = toColumns a
83+ fromColumns = NullTable . fromColumns
84+
85+ toResult = toResult @_ @(Nullify context a)
86+ fromResult = fromResult @_ @(Nullify context a)
87+
88+
89+instance (EqTable a, context ~ Expr) => EqTable (NullTable context a) where
90+ eqTable = eqTable @(Nullify context a)
91+
92+
93+instance (OrdTable a, context ~ Expr) => OrdTable (NullTable context a) where
94+ ordTable = ordTable @(Nullify context a)
95+
96+
97+instance (ToExprs exprs a, context ~ Expr) =>
98+ ToExprs (NullTable context exprs) (Maybe a)
99+
100+
101+-- | Check if any of the non-nullable fields of @a@ are 'Rel8.null' under the
102+-- 'NullTable'. Returns 'Rel8.false' if @a@ has no non-nullable fields.
103+isNullTable :: Table Expr a => NullTable Expr a -> Expr Bool
104+isNullTable (NullTable a) = isNull a
105+
106+
107+-- | The inverse of 'isNullTable'.
108+isNonNullTable :: Table Expr a => NullTable Expr a -> Expr Bool
109+isNonNullTable = not_ . isNullTable
110+
111+
112+-- | Like 'Rel8.nullable'.
113+nullableTable :: (Table Expr a, Table Expr b)
114+ => b -> (a -> b) -> NullTable Expr a -> b
115+nullableTable b f ma@(NullTable a) = bool (f (extract a)) b (isNullTable ma)
116+
117+
118+-- | The null table. Like 'Rel8.null'.
119+nullTable :: Table Expr a => NullTable Expr a
120+nullTable = NullTable (pure undefined)
121+
122+
123+-- | Lift any table into 'NullTable'. Like 'Rel8.nullify'.
124+nullifyTable :: a -> NullTable Expr a
125+nullifyTable = NullTable . pure
126+
127+
128+unsafeUnnullifyTable :: NullTable Expr a -> a
129+unsafeUnnullifyTable (NullTable a) = extract a
130+
131+
132+-- | Construct a 'NullTable' in the 'Name' context. This can be useful if you
133+-- have a 'NullTable' that you are storing in a table and need to construct a
134+-- 'TableSchema'.
135+nameNullTable :: a -> NullTable Name a
136+nameNullTable = NullTable . pure
137+
138+
139+-- | Convert a 'NullTable' to a 'MaybeTable'.
140+toMaybeTable :: Table Expr a => NullTable Expr a -> MaybeTable Expr a
141+toMaybeTable = nullableTable nothingTable justTable
142+
143+
144+-- | Convert a 'MaybeTable' to a 'NullTable'. Note that if the underlying @a@
145+-- has no non-nullable fields, this is a lossy conversion.
146+toNullTable :: Table Expr a => MaybeTable Expr a -> NullTable Expr a
147+toNullTable = maybeTable nullTable nullifyTable
src/Rel8/Table/Nullify.hs+27
@@ -1,7 +1,9 @@
11{-# language DataKinds #-}
2+{-# language FlexibleContexts #-}
23{-# language FlexibleInstances #-}
34{-# language LambdaCase #-}
45{-# language MultiParamTypeClasses #-}
6+{-# language NamedFieldPuns #-}
57{-# language ScopedTypeVariables #-}
68{-# language StandaloneKindSignatures #-}
79{-# language TypeApplications #-}
@@ -12,11 +14,13 @@ module Rel8.Table.Nullify
1214 ( Nullify
1315 , aggregateNullify
1416 , guard
17+ , isNull
1518 )
1619where
1720
1821-- base
1922import Control.Applicative ( liftA2 )
23+import Data.Functor.Const ( Const( Const ), getConst )
2024import Data.Functor.Identity ( runIdentity )
2125import Data.Kind ( Type )
2226import Prelude
@@ -27,6 +31,8 @@ import Control.Comonad ( Comonad, duplicate, extract, ComonadApply, (<@>) )
2731-- rel8
2832import Rel8.Aggregate ( Aggregate )
2933import Rel8.Expr ( Expr )
34+import Rel8.Expr.Bool ( (||.), false )
35+import qualified Rel8.Expr.Null as Expr
3036import Rel8.Kind.Context ( Reifiable, contextSing )
3137import Rel8.Schema.Context.Nullify
3238 ( Nullifiability( NAggregate, NExpr )
@@ -45,12 +51,14 @@ import Rel8.Schema.HTable.Nullify
4551 , hproject
4652 )
4753import qualified Rel8.Schema.Kind as K
54+import Rel8.Schema.Null ( Nullity( NotNull, Null ) )
4855import qualified Rel8.Schema.Result as R
4956import Rel8.Table
5057 ( Table, Columns, Context, toColumns, fromColumns
5158 , FromExprs, fromResult, toResult
5259 , Transpose
5360 )
61+import Rel8.Schema.Spec ( Spec( Spec, nullity ) )
5462import Rel8.Table.Eq ( EqTable, eqTable )
5563import Rel8.Table.Ord ( OrdTable, ordTable )
5664import Rel8.Table.Projection ( Projectable, apply, project )
@@ -182,3 +190,22 @@ guard :: (Reifiable context, HTable t)
182190 -> HNullify t context
183191guard tag isNonNull isNonNullExpr =
184192 hguard (guarder contextSing tag isNonNull isNonNullExpr)
193+
194+
195+isNull :: forall a. Table Expr a => Nullify Expr a -> Expr Bool
196+isNull =
197+ maybe false getAny .
198+ getConst .
199+ hunnullify (\Spec {nullity} a -> Const $ case nullity of
200+ NotNull -> Just $ Any $ Expr.isNull a
201+ Null -> Nothing) .
202+ toColumns
203+
204+
205+newtype Any = Any
206+ { getAny :: Expr Bool
207+ }
208+
209+
210+instance Semigroup Any where
211+ Any a <> Any b = Any (a ||. b)
src/Rel8/Table/Opaleye.hs+31−47
@@ -7,6 +7,8 @@
77{-# language TypeFamilies #-}
88{-# language ViewPatterns #-}
99
10+{-# options_ghc -Wno-deprecations #-}
11+
1012module Rel8.Table.Opaleye
1113 ( aggregator
1214 , attributes
@@ -26,17 +28,15 @@ where
2628-- base
2729import Data.Functor.Const ( Const( Const ), getConst )
2830import Data.List.NonEmpty ( NonEmpty )
29−import Prelude hiding ( undefined )
31+import Prelude
3032
3133-- opaleye
34+import qualified Opaleye.Adaptors as Opaleye
35+import qualified Opaleye.Field as Opaleye ( Field_ )
3236import qualified Opaleye.Internal.Aggregate as Opaleye
33−import qualified Opaleye.Internal.Binary as Opaleye
34−import qualified Opaleye.Internal.Distinct as Opaleye
3537import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
36−import qualified Opaleye.Internal.PackMap as Opaleye
37−import qualified Opaleye.Internal.Unpackspec as Opaleye
3838import qualified Opaleye.Internal.Values as Opaleye
39−import qualified Opaleye.Internal.Table as Opaleye
39+import qualified Opaleye.Table as Opaleye
4040
4141-- profunctors
4242import Data.Profunctor ( dimap, lmap )
@@ -46,27 +46,25 @@ import Rel8.Aggregate ( Aggregate( Aggregate ), Aggregates )
4646import Rel8.Expr ( Expr )
4747import Rel8.Expr.Opaleye
4848 ( fromPrimExpr, toPrimExpr
49− , traversePrimExpr
50− , fromColumn, toColumn
51− , scastExpr
49+ , scastExpr, traverseFieldP
5250 )
53−import Rel8.Schema.HTable ( htabulateA, hfield, htraverse, hspecs, htabulate )
51+import Rel8.Schema.HTable ( htabulateA, hfield, hspecs, htabulate,
52+ htraverseP, htraversePWithField )
5453import Rel8.Schema.Name ( Name( Name ), Selects, ppColumn )
5554import Rel8.Schema.Spec ( Spec(..) )
5655import Rel8.Schema.Table ( TableSchema(..), ppTable )
5756import Rel8.Table ( Table, fromColumns, toColumns )
58−import Rel8.Table.Undefined ( undefined )
57+import Rel8.Type.Information ( typeName )
5958
6059-- semigroupoids
6160import Data.Functor.Apply ( WrappedApplicative(..) )
61+import Data.Profunctor.Product ( ProductProfunctor )
6262
6363
6464aggregator :: Aggregates aggregates exprs => Opaleye.Aggregator aggregates exprs
65−aggregator = Opaleye.Aggregator $ Opaleye.PackMap $ \f aggregates ->
66− fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->
67− WrapApplicative $ case hfield (toColumns aggregates) field of
68− Aggregate (Opaleye.Aggregator (Opaleye.PackMap inner)) ->
69− inner f ()
65+aggregator = dimap toColumns fromColumns $
66+ htraverseP $
67+ lmap (\(Aggregate a) -> (a, ())) Opaleye.aggregatorApply
7068
7169
7270attributes :: Selects names exprs => TableSchema names -> exprs
@@ -77,22 +75,19 @@ attributes schema@TableSchema {columns} = fromColumns $ htabulate $ \field ->
7775 show (ppTable schema) <> "." <> show (ppColumn column)
7876
7977
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+
8085binaryspec :: Table Expr a => Opaleye.Binaryspec a a
81−binaryspec = Opaleye.Binaryspec $ Opaleye.PackMap $ \f (as, bs) ->
82− fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->
83− WrapApplicative $
84− case (hfield (toColumns as) field, hfield (toColumns bs) field) of
85− (a, b) -> fromPrimExpr <$> f (toPrimExpr a, toPrimExpr b)
86+binaryspec = fromOpaleyespec Opaleye.binaryspecField
8687
8788
8889distinctspec :: Table Expr a => Opaleye.Distinctspec a a
89−distinctspec =
90− Opaleye.Distinctspec $ Opaleye.Aggregator $ Opaleye.PackMap $ \f ->
91− fmap fromColumns .
92− unwrapApplicative .
93− htraverse
94− (\a -> WrapApplicative $ fromPrimExpr <$> f (Nothing, toPrimExpr a)) .
95− toColumns
90+distinctspec = fromOpaleyespec Opaleye.distinctspecField
9691
9792
9893exprs :: Table Expr a => a -> NonEmpty Opaleye.PrimExpr
@@ -111,8 +106,8 @@ exprsWithNames names as = getConst $ htabulateA $ \field ->
111106table :: Selects names exprs => TableSchema names -> Opaleye.Table exprs exprs
112107table (TableSchema name schema columns) =
113108 case schema of
114− Nothing -> Opaleye.Table name (tableFields columns)
115− Just schemaName -> Opaleye.TableWithSchema schemaName name (tableFields columns)
109+ Nothing -> Opaleye.table name (tableFields columns)
110+ Just schemaName -> Opaleye.tableWithSchema schemaName name (tableFields columns)
116111
117112
118113tableFields :: Selects names exprs
@@ -124,21 +119,19 @@ tableFields (toColumns -> names) = dimap toColumns fromColumns $
124119 where
125120 go :: Name a -> Opaleye.TableFields (Expr a) (Expr a)
126121 go (Name name) =
127− dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) $
122+ traverseFieldP $
128123 Opaleye.requiredTableField name
129124
130125
131126unpackspec :: Table Expr a => Opaleye.Unpackspec a a
132−unpackspec = Opaleye.Unpackspec $ Opaleye.PackMap $ \f ->
133− fmap fromColumns .
134− unwrapApplicative .
135− htraverse (WrapApplicative . traversePrimExpr f) .
136− toColumns
127+unpackspec = fromOpaleyespec Opaleye.unpackspecField
137128{-# INLINABLE unpackspec #-}
138129
139130
140−valuesspec :: Table Expr a => Opaleye.ValuesspecSafe a a
141−valuesspec = Opaleye.ValuesspecSafe (toPackMap undefined) unpackspec
131+valuesspec :: Table Expr a => Opaleye.Valuesspec a a
132+valuesspec = dimap toColumns fromColumns $
133+ htraversePWithField (traverseFieldP . Opaleye.valuesspecFieldType . typeName)
134+ where typeName = Rel8.Type.Information.typeName . info . hfield hspecs
142135
143136
144137view :: Selects names exprs => names -> exprs
@@ -147,15 +140,6 @@ view columns = fromColumns $ htabulate $ \field ->
147140 Name column -> fromPrimExpr $ Opaleye.BaseTableAttrExpr column
148141
149142
150−toPackMap :: Table Expr a
151− => a -> Opaleye.PackMap Opaleye.PrimExpr Opaleye.PrimExpr () a
152−toPackMap as = Opaleye.PackMap $ \f () ->
153− fmap fromColumns $
154− unwrapApplicative .
155− htraverse (WrapApplicative . traversePrimExpr f) $
156− toColumns as
157−
158−
159143-- | Transform a table by adding 'CAST' to all columns. This is most useful for
160144-- finalising a SELECT or RETURNING statement, guaranteed that the output
161145-- matches what is encoded in each columns TypeInformation.
src/Rel8/Table/Ord.hs+2−2
@@ -146,9 +146,9 @@ infix 4 >=:
146146
147147-- | Given two 'Table's, return the table that sorts before the other.
148148least :: OrdTable a => a -> a -> a
149−least a b = bool a b (a <: b)
149+least a b = bool b a (a <: b)
150150
151151
152152-- | Given two 'Table's, return the table that sorts after the other.
153153greatest :: OrdTable a => a -> a -> a
154−greatest a b = bool a b (a >: b)
154+greatest a b = bool b a (a >: b)
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+23−20
@@ -58,7 +58,7 @@ import Data.Function ( on )
5858import Data.Functor.Contravariant ( Contravariant, (>$<), contramap )
5959import Data.Int ( Int64 )
6060import Data.Kind ( Type )
61−import Data.Maybe ( fromMaybe )
61+import Data.Maybe ( fromJust, fromMaybe )
6262import Prelude hiding ( lookup, zip, zipWith )
6363
6464-- bifunctors
@@ -69,9 +69,7 @@ import Control.Comonad ( extract )
6969
7070-- opaleye
7171import qualified Opaleye.Aggregate as Opaleye
72−import qualified Opaleye.Internal.Order as Opaleye
73−import qualified Opaleye.Internal.QueryArr as Opaleye
74−import qualified Opaleye.Order as Opaleye ( orderBy )
72+import qualified Opaleye.Order as Opaleye ( orderBy, distinctOnExplicit )
7573
7674-- profunctors
7775import Data.Profunctor ( dimap, lmap )
@@ -92,10 +90,10 @@ import Rel8.Order ( Order( Order ) )
9290import Rel8.Query ( Query )
9391import qualified Rel8.Query.Exists as Q ( exists, present, absent )
9492import Rel8.Query.Filter ( where_ )
95−import Rel8.Query.Limit ( limit )
9693import Rel8.Query.List ( catNonEmptyTable )
9794import qualified Rel8.Query.Maybe as Q ( optional )
9895import Rel8.Query.Opaleye ( mapOpaleye, unsafePeekQuery )
96+import Rel8.Query.Rebind ( rebind )
9997import Rel8.Query.These ( alignBy )
10098import Rel8.Table ( Table, fromColumns, toColumns )
10199import Rel8.Table.Aggregate ( hgroupBy, listAgg, nonEmptyAgg )
@@ -236,7 +234,13 @@ instance EqTable k => Monad (Tabulation k) where
236234-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<|>:)@ is
237235-- @unionWith (<>)@.
238236instance EqTable k => AltTable (Tabulation k) where
239− as <|>: bs = catNonEmptyTable `through` ((<>) `on` some) as bs
237+ tas <|>: tbs = do
238+ eas <- peek tas
239+ ebs <- peek tbs
240+ case (eas, ebs) of
241+ (Left as, Left bs) -> liftQuery $ as <|>: bs
242+ (Right as, Right bs) -> fromQuery $ as <|>: bs
243+ _ -> catNonEmptyTable `through` ((<>) `on` some) tas tbs
240244
241245
242246instance EqTable k => AlternativeTable (Tabulation k) where
@@ -345,19 +349,8 @@ aggregate (Tabulation f) = Tabulation $
345349-- \"first\" value it encounters for each key, but note that \"first\" is
346350-- undefined unless you first call 'order'.
347351distinct :: EqTable k => Tabulation k a -> Tabulation k a
348−distinct (Tabulation f) = Tabulation $ \p ->
349− -- workaround for https://github.com/tomjaguarpaw/haskell-opaleye/pull/518
350− case fst (unsafePeekQuery (f p)) of
351− Nothing -> limit 1 (f p)
352− Just _ ->
353− mapOpaleye
354− (\q ->
355− Opaleye.productQueryArr
356− ( Opaleye.distinctOn (key unpackspec) fst
357− . Opaleye.runSimpleQueryArr q
358− )
359− )
360− (f p)
352+distinct (Tabulation f) = Tabulation $
353+ mapOpaleye (Opaleye.distinctOnExplicit (key unpackspec) fst) . f
361354
362355
363356-- | 'order' orders the /values/ of a 'Tabulation' within their
@@ -516,8 +509,8 @@ alignWith :: EqTable k
516509 -> Tabulation k a -> Tabulation k b -> Tabulation k c
517510alignWith f (Tabulation as) (Tabulation bs) = Tabulation $ \p -> do
518511 tkab <- liftF2 (alignBy condition) as bs p
512+ k <- traverse (rebind "key") $ recover $ bimap fst fst tkab
519513 let
520− k = recover $ bimap fst fst tkab
521514 tab = bimap snd snd tkab
522515 pure (k, f tab)
523516 where
@@ -635,3 +628,13 @@ similarity a b = a <* present b
635628-- @do@-notation.
636629difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
637630difference a b = a <* absent b
631+
632+
633+-- | 'Tabulation's can be produced with either 'fromQuery' or 'liftQuery', and
634+-- in some cases we might want to treat these differently. 'peek' uses
635+-- 'unsafePeekQuery' to determine which type of 'Tabulation' we have.
636+peek :: Tabulation k a -> Tabulation k (Either (Query a) (Query (k, a)))
637+peek (Tabulation f) = Tabulation $ \p ->
638+ pure $ (empty,) $ case unsafePeekQuery (f p) of
639+ (Nothing, _) -> Left $ fmap snd (f p)
640+ (Just _, _) -> Right $ fmap (first fromJust) (f p)
src/Rel8/Type.hs+8−8
@@ -128,10 +128,10 @@ instance DBType Int64 where
128128instance DBType Float where
129129 typeInformation = TypeInformation
130130 { encode = \x -> Opaleye.ConstExpr
131− if | x == (1 /0) -> Opaleye.OtherLit "'Infinity'"
132− | isNaN x -> Opaleye.OtherLit "'NaN'"
133− | x == (-1/0) -> Opaleye.OtherLit "'-Infinity'"
134− | otherwise -> Opaleye.NumericLit $ realToFrac x
131+ if | x == (1 / 0) -> Opaleye.OtherLit "'Infinity'"
132+ | isNaN x -> Opaleye.OtherLit "'NaN'"
133+ | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'"
134+ | otherwise -> Opaleye.NumericLit $ realToFrac x
135135 , decode = Hasql.float4
136136 , typeName = "float4"
137137 }
@@ -141,10 +141,10 @@ instance DBType Float where
141141instance DBType Double where
142142 typeInformation = TypeInformation
143143 { encode = \x -> Opaleye.ConstExpr
144− if | x == (1 /0) -> Opaleye.OtherLit "'Infinity'"
145− | isNaN x -> Opaleye.OtherLit "'NaN'"
146− | x == (-1/0) -> Opaleye.OtherLit "'-Infinity'"
147− | otherwise -> Opaleye.NumericLit $ realToFrac x
144+ if | x == (1 / 0) -> Opaleye.OtherLit "'Infinity'"
145+ | isNaN x -> Opaleye.OtherLit "'NaN'"
146+ | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'"
147+ | otherwise -> Opaleye.NumericLit $ realToFrac x
148148 , decode = Hasql.float8
149149 , typeName = "float8"
150150 }
src/Rel8/Type/Enum.hs+1
@@ -106,6 +106,7 @@ class (DBType a, Enumable a) => DBEnum a where
106106
107107-- | Types that are sum types, where each constructor is unary (that is, has no
108108-- fields).
109+type Enumable :: Type -> Constraint
109110class (Generic a, GEnumable (Rep a)) => Enumable a
110111instance (Generic a, GEnumable (Rep a)) => Enumable a
111112
src/Rel8/Type/JSONBEncoded.hs+4
@@ -1,3 +1,5 @@
1+{-# language StandaloneKindSignatures #-}
2+
13module Rel8.Type.JSONBEncoded ( JSONBEncoded(..) ) where
24
35-- aeson
@@ -6,6 +8,7 @@ import Data.Aeson.Types ( parseEither )
68
79-- base
810import Data.Bifunctor ( first )
11+import Data.Kind ( Type )
912import Prelude
1013
1114-- hasql
@@ -20,6 +23,7 @@ import Data.Text ( pack )
2023
2124
2225-- | Like 'Rel8.JSONEncoded', but works for @jsonb@ columns.
26+type JSONBEncoded :: Type -> Type
2327newtype JSONBEncoded a = JSONBEncoded { fromJSONBEncoded :: a }
2428
2529
src/Rel8/Type/JSONEncoded.hs+4
@@ -1,3 +1,5 @@
1+{-# language StandaloneKindSignatures #-}
2+
13module Rel8.Type.JSONEncoded ( JSONEncoded(..) ) where
24
35-- aeson
@@ -5,6 +7,7 @@ import Data.Aeson ( FromJSON, ToJSON, parseJSON, toJSON )
57import Data.Aeson.Types ( parseEither )
68
79-- base
10+import Data.Kind ( Type )
811import Prelude
912
1013-- rel8
@@ -15,6 +18,7 @@ import Rel8.Type.Information ( parseTypeInformation )
1518-- | A deriving-via helper type for column types that store a Haskell value
1619-- using a JSON encoding described by @aeson@'s 'ToJSON' and 'FromJSON' type
1720-- classes.
21+type JSONEncoded :: Type -> Type
1822newtype JSONEncoded a = JSONEncoded { fromJSONEncoded :: a }
1923
2024
src/Rel8/Type/Num.hs+4−1
@@ -18,6 +18,7 @@ import Prelude
1818
1919-- rel8
2020import Rel8.Type ( DBType )
21+import Rel8.Type.Ord ( DBOrd )
2122
2223-- scientific
2324import Data.Scientific ( Scientific )
@@ -39,13 +40,14 @@ instance DBNum Scientific
3940-- expressions. This is a Rel8 concept, and allows us to provide
4041-- 'fromIntegral'.
4142type DBIntegral :: Type -> Constraint
42−class DBNum a => DBIntegral a
43+class (DBNum a, DBOrd a) => DBIntegral a
4344instance DBIntegral Int16
4445instance DBIntegral Int32
4546instance DBIntegral Int64
4647
4748
4849-- | The class of database types that support the @/@ operator.
50+type DBFractional :: Type -> Constraint
4951class DBNum a => DBFractional a
5052instance DBFractional Float
5153instance DBFractional Double
@@ -53,6 +55,7 @@ instance DBFractional Scientific
5355
5456
5557-- | The class of database types that support the @/@ operator.
58+type DBFloating :: Type -> Constraint
5659class DBFractional a => DBFloating a
5760instance DBFloating Float
5861instance DBFloating Double
src/Rel8/Type/ReadShow.hs+3
@@ -1,10 +1,12 @@
11{-# language ScopedTypeVariables #-}
2+{-# language StandaloneKindSignatures #-}
23{-# language TypeApplications #-}
34{-# language ViewPatterns #-}
45
56module Rel8.Type.ReadShow ( ReadShow(..) ) where
67
78-- base
9+import Data.Kind ( Type )
810import Data.Proxy ( Proxy( Proxy ) )
911import Data.Typeable ( Typeable, typeRep )
1012import Prelude
@@ -20,6 +22,7 @@ import qualified Data.Text as Text
2022
2123-- | A deriving-via helper type for column types that store a Haskell value
2224-- using a Haskell's 'Read' and 'Show' type classes.
25+type ReadShow :: Type -> Type
2326newtype ReadShow a = ReadShow { fromReadShow :: a }
2427
2528
src/Rel8/Type/Tag.hs+1
@@ -90,6 +90,7 @@ instance DBMonoid MaybeTag where
9090 memptyExpr = litExpr mempty
9191
9292
93+type Tag :: Type
9394newtype Tag = Tag Text
9495 deriving newtype
9596 ( Eq, Ord, Read, Show
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