git.iko.soy/rel8
on master help sign in
The beginning of rel8 1.0
6360f10Shane O'Brien
.gitignorenew file+1
compare with master
unifiedsplit
@@ -0,0 +1 @@
1+/dist-newstyle
Doctest.hsnew file+33
@@ -0,0 +1,33 @@
1+{-# language BlockArguments #-}
2+{-# language OverloadedStrings #-}
3+
4+module Main where
5+
6+import Build_doctests ( flags, pkgs, module_sources )
7+import Control.Exception ( bracket, throwIO )
8+import Data.ByteString.Char8 ( unpack )
9+import Data.Foldable ( traverse_ )
10+import Database.PostgreSQL.Simple ( connectPostgreSQL, close, execute_ )
11+import Database.Postgres.Temp ( toConnectionString, with, withConfig, verboseConfig )
12+import System.Environment ( setEnv )
13+import System.Environment.Compat ( unsetEnv )
14+import Test.DocTest ( doctest )
15+
16+main :: IO ()
17+main = do
18+ unsetEnv "GHC_ENVIRONMENT" -- see 'Notes'; you may not need this
19+ either throwIO return =<< with \db -> do
20+ setEnv "TEST_DATABASE_URL" (unpack (toConnectionString db))
21+ bracket (connectPostgreSQL (toConnectionString db)) close \conn -> do
22+ execute_ conn "create table author ( author_id serial primary key, name text not null, url text )"
23+ execute_ conn "create table project ( author_id int not null references author (author_id), name text not null )"
24+
25+ execute_ conn "insert into author ( name, url ) values ( 'Ollie', 'https://ocharles.org.uk' )"
26+ execute_ conn "insert into author ( name, url ) values ( 'Bryan O''Sullivan', null )"
27+ execute_ conn "insert into project ( author_id, name ) values ( 1, 'rel8' )"
28+ execute_ conn "insert into project ( author_id, name ) values ( 2, 'aeson' )"
29+
30+ doctest args
31+
32+ where
33+ args = flags ++ pkgs ++ module_sources
LICENSEnew file+26
@@ -0,0 +1,26 @@
1+Copyright 2020 Oliver Charles
2+
3+All rights reserved.
4+
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions
7+are met:
8+
9+1. Redistributions of source code must retain the above copyright
10+ notice, this list of conditions and the following disclaimer.
11+
12+2. Redistributions in binary form must reproduce the above copyright
13+ notice, this list of conditions and the following disclaimer in the
14+ documentation and/or other materials provided with the distribution.
15+
16+THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
17+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
18+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
19+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
20+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
21+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
22+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
23+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
24+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
25+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
26+POSSIBILITY OF SUCH DAMAGE.
Setup.hsnew file+6
@@ -0,0 +1,6 @@
1+module Main where
2+
3+import Distribution.Extra.Doctest (defaultMainWithDoctests)
4+
5+main :: IO ()
6+main = defaultMainWithDoctests "doctests"
cabal.projectnew file+1
@@ -0,0 +1 @@
1+packages: .
default.nixnew file+29
@@ -0,0 +1,29 @@
1+let
2+ haskellNix = import (import ./nix/sources.nix)."haskell.nix" {};
3+
4+ nixpkgsSrc = haskellNix.sources.nixpkgs-2009;
5+
6+ nixpkgsArgs = haskellNix.nixpkgsArgs;
7+
8+ compiler-nix-name = "ghc8103";
9+
10+ pkgs = import nixpkgsSrc nixpkgsArgs;
11+
12+in
13+pkgs.haskell-nix.project {
14+ inherit compiler-nix-name;
15+
16+ src = pkgs.haskell-nix.haskellLib.cleanGit {
17+ name = "rel8";
18+ src = ./.;
19+ };
20+
21+ modules = [
22+ { packages.rel8 = {
23+ preCheck = ''
24+ export PATH="${pkgs.postgresql}/bin:${"$PATH"}"
25+ '';
26+ };
27+ }
28+ ];
29+}
jobs.nixnew file+5
@@ -0,0 +1,5 @@
1+let rel8 = (import ./.).hsPkgs.rel8;
2+in {
3+ rel8 = rel8.components.library;
4+ tests = rel8.checks.tests;
5+}
nix/sources.jsonnew file+38
@@ -0,0 +1,38 @@
1+{
2+ "haskell.nix": {
3+ "branch": "circuithub",
4+ "description": "Alternative Haskell Infrastructure for Nixpkgs",
5+ "homepage": "https://input-output-hk.github.io/haskell.nix",
6+ "owner": "circuithub",
7+ "repo": "haskell.nix",
8+ "rev": "2902f9b49484a87afb0e1a33b1d88a2c7b8ca0a0",
9+ "sha256": "0a01g5b46z5yaf2mnl415hc4lciwiyqhj22qhgwgwd261w4068iy",
10+ "type": "tarball",
11+ "url": "https://github.com/circuithub/haskell.nix/archive/2902f9b49484a87afb0e1a33b1d88a2c7b8ca0a0.tar.gz",
12+ "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
13+ },
14+ "niv": {
15+ "branch": "master",
16+ "description": "Easy dependency management for Nix projects",
17+ "homepage": "https://github.com/nmattia/niv",
18+ "owner": "nmattia",
19+ "repo": "niv",
20+ "rev": "ba57d5a29b4e0f2085917010380ef3ddc3cf380f",
21+ "sha256": "1kpsvc53x821cmjg1khvp1nz7906gczq8mp83664cr15h94sh8i4",
22+ "type": "tarball",
23+ "url": "https://github.com/nmattia/niv/archive/ba57d5a29b4e0f2085917010380ef3ddc3cf380f.tar.gz",
24+ "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
25+ },
26+ "nixpkgs": {
27+ "branch": "nixos-20.09",
28+ "description": "Nix Packages collection",
29+ "homepage": null,
30+ "owner": "nixos",
31+ "repo": "nixpkgs",
32+ "rev": "6e7f25001fe6874f7ae271891f709bbf50a22c45",
33+ "sha256": "1x04j4351pqiqbpkq6g308mxcvb5aqnwv8l2vmlxkgvq5phzky7z",
34+ "type": "tarball",
35+ "url": "https://github.com/nixos/nixpkgs/archive/6e7f25001fe6874f7ae271891f709bbf50a22c45.tar.gz",
36+ "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
37+ }
38+}
nix/sources.nixnew file+148
@@ -0,0 +1,148 @@
1+# This file has been generated by Niv.
2+
3+let
4+
5+ #
6+ # The fetchers. fetch_<type> fetches specs of type <type>.
7+ #
8+
9+ fetch_file = pkgs: spec:
10+ if spec.builtin or true then
11+ builtins_fetchurl { inherit (spec) url sha256; }
12+ else
13+ pkgs.fetchurl { inherit (spec) url sha256; };
14+
15+ fetch_tarball = pkgs: name: spec:
16+ let
17+ ok = str: ! builtins.isNull (builtins.match "[a-zA-Z0-9+-._?=]" str);
18+ # sanitize the name, though nix will still fail if name starts with period
19+ name' = stringAsChars (x: if ! ok x then "-" else x) "${name}-src";
20+ in
21+ if spec.builtin or true then
22+ builtins_fetchTarball { name = name'; inherit (spec) url sha256; }
23+ else
24+ pkgs.fetchzip { name = name'; inherit (spec) url sha256; };
25+
26+ fetch_git = spec:
27+ builtins.fetchGit { url = spec.repo; inherit (spec) rev ref; };
28+
29+ fetch_local = spec: spec.path;
30+
31+ fetch_builtin-tarball = name: throw
32+ ''[${name}] The niv type "builtin-tarball" is deprecated. You should instead use `builtin = true`.
33+ $ niv modify ${name} -a type=tarball -a builtin=true'';
34+
35+ fetch_builtin-url = name: throw
36+ ''[${name}] The niv type "builtin-url" will soon be deprecated. You should instead use `builtin = true`.
37+ $ niv modify ${name} -a type=file -a builtin=true'';
38+
39+ #
40+ # Various helpers
41+ #
42+
43+ # The set of packages used when specs are fetched using non-builtins.
44+ mkPkgs = sources:
45+ let
46+ sourcesNixpkgs =
47+ import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) {};
48+ hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath;
49+ hasThisAsNixpkgsPath = <nixpkgs> == ./.;
50+ in
51+ if builtins.hasAttr "nixpkgs" sources
52+ then sourcesNixpkgs
53+ else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then
54+ import <nixpkgs> {}
55+ else
56+ abort
57+ ''
58+ Please specify either <nixpkgs> (through -I or NIX_PATH=nixpkgs=...) or
59+ add a package called "nixpkgs" to your sources.json.
60+ '';
61+
62+ # The actual fetching function.
63+ fetch = pkgs: name: spec:
64+
65+ if ! builtins.hasAttr "type" spec then
66+ abort "ERROR: niv spec ${name} does not have a 'type' attribute"
67+ else if spec.type == "file" then fetch_file pkgs spec
68+ else if spec.type == "tarball" then fetch_tarball pkgs name spec
69+ else if spec.type == "git" then fetch_git spec
70+ else if spec.type == "local" then fetch_local spec
71+ else if spec.type == "builtin-tarball" then fetch_builtin-tarball name
72+ else if spec.type == "builtin-url" then fetch_builtin-url name
73+ else
74+ abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}";
75+
76+ # If the environment variable NIV_OVERRIDE_${name} is set, then use
77+ # the path directly as opposed to the fetched source.
78+ replace = name: drv:
79+ let
80+ saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name;
81+ ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}";
82+ in
83+ if ersatz == "" then drv else ersatz;
84+
85+ # Ports of functions for older nix versions
86+
87+ # a Nix version of mapAttrs if the built-in doesn't exist
88+ mapAttrs = builtins.mapAttrs or (
89+ f: set: with builtins;
90+ listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set))
91+ );
92+
93+ # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/lists.nix#L295
94+ range = first: last: if first > last then [] else builtins.genList (n: first + n) (last - first + 1);
95+
96+ # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L257
97+ stringToCharacters = s: map (p: builtins.substring p 1 s) (range 0 (builtins.stringLength s - 1));
98+
99+ # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269
100+ stringAsChars = f: s: concatStrings (map f (stringToCharacters s));
101+ concatStrings = builtins.concatStringsSep "";
102+
103+ # fetchTarball version that is compatible between all the versions of Nix
104+ builtins_fetchTarball = { url, name, sha256 }@attrs:
105+ let
106+ inherit (builtins) lessThan nixVersion fetchTarball;
107+ in
108+ if lessThan nixVersion "1.12" then
109+ fetchTarball { inherit name url; }
110+ else
111+ fetchTarball attrs;
112+
113+ # fetchurl version that is compatible between all the versions of Nix
114+ builtins_fetchurl = { url, sha256 }@attrs:
115+ let
116+ inherit (builtins) lessThan nixVersion fetchurl;
117+ in
118+ if lessThan nixVersion "1.12" then
119+ fetchurl { inherit url; }
120+ else
121+ fetchurl attrs;
122+
123+ # Create the final "sources" from the config
124+ mkSources = config:
125+ mapAttrs (
126+ name: spec:
127+ if builtins.hasAttr "outPath" spec
128+ then abort
129+ "The values in sources.json should not have an 'outPath' attribute"
130+ else
131+ spec // { outPath = replace name (fetch config.pkgs name spec); }
132+ ) config.sources;
133+
134+ # The "config" used by the fetchers
135+ mkConfig =
136+ { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null
137+ , sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile)
138+ , pkgs ? mkPkgs sources
139+ }: rec {
140+ # The sources, i.e. the attribute set of spec name to spec
141+ inherit sources;
142+
143+ # The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers
144+ inherit pkgs;
145+ };
146+
147+in
148+mkSources (mkConfig {}) // { __functor = _: settings: mkSources (mkConfig settings); }
rel8.cabalnew file+204
@@ -0,0 +1,204 @@
1+cabal-version: 2.0
2+name: rel8
3+version: 0.1.0.0
4+synopsis: Hey! Hey! Can u rel8?
5+license: BSD3
6+license-file: LICENSE
7+author: Oliver Charles
8+maintainer: ollie@ocharles.org.uk
9+build-type: Custom
10+
11+custom-setup
12+ setup-depends:
13+ base >= 4 && <5,
14+ Cabal,
15+ cabal-doctest >= 1 && <1.1
16+
17+library
18+ build-depends:
19+ aeson
20+ , base ^>=4.12 || ^>= 4.13 || ^>= 4.14
21+ , bytestring
22+ , case-insensitive
23+ , casing
24+ , contravariant
25+ , hasql
26+ , opaleye ^>= 0.7.1.0
27+ , profunctors
28+ , scientific
29+ , semialign
30+ , semigroupoids
31+ , text
32+ , these
33+ , time
34+ , uuid
35+ default-language:
36+ Haskell2010
37+ ghc-options:
38+ -Weverything -Wno-unsafe -Wno-safe -Wno-missing-safe-haskell-mode
39+ -Wno-missing-import-lists -Wno-prepositive-qualified-module
40+ -Wno-monomorphism-restriction
41+ -Wno-missing-local-signatures
42+ hs-source-dirs:
43+ src
44+ exposed-modules:
45+ Rel8.Aggregate
46+
47+ Rel8.Expr
48+ Rel8.Expr.Aggregate
49+ Rel8.Expr.Array
50+ Rel8.Expr.Bool
51+ Rel8.Expr.Eq
52+ Rel8.Expr.Function
53+ Rel8.Expr.Null
54+ Rel8.Expr.Num
55+ Rel8.Expr.Opaleye
56+ Rel8.Expr.Ord
57+ Rel8.Expr.Order
58+ Rel8.Expr.Serialize
59+ Rel8.Expr.Text
60+ Rel8.Expr.Time
61+
62+ Rel8.Kind.Bool
63+ Rel8.Kind.Labels
64+ Rel8.Kind.Necessity
65+
66+ Rel8.Order
67+
68+ Rel8.Query
69+ Rel8.Query.Aggregate
70+ Rel8.Query.Distinct
71+ Rel8.Query.Each
72+ Rel8.Query.Either
73+ Rel8.Query.Exists
74+ Rel8.Query.Filter
75+ Rel8.Query.Limit
76+ Rel8.Query.List
77+ Rel8.Query.Maybe
78+ Rel8.Query.Null
79+ Rel8.Query.Opaleye
80+ Rel8.Query.Optimize
81+ Rel8.Query.Order
82+ Rel8.Query.Set
83+ Rel8.Query.SQL
84+ Rel8.Query.These
85+ Rel8.Query.Values
86+
87+ Rel8.Schema.Column
88+ Rel8.Schema.Context
89+ Rel8.Schema.Context.Label
90+ Rel8.Schema.Context.Nullify
91+ Rel8.Schema.Context.Result
92+ Rel8.Schema.Dict
93+ Rel8.Schema.Field
94+ Rel8.Schema.Generic
95+ Rel8.Schema.Generic.Test
96+ Rel8.Schema.HTable
97+ Rel8.Schema.HTable.Context
98+ Rel8.Schema.HTable.Either
99+ Rel8.Schema.HTable.Identity
100+ Rel8.Schema.HTable.Label
101+ Rel8.Schema.HTable.List
102+ Rel8.Schema.HTable.Maybe
103+ Rel8.Schema.HTable.NonEmpty
104+ Rel8.Schema.HTable.Nullify
105+ Rel8.Schema.HTable.Pair
106+ Rel8.Schema.HTable.Quartet
107+ Rel8.Schema.HTable.Quintet
108+ Rel8.Schema.HTable.These
109+ Rel8.Schema.HTable.Trio
110+ Rel8.Schema.HTable.Type
111+ Rel8.Schema.HTable.Vectorize
112+ Rel8.Schema.Nullability
113+ Rel8.Schema.Spec
114+ Rel8.Schema.Spec.ConstrainContext
115+ Rel8.Schema.Spec.ConstrainDBType
116+ Rel8.Schema.Spec.ConstrainType
117+ Rel8.Schema.Table
118+
119+ Rel8.Statement.Delete
120+ Rel8.Statement.Insert
121+ Rel8.Statement.Returning
122+ Rel8.Statement.Select
123+ Rel8.Statement.Update
124+ Rel8.Statement.View
125+
126+ Rel8.Table
127+ Rel8.Table.Aggregate
128+ Rel8.Table.Alternative
129+ Rel8.Table.Bool
130+ Rel8.Table.Either
131+ Rel8.Table.Eq
132+ Rel8.Table.Insert
133+ Rel8.Table.Lifted
134+ Rel8.Table.List
135+ Rel8.Table.Maybe
136+ Rel8.Table.Name
137+ Rel8.Table.NonEmpty
138+ Rel8.Table.Opaleye
139+ Rel8.Table.Ord
140+ Rel8.Table.Order
141+ Rel8.Table.Recontextualize
142+ Rel8.Table.Serialize
143+ Rel8.Table.These
144+ Rel8.Table.Undefined
145+
146+ Rel8.Tabulate
147+
148+ Rel8.Type
149+ Rel8.Type.Array
150+ Rel8.Type.Eq
151+ Rel8.Type.Information
152+ Rel8.Type.Monoid
153+ Rel8.Type.Num
154+ Rel8.Type.Ord
155+ Rel8.Type.Semigroup
156+ Rel8.Type.String
157+ Rel8.Type.Sum
158+ Rel8.Type.Tag
159+
160+ other-modules:
161+ Rel8.Opaque
162+ Rel8.Schema.Structure
163+
164+test-suite tests
165+ type: exitcode-stdio-1.0
166+ build-depends:
167+ base
168+ , bytestring
169+ , case-insensitive
170+ , containers
171+ , hasql
172+ , hedgehog ^>=1.0.2
173+ , lifted-base ^>=0.2.3.12
174+ , monad-control ^>=1.0.2.3
175+ , rel8
176+ , scientific
177+ , tasty
178+ , tasty-hedgehog
179+ , text
180+ , time
181+ , tmp-postgres ^>=1.34.1.0
182+ , uuid
183+
184+ main-is: Main.hs
185+ hs-source-dirs: tests
186+ default-language: Haskell2010
187+ ghc-options:
188+ -Weverything -Wno-unsafe -Wno-safe -Wno-missing-safe-haskell-mode
189+ -Wno-missing-import-lists -Wno-prepositive-qualified-module
190+ -Wno-deprecations -Wno-monomorphism-restriction
191+ -Wno-missing-local-signatures -Wno-implicit-prelude
192+
193+test-suite doctests
194+ type: exitcode-stdio-1.0
195+ build-depends:
196+ base
197+ , base-compat
198+ , bytestring
199+ , doctest
200+ , hasql
201+ , tmp-postgres
202+
203+ main-is: Doctest.hs
204+ default-language: Haskell2010
shell.nixnew file+11
@@ -0,0 +1,11 @@
1+let
2+ sources = import ./nix/sources.nix;
3+ pkgs = import sources.nixpkgs {};
4+ hsPkgs = import ./default.nix;
5+in
6+ hsPkgs.shellFor {
7+ withHoogle = true;
8+ tools = { cabal = "3.2.0.0"; haskell-language-server = "latest"; };
9+ exactDeps = false;
10+ buildInputs = [ pkgs.postgresql ];
11+ }
src/Rel8/Aggregate.hsnew file+68
@@ -0,0 +1,68 @@
1+{-# language DerivingVia #-}
2+{-# language GeneralizedNewtypeDeriving #-}
3+{-# language NamedFieldPuns #-}
4+{-# language StandaloneKindSignatures #-}
5+
6+module Rel8.Aggregate
7+ ( Aggregate(..), foldInputs, mapInputs
8+ , Aggregator(..), unsafeMakeAggregate
9+ )
10+where
11+
12+-- base
13+import Data.Functor.Const ( Const( Const ), getConst )
14+import Data.Kind ( Type )
15+import Prelude
16+
17+-- opaleye
18+import qualified Opaleye.Internal.Aggregate as Opaleye
19+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
20+import qualified Opaleye.Internal.PackMap as Opaleye
21+
22+-- semigroupoids
23+import Data.Functor.Apply ( Apply, WrappedApplicative(..) )
24+
25+
26+type Aggregate :: Type -> Type
27+newtype Aggregate a = Aggregate (Opaleye.Aggregator () a)
28+ deriving newtype Functor
29+ deriving Apply via (WrappedApplicative (Opaleye.Aggregator ()))
30+
31+
32+foldInputs :: Monoid b
33+ => (Maybe Aggregator -> Opaleye.PrimExpr -> b) -> Aggregate a -> b
34+foldInputs f (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =
35+ getConst $ flip agg () $ \(aggregator, a) ->
36+ Const $ f (detuplize <$> aggregator) a
37+ where
38+ detuplize (operation, ordering, distinction) =
39+ Aggregator {operation, ordering, distinction}
40+
41+
42+mapInputs :: ()
43+ => (Opaleye.PrimExpr -> Opaleye.PrimExpr) -> Aggregate a -> Aggregate a
44+mapInputs transform (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =
45+ Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ agg . \f input ->
46+ f (fmap transform input)
47+
48+
49+type Aggregator :: Type
50+data Aggregator = Aggregator
51+ { operation :: Opaleye.AggrOp
52+ , ordering :: [Opaleye.OrderExpr]
53+ , distinction :: Opaleye.AggrDistinct
54+ }
55+
56+
57+unsafeMakeAggregate :: ()
58+ => (input -> Opaleye.PrimExpr)
59+ -> (Opaleye.PrimExpr -> output)
60+ -> Maybe Aggregator
61+ -> input
62+ -> Aggregate output
63+unsafeMakeAggregate input output aggregator expr =
64+ Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ \f _ ->
65+ output <$> f (tuplize <$> aggregator, input expr)
66+ where
67+ tuplize Aggregator {operation, ordering, distinction} =
68+ (operation, ordering, distinction)
src/Rel8/Expr.hsnew file+84
@@ -0,0 +1,84 @@
1+{-# language DataKinds #-}
2+{-# language DerivingStrategies #-}
3+{-# language FlexibleContexts #-}
4+{-# language GADTs #-}
5+{-# language RoleAnnotations #-}
6+{-# language ScopedTypeVariables #-}
7+{-# language StandaloneKindSignatures #-}
8+{-# language TypeApplications #-}
9+{-# language UndecidableInstances #-}
10+
11+module Rel8.Expr
12+ ( Expr(..)
13+ )
14+where
15+
16+-- base
17+import Data.Kind ( Type )
18+import Data.String ( IsString, fromString )
19+import Prelude hiding ( null )
20+
21+-- opaleye
22+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
23+
24+-- rel8
25+import Rel8.Expr.Null ( liftOpNullable, nullify )
26+import Rel8.Expr.Opaleye
27+ ( castExpr
28+ , unsafeFromPrimExpr
29+ , mapPrimExpr
30+ , zipPrimExprsWith
31+ )
32+import Rel8.Expr.Serialize ( litExpr )
33+import Rel8.Schema.Nullability
34+ ( Nullability( Nullable, NonNullable )
35+ , Nullabilizes, nullabilization
36+ )
37+import Rel8.Type ( DBType )
38+import Rel8.Type.Monoid ( DBMonoid, memptyExpr )
39+import Rel8.Type.Num ( DBFractional, DBNum )
40+import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )
41+
42+
43+type role Expr representational
44+type Expr :: Type -> Type
45+newtype Expr a = Expr Opaleye.PrimExpr
46+ deriving stock Show
47+
48+
49+instance (DBSemigroup db, Nullabilizes db a) => Semigroup (Expr a) where
50+ (<>) = case nullabilization @a of
51+ Nullable -> liftOpNullable (<>.)
52+ NonNullable -> (<>.)
53+
54+
55+instance (DBMonoid db, Nullabilizes db a) => Monoid (Expr a) where
56+ mempty = case nullabilization @a of
57+ Nullable -> nullify memptyExpr
58+ NonNullable -> memptyExpr
59+
60+
61+instance (IsString db, DBType db, Nullabilizes db a) => IsString (Expr a) where
62+ fromString = litExpr . case nullabilization @a of
63+ Nullable -> Just . fromString
64+ NonNullable -> fromString
65+
66+
67+instance (DBNum db, Nullabilizes db a) => Num (Expr a) where
68+ (+) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:+))
69+ (*) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:*))
70+ (-) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:-))
71+
72+ abs = mapPrimExpr (Opaleye.UnExpr Opaleye.OpAbs)
73+ negate = mapPrimExpr (Opaleye.UnExpr Opaleye.OpNegate)
74+
75+ signum = castExpr . mapPrimExpr (Opaleye.UnExpr (Opaleye.UnOpOther "SIGN"))
76+
77+ fromInteger = castExpr . unsafeFromPrimExpr . Opaleye.ConstExpr . Opaleye.IntegerLit
78+
79+
80+instance (DBFractional db, Nullabilizes db a) => Fractional (Expr a) where
81+ (/) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:/))
82+
83+ fromRational =
84+ castExpr . Expr . Opaleye.ConstExpr . Opaleye.NumericLit . realToFrac
src/Rel8/Expr.hs-bootnew file+19
@@ -0,0 +1,19 @@
1+{-# language RoleAnnotations #-}
2+{-# language StandaloneKindSignatures #-}
3+
4+module Rel8.Expr
5+ ( Expr(..)
6+ )
7+where
8+
9+-- base
10+import Data.Kind ( Type )
11+import Prelude ()
12+
13+-- opaleye
14+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
15+
16+
17+type role Expr representational
18+type Expr :: Type -> Type
19+newtype Expr a = Expr Opaleye.PrimExpr
src/Rel8/Expr/Aggregate.hsnew file+158
@@ -0,0 +1,158 @@
1+{-# language DataKinds #-}
2+{-# language ScopedTypeVariables #-}
3+{-# language TypeApplications #-}
4+{-# language TypeFamilies #-}
5+
6+{-# options_ghc -fno-warn-redundant-constraints #-}
7+
8+module Rel8.Expr.Aggregate
9+ ( count, countDistinct, countStar, countWhere
10+ , and, or
11+ , min, max
12+ , sum, sumWhere
13+ , stringAgg
14+ , groupByExpr
15+ , listAggExpr, nonEmptyAggExpr
16+ , sgroupByExpr
17+ )
18+where
19+
20+-- base
21+import Data.Int ( Int64 )
22+import Data.List.NonEmpty ( NonEmpty )
23+import Prelude hiding ( and, max, min, null, or, sum )
24+
25+-- opaleye
26+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
27+
28+-- rel8
29+import Rel8.Aggregate ( Aggregate, Aggregator(..), unsafeMakeAggregate )
30+import Rel8.Expr ( Expr )
31+import Rel8.Expr.Bool ( caseExpr )
32+import Rel8.Expr.Opaleye
33+ ( castExpr
34+ , fromPrimExpr
35+ , unsafeFromPrimExpr
36+ , unsafeToPrimExpr
37+ )
38+import Rel8.Expr.Null ( null )
39+import Rel8.Expr.Serialize ( litExpr )
40+import Rel8.Schema.Nullability ( Nullability, Nullabilizes, nullabilization )
41+import Rel8.Type.Eq ( DBEq )
42+import Rel8.Type.Num ( DBNum )
43+import Rel8.Type.Ord ( DBMax, DBMin )
44+import Rel8.Type.String ( DBString )
45+import Rel8.Type.Sum ( DBSum )
46+
47+
48+count :: Expr a -> Aggregate (Expr Int64)
49+count = unsafeMakeAggregate unsafeToPrimExpr unsafeFromPrimExpr $
50+ Just Aggregator
51+ { operation = Opaleye.AggrCount
52+ , ordering = []
53+ , distinction = Opaleye.AggrAll
54+ }
55+
56+
57+countDistinct :: DBEq a => Expr a -> Aggregate (Expr Int64)
58+countDistinct = unsafeMakeAggregate unsafeToPrimExpr unsafeFromPrimExpr $
59+ Just Aggregator
60+ { operation = Opaleye.AggrCount
61+ , ordering = []
62+ , distinction = Opaleye.AggrDistinct
63+ }
64+
65+
66+countStar :: Aggregate (Expr Int64)
67+countStar = count (litExpr True)
68+
69+
70+countWhere :: Expr Bool -> Aggregate (Expr Int64)
71+countWhere condition = count (caseExpr [(condition, litExpr (Just True))] null)
72+
73+
74+and :: Expr Bool -> Aggregate (Expr Bool)
75+and = unsafeMakeAggregate unsafeToPrimExpr unsafeFromPrimExpr $
76+ Just Aggregator
77+ { operation = Opaleye.AggrBoolAnd
78+ , ordering = []
79+ , distinction = Opaleye.AggrAll
80+ }
81+
82+
83+or :: Expr Bool -> Aggregate (Expr Bool)
84+or = unsafeMakeAggregate unsafeToPrimExpr unsafeFromPrimExpr $
85+ Just Aggregator
86+ { operation = Opaleye.AggrBoolOr
87+ , ordering = []
88+ , distinction = Opaleye.AggrAll
89+ }
90+
91+
92+max :: (DBMax db, Nullabilizes db a) => Expr a -> Aggregate (Expr a)
93+max = unsafeMakeAggregate unsafeToPrimExpr unsafeFromPrimExpr $
94+ Just Aggregator
95+ { operation = Opaleye.AggrSum
96+ , ordering = []
97+ , distinction = Opaleye.AggrAll
98+ }
99+
100+
101+min :: (DBMin db, Nullabilizes db a) => Expr a -> Aggregate (Expr a)
102+min = unsafeMakeAggregate unsafeToPrimExpr unsafeFromPrimExpr $
103+ Just Aggregator
104+ { operation = Opaleye.AggrSum
105+ , ordering = []
106+ , distinction = Opaleye.AggrAll
107+ }
108+
109+
110+sum :: (DBSum db, Nullabilizes db a) => Expr a -> Aggregate (Expr a)
111+sum = unsafeMakeAggregate unsafeToPrimExpr (castExpr . unsafeFromPrimExpr) $
112+ Just Aggregator
113+ { operation = Opaleye.AggrSum
114+ , ordering = []
115+ , distinction = Opaleye.AggrAll
116+ }
117+
118+
119+sumWhere :: (DBNum db, DBSum db, Nullabilizes db a)
120+ => Expr Bool -> Expr a -> Aggregate (Expr a)
121+sumWhere condition a = sum (caseExpr [(condition, a)] 0)
122+
123+
124+stringAgg :: (DBString db, Nullabilizes db a)
125+ => Expr db -> Expr a -> Aggregate (Expr a)
126+stringAgg delimiter =
127+ unsafeMakeAggregate unsafeToPrimExpr (castExpr . unsafeFromPrimExpr) $
128+ Just Aggregator
129+ { operation = Opaleye.AggrStringAggr (unsafeToPrimExpr delimiter)
130+ , ordering = []
131+ , distinction = Opaleye.AggrAll
132+ }
133+
134+
135+groupByExpr :: (DBEq db, Nullabilizes db a) => Expr a -> Aggregate (Expr a)
136+groupByExpr = sgroupByExpr nullabilization
137+
138+
139+listAggExpr :: Expr a -> Aggregate (Expr [a])
140+listAggExpr = unsafeMakeAggregate unsafeToPrimExpr fromPrimExpr $ Just
141+ Aggregator
142+ { operation = Opaleye.AggrArr
143+ , ordering = []
144+ , distinction = Opaleye.AggrAll
145+ }
146+
147+
148+nonEmptyAggExpr :: Expr a -> Aggregate (Expr (NonEmpty a))
149+nonEmptyAggExpr = unsafeMakeAggregate unsafeToPrimExpr fromPrimExpr $ Just
150+ Aggregator
151+ { operation = Opaleye.AggrArr
152+ , ordering = []
153+ , distinction = Opaleye.AggrAll
154+ }
155+
156+
157+sgroupByExpr :: DBEq db => Nullability db a -> Expr a -> Aggregate (Expr a)
158+sgroupByExpr _ = unsafeMakeAggregate unsafeToPrimExpr unsafeFromPrimExpr Nothing
src/Rel8/Expr/Array.hsnew file+59
@@ -0,0 +1,59 @@
1+{-# language DataKinds #-}
2+{-# language FlexibleContexts #-}
3+{-# language ScopedTypeVariables #-}
4+{-# language TypeApplications #-}
5+{-# language TypeFamilies #-}
6+
7+{-# options_ghc -fno-warn-redundant-constraints #-}
8+
9+module Rel8.Expr.Array
10+ ( listOf, nonEmptyOf
11+ , sappend, sappend1, sempty
12+ )
13+where
14+
15+-- base
16+import Data.List.NonEmpty ( NonEmpty )
17+import Prelude
18+
19+-- opaleye
20+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
21+
22+-- rel8
23+import {-# SOURCE #-} Rel8.Expr ( Expr )
24+import Rel8.Expr.Opaleye
25+ ( unsafeFromPrimExpr, unsafeToPrimExpr
26+ , zipPrimExprsWith
27+ )
28+import Rel8.Type ( DBType, typeInformation )
29+import Rel8.Type.Array ( array )
30+import Rel8.Type.Information ( TypeInformation(..) )
31+import Rel8.Schema.Nullability ( Nullability, Nullabilizes )
32+
33+
34+sappend :: Expr [a] -> Expr [a] -> Expr [a]
35+sappend = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
36+
37+
38+sappend1 :: Expr (NonEmpty a) -> Expr (NonEmpty a) -> Expr (NonEmpty a)
39+sappend1 = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
40+
41+
42+sempty :: Nullability t a -> TypeInformation t -> Expr [a]
43+sempty _ info = unsafeFromPrimExpr $ array info []
44+
45+
46+listOf :: forall a t. (Nullabilizes t a, DBType t)
47+ => [Expr a] -> Expr [a]
48+listOf =
49+ unsafeFromPrimExpr .
50+ array (typeInformation @t) .
51+ fmap unsafeToPrimExpr
52+
53+
54+nonEmptyOf :: forall a t. (Nullabilizes t a, DBType t)
55+ => NonEmpty (Expr a) -> Expr (NonEmpty a)
56+nonEmptyOf =
57+ unsafeFromPrimExpr .
58+ array (typeInformation @t) .
59+ fmap unsafeToPrimExpr
src/Rel8/Expr/Bool.hsnew file+68
@@ -0,0 +1,68 @@
1+module Rel8.Expr.Bool
2+ ( false, true
3+ , (&&.), (||.), not_
4+ , and_, or_
5+ , boolExpr
6+ , caseExpr
7+ , fromTrool
8+ )
9+where
10+
11+-- base
12+import Data.Foldable ( foldl' )
13+import Prelude hiding ( null )
14+
15+-- opaleye
16+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
17+
18+-- rel8
19+import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
20+import Rel8.Expr.Opaleye ( mapPrimExpr, zipPrimExprsWith )
21+import Rel8.Expr.Serialize ( litExpr )
22+
23+
24+false :: Expr Bool
25+false = litExpr False
26+
27+
28+true :: Expr Bool
29+true = litExpr True
30+
31+
32+(&&.) :: Expr Bool -> Expr Bool -> Expr Bool
33+(&&.) = zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpAnd)
34+infixr 3 &&.
35+
36+
37+(||.) :: Expr Bool -> Expr Bool -> Expr Bool
38+(||.) = zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpOr)
39+infixr 2 ||.
40+
41+
42+not_ :: Expr Bool -> Expr Bool
43+not_ = mapPrimExpr (Opaleye.UnExpr Opaleye.OpNot)
44+
45+
46+and_ :: Foldable f => f (Expr Bool) -> Expr Bool
47+and_ = foldl' (&&.) true
48+
49+
50+or_ :: Foldable f => f (Expr Bool) -> Expr Bool
51+or_ = foldl' (||.) false
52+
53+
54+boolExpr :: Expr a -> Expr a -> Expr Bool -> Expr a
55+boolExpr ifFalse ifTrue condition = caseExpr [(condition, ifTrue)] ifFalse
56+
57+
58+caseExpr :: [(Expr Bool, Expr a)] -> Expr a -> Expr a
59+caseExpr branches (Expr fallback) =
60+ Expr $ Opaleye.CaseExpr (map go branches) fallback
61+ where
62+ go (Expr condition, Expr value) = (condition, value)
63+
64+
65+fromTrool :: Expr (Maybe Bool) -> Expr Bool
66+fromTrool (Expr a) = Expr a &&. Expr (Opaleye.FunExpr "COALESCE" [a, untrue])
67+ where
68+ untrue = Opaleye.ConstExpr (Opaleye.BoolLit False)
src/Rel8/Expr/Eq.hsnew file+93
@@ -0,0 +1,93 @@
1+{-# language GADTs #-}
2+{-# language LambdaCase #-}
3+{-# language ViewPatterns #-}
4+
5+{-# options_ghc -fno-warn-redundant-constraints #-}
6+
7+module Rel8.Expr.Eq
8+ ( seq, sne
9+ , (==.), (/=.)
10+ , (==?), (/=?)
11+ , in_
12+ )
13+where
14+
15+-- base
16+import Data.Foldable ( toList )
17+import Data.List.NonEmpty ( nonEmpty )
18+import Prelude hiding ( seq, sin )
19+
20+-- opaleye
21+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
22+
23+-- rel8
24+import Rel8.Expr ( Expr )
25+import Rel8.Expr.Bool ( (&&.), (||.), false, or_, fromTrool )
26+import Rel8.Expr.Null ( isNull, unsafeLiftOpNullable )
27+import Rel8.Expr.Opaleye
28+ ( unsafeFromPrimExpr, unsafeToPrimExpr
29+ , unsafeZipPrimExprsWith
30+ )
31+import Rel8.Schema.Nullability
32+ ( Nullability( NonNullable, Nullable )
33+ , Nullabilizes, nullabilization
34+ )
35+import Rel8.Type.Eq ( DBEq )
36+
37+
38+eq :: DBEq a => Expr a -> Expr a -> Expr Bool
39+eq = unsafeZipPrimExprsWith (Opaleye.BinExpr (Opaleye.:==))
40+
41+
42+ne :: DBEq a => Expr a -> Expr a -> Expr Bool
43+ne = unsafeZipPrimExprsWith (Opaleye.BinExpr (Opaleye.:<>))
44+
45+
46+seq :: DBEq db => Nullability db a -> Expr a -> Expr a -> Expr Bool
47+seq = \case
48+ Nullable -> \ma mb -> isNull ma &&. isNull mb ||. ma ==? mb
49+ NonNullable -> eq
50+
51+
52+sne :: DBEq db => Nullability db a -> Expr a -> Expr a -> Expr Bool
53+sne = \case
54+ Nullable -> \ma mb -> isNull ma `ne` isNull mb ||. ma /=? mb
55+ NonNullable -> ne
56+
57+
58+sin :: (DBEq db, Foldable f)
59+ => Nullability db a -> f (Expr a) -> Expr a -> Expr Bool
60+sin nullability (toList -> as) a = case nullability of
61+ Nullable -> or_ $ map (seq Nullable a) as
62+ NonNullable -> case nonEmpty as of
63+ Nothing -> false
64+ Just xs ->
65+ unsafeFromPrimExpr $
66+ Opaleye.BinExpr Opaleye.OpIn
67+ (unsafeToPrimExpr a)
68+ (Opaleye.ListExpr (unsafeToPrimExpr <$> xs))
69+
70+
71+(==.) :: (DBEq db, Nullabilizes db a) => Expr a -> Expr a -> Expr Bool
72+(==.) = seq nullabilization
73+infix 4 ==.
74+
75+
76+(/=.) :: (DBEq db, Nullabilizes db a) => Expr a -> Expr a -> Expr Bool
77+(/=.) = sne nullabilization
78+infix 4 /=.
79+
80+
81+(==?) :: DBEq a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
82+a ==? b = fromTrool $ unsafeLiftOpNullable eq a b
83+infix 4 ==?
84+
85+
86+(/=?) :: DBEq a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
87+a /=? b = fromTrool $ unsafeLiftOpNullable ne a b
88+infix 4 /=?
89+
90+
91+in_ :: (DBEq db, Nullabilizes db a, Foldable f)
92+ => f (Expr a) -> Expr a -> Expr Bool
93+in_ = sin nullabilization
src/Rel8/Expr/Function.hsnew file+81
@@ -0,0 +1,81 @@
1+{-# language FlexibleContexts #-}
2+{-# language FlexibleInstances #-}
3+{-# language MultiParamTypeClasses #-}
4+{-# language StandaloneKindSignatures #-}
5+{-# language TypeFamilies #-}
6+{-# language UndecidableInstances #-}
7+
8+module Rel8.Expr.Function
9+ ( Function, function
10+ , nullaryFunction
11+ , binaryOperator
12+ , unsafeBinaryOperator
13+ )
14+where
15+
16+-- base
17+import Data.Kind ( Constraint, Type )
18+import Prelude
19+
20+-- opaleye
21+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
22+
23+-- rel8
24+import Rel8.Expr ( Expr( Expr ) )
25+import Rel8.Expr.Opaleye
26+ ( castExpr
27+ , fromPrimExpr, toPrimExpr, zipPrimExprsWith
28+ , unsafeZipPrimExprsWith
29+ )
30+import Rel8.Kind.Bool ( KnownBool, IsList )
31+import Rel8.Schema.Nullability ( Nullabilizes )
32+import Rel8.Type ( DBType )
33+
34+
35+type Function :: Type -> Type -> Constraint
36+class Function arg res where
37+ applyArgument :: ([Opaleye.PrimExpr] -> Opaleye.PrimExpr) -> arg -> res
38+
39+
40+instance
41+ ( arg ~ Expr a
42+ , Nullabilizes _a a, KnownBool (IsList _a)
43+ , DBType _b, Nullabilizes _b b, KnownBool (IsList _b)
44+ )
45+ => Function arg (Expr b)
46+ where
47+ applyArgument f a = castExpr $ fromPrimExpr $ f [toPrimExpr a]
48+
49+
50+instance
51+ ( arg ~ Expr a
52+ , Nullabilizes _a a, KnownBool (IsList _a)
53+ , Function args res
54+ ) =>
55+ Function arg (args -> res)
56+ where
57+ applyArgument f a = applyArgument (f . (toPrimExpr a :))
58+
59+
60+function :: Function args result => String -> args -> result
61+function = applyArgument . Opaleye.FunExpr
62+
63+
64+nullaryFunction :: (DBType db, Nullabilizes db a) => String -> Expr a
65+nullaryFunction name = castExpr $ Expr (Opaleye.FunExpr name [])
66+
67+
68+binaryOperator ::
69+ ( Nullabilizes _a a, KnownBool (IsList _a)
70+ , Nullabilizes _b b, KnownBool (IsList _b)
71+ , DBType _c, Nullabilizes _c c, KnownBool (IsList _c)
72+ )
73+ => String -> Expr a -> Expr b -> Expr c
74+binaryOperator operator a b =
75+ castExpr $ zipPrimExprsWith (Opaleye.BinExpr (Opaleye.OpOther operator)) a b
76+
77+
78+unsafeBinaryOperator :: (DBType _c, Nullabilizes _c c)
79+ => String -> Expr a -> Expr b -> Expr c
80+unsafeBinaryOperator operator a b =
81+ castExpr $ unsafeZipPrimExprsWith (Opaleye.BinExpr (Opaleye.OpOther operator)) a b
src/Rel8/Expr/Null.hsnew file+87
@@ -0,0 +1,87 @@
1+{-# language DataKinds #-}
2+{-# language FlexibleContexts #-}
3+{-# language TypeFamilies #-}
4+
5+{-# options -fno-warn-redundant-constraints #-}
6+
7+module Rel8.Expr.Null
8+ ( null, snull, nullable, nullableOf
9+ , isNull, isNonNull
10+ , nullify, unsafeUnnullify
11+ , mapNullable, liftOpNullable
12+ , unsafeMapNullable, unsafeLiftOpNullable
13+ )
14+where
15+
16+-- base
17+import Prelude hiding ( null )
18+
19+-- opaleye
20+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
21+
22+-- rel8
23+import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
24+import Rel8.Expr.Bool ( (||.), boolExpr )
25+import Rel8.Expr.Opaleye ( scastExpr, unsafeMapPrimExpr )
26+import Rel8.Schema.Nullability ( Nullability( Nullable ), IsMaybe )
27+import Rel8.Type ( DBType, typeInformation )
28+import Rel8.Type.Information ( TypeInformation )
29+
30+
31+nullify :: IsMaybe a ~ 'False => Expr a -> Expr (Maybe a)
32+nullify (Expr a) = Expr a
33+
34+
35+unsafeUnnullify :: Expr (Maybe a) -> Expr a
36+unsafeUnnullify (Expr a) = Expr a
37+
38+
39+nullable :: Expr b -> (Expr a -> Expr b) -> Expr (Maybe a) -> Expr b
40+nullable b f ma = boolExpr (f (unsafeUnnullify ma)) b (isNull ma)
41+
42+
43+nullableOf :: (IsMaybe a ~ 'False, DBType a)
44+ => Maybe (Expr a) -> Expr (Maybe a)
45+nullableOf = maybe null nullify
46+
47+
48+isNull :: Expr (Maybe a) -> Expr Bool
49+isNull = unsafeMapPrimExpr (Opaleye.UnExpr Opaleye.OpIsNull)
50+
51+
52+isNonNull :: Expr (Maybe a) -> Expr Bool
53+isNonNull = unsafeMapPrimExpr (Opaleye.UnExpr Opaleye.OpIsNotNull)
54+
55+
56+mapNullable :: (IsMaybe b ~ 'False, DBType b)
57+ => (Expr a -> Expr b) -> Expr (Maybe a) -> Expr (Maybe b)
58+mapNullable f ma = boolExpr (unsafeMapNullable f ma) null (isNull ma)
59+
60+
61+liftOpNullable :: (IsMaybe c ~ 'False, DBType c)
62+ => (Expr a -> Expr b -> Expr c)
63+ -> Expr (Maybe a) -> Expr (Maybe b) -> Expr (Maybe c)
64+liftOpNullable f ma mb =
65+ boolExpr (unsafeLiftOpNullable f ma mb) null
66+ (isNull ma ||. isNull mb)
67+
68+
69+snull :: Nullability a (Maybe a) -> TypeInformation a -> Expr (Maybe a)
70+snull nullability info =
71+ scastExpr nullability info $ Expr $ Opaleye.ConstExpr Opaleye.NullLit
72+
73+
74+null :: (IsMaybe a ~ 'False, DBType a) => Expr (Maybe a)
75+null = snull Nullable typeInformation
76+
77+
78+unsafeMapNullable :: IsMaybe b ~ 'False
79+ => (Expr a -> Expr b) -> Expr (Maybe a) -> Expr (Maybe b)
80+unsafeMapNullable f ma = nullify (f (unsafeUnnullify ma))
81+
82+
83+unsafeLiftOpNullable :: IsMaybe c ~ 'False
84+ => (Expr a -> Expr b -> Expr c)
85+ -> Expr (Maybe a) -> Expr (Maybe b) -> Expr (Maybe c)
86+unsafeLiftOpNullable f ma mb =
87+ nullify (f (unsafeUnnullify ma) (unsafeUnnullify mb))
src/Rel8/Expr/Num.hsnew file+80
@@ -0,0 +1,80 @@
1+{-# language TypeFamilies #-}
2+
3+{-# options_ghc -fno-warn-redundant-constraints #-}
4+
5+module Rel8.Expr.Num
6+ ( fromIntegral, realToFrac, div, mod, ceiling, floor, round, truncate
7+ )
8+where
9+
10+-- base
11+import Prelude ()
12+
13+-- rel
14+import Rel8.Expr ( Expr( Expr ) )
15+import Rel8.Expr.Function ( function )
16+import Rel8.Expr.Opaleye ( castExpr )
17+import Rel8.Schema.Nullability ( IsMaybe, Nullabilizes )
18+import Rel8.Type.Num ( DBFractional, DBIntegral, DBNum )
19+
20+
21+fromIntegral ::
22+ ( DBIntegral _a, Nullabilizes _a a
23+ , DBNum _b, Nullabilizes _b b
24+ , IsMaybe a ~ IsMaybe b
25+ )
26+ => Expr a -> Expr b
27+fromIntegral (Expr a) = castExpr (Expr a)
28+
29+
30+realToFrac ::
31+ ( DBNum _a, Nullabilizes _a a
32+ , DBFractional _b, Nullabilizes _b b
33+ , IsMaybe a ~ IsMaybe b
34+ )
35+ => Expr a -> Expr b
36+realToFrac (Expr a) = castExpr (Expr a)
37+
38+
39+ceiling ::
40+ ( DBFractional _a, Nullabilizes _a a
41+ , DBIntegral _b, Nullabilizes _b b
42+ , IsMaybe a ~ IsMaybe b
43+ )
44+ => Expr a -> Expr b
45+ceiling = function "CEILING"
46+
47+
48+div :: (DBIntegral _a, Nullabilizes _a a) => Expr a -> Expr a -> Expr a
49+div = function "DIV"
50+
51+
52+mod :: (DBIntegral _a, Nullabilizes _a a) => Expr a -> Expr a -> Expr a
53+mod = function "MOD"
54+
55+
56+floor ::
57+ ( DBFractional _a, Nullabilizes _a a
58+ , DBIntegral _b, Nullabilizes _b b
59+ , IsMaybe a ~ IsMaybe b
60+ )
61+ => Expr a -> Expr b
62+floor = function "FLOOR"
63+
64+
65+round ::
66+ ( DBFractional _a, Nullabilizes _a a
67+ , DBIntegral _b, Nullabilizes _b b
68+ , IsMaybe a ~ IsMaybe b
69+ )
70+ => Expr a -> Expr b
71+round = function "ROUND"
72+
73+
74+truncate ::
75+ ( DBFractional _a, Nullabilizes _a a
76+ , DBIntegral _b, Nullabilizes _b b
77+ , IsMaybe a ~ IsMaybe b
78+ )
79+ => Expr a -> Expr b
80+truncate = function "TRUNC"
src/Rel8/Expr/Opaleye.hsnew file+145
@@ -0,0 +1,145 @@
1+{-# language FlexibleContexts #-}
2+{-# language LambdaCase #-}
3+{-# language NamedFieldPuns #-}
4+{-# language ScopedTypeVariables #-}
5+{-# language TypeApplications #-}
6+{-# language TypeFamilies #-}
7+
8+{-# options_ghc -fno-warn-redundant-constraints #-}
9+
10+module Rel8.Expr.Opaleye
11+ ( castExpr, unsafeCastExpr
12+ , scastExpr, sunsafeCastExpr
13+ , unsafeLiteral
14+ , unsafeFromPrimExpr, unsafeToPrimExpr, unsafeMapPrimExpr
15+ , unsafeZipPrimExprsWith, unsafeTraversePrimExpr
16+ , sfromPrimExpr, stoPrimExpr
17+ , fromPrimExpr, toPrimExpr, mapPrimExpr, zipPrimExprsWith
18+ , toColumn, fromColumn
19+ )
20+where
21+
22+-- base
23+import Prelude
24+
25+-- opaleye
26+import qualified Opaleye.Internal.Column as Opaleye
27+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
28+
29+-- rel8
30+import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
31+import Rel8.Kind.Bool ( SBool( SFalse, STrue ), KnownBool, boolSing, IsList )
32+import Rel8.Schema.Nullability ( Nullability, Nullabilizes, nullabilization )
33+import Rel8.Type ( DBType, typeInformation )
34+import Rel8.Type.Information ( TypeInformation(..) )
35+
36+
37+castExpr :: (DBType db, Nullabilizes db a) => Expr a -> Expr a
38+castExpr = scastExpr nullabilization typeInformation
39+
40+
41+unsafeCastExpr :: (DBType db, Nullabilizes db b) => Expr a -> Expr b
42+unsafeCastExpr = sunsafeCastExpr nullabilization typeInformation
43+
44+
45+scastExpr :: Nullability db a -> TypeInformation db -> Expr a -> Expr a
46+scastExpr = sunsafeCastExpr
47+
48+
49+sunsafeCastExpr :: ()
50+ => Nullability db b -> TypeInformation db -> Expr a -> Expr b
51+sunsafeCastExpr _ TypeInformation {typeName} =
52+ Expr . Opaleye.CastExpr typeName . unsafeToPrimExpr
53+
54+
55+unsafeLiteral :: (DBType db, Nullabilizes db a) => String -> Expr a
56+unsafeLiteral = castExpr . Expr . Opaleye.ConstExpr . Opaleye.OtherLit
57+
58+
59+unsafeFromPrimExpr :: Opaleye.PrimExpr -> Expr a
60+unsafeFromPrimExpr = Expr
61+
62+
63+unsafeToPrimExpr :: Expr a -> Opaleye.PrimExpr
64+unsafeToPrimExpr (Expr a) = a
65+
66+
67+unsafeMapPrimExpr :: ()
68+ => (Opaleye.PrimExpr -> Opaleye.PrimExpr) -> Expr a -> Expr b
69+unsafeMapPrimExpr f = unsafeFromPrimExpr . f . unsafeToPrimExpr
70+
71+
72+unsafeZipPrimExprsWith :: ()
73+ => (Opaleye.PrimExpr -> Opaleye.PrimExpr -> Opaleye.PrimExpr)
74+ -> Expr a -> Expr b -> Expr c
75+unsafeZipPrimExprsWith f a b =
76+ unsafeFromPrimExpr (f (unsafeToPrimExpr a) (unsafeToPrimExpr b))
77+
78+
79+unsafeTraversePrimExpr :: Functor f
80+ => (Opaleye.PrimExpr -> f Opaleye.PrimExpr) -> Expr a -> f (Expr b)
81+unsafeTraversePrimExpr f = fmap unsafeFromPrimExpr . f . unsafeToPrimExpr
82+
83+
84+fromPrimExpr ::
85+ ( KnownBool (IsList _a), Nullabilizes _a a
86+ )
87+ => Opaleye.PrimExpr -> Expr a
88+fromPrimExpr = sfromPrimExpr nullabilization boolSing
89+
90+
91+toPrimExpr ::
92+ ( KnownBool (IsList _a), Nullabilizes _a a
93+ )
94+ => Expr a -> Opaleye.PrimExpr
95+toPrimExpr = stoPrimExpr nullabilization boolSing
96+
97+
98+sfromPrimExpr :: ()
99+ => Nullability _a a -> SBool (IsList _a) -> Opaleye.PrimExpr -> Expr a
100+sfromPrimExpr _ = \case
101+ SFalse -> unsafeFromPrimExpr
102+ STrue -> \a -> Expr $
103+ Opaleye.CaseExpr
104+ [ (Opaleye.UnExpr Opaleye.OpIsNull a, Opaleye.ConstExpr Opaleye.NullLit)
105+ ]
106+ (Opaleye.UnExpr (Opaleye.UnOpOther "ROW") a)
107+
108+
109+stoPrimExpr :: ()
110+ => Nullability _a a -> SBool (IsList _a) -> Expr a -> Opaleye.PrimExpr
111+stoPrimExpr _ = \case
112+ SFalse -> unsafeToPrimExpr
113+ STrue -> \(Expr a) ->
114+ Opaleye.CaseExpr
115+ [ (Opaleye.UnExpr Opaleye.OpIsNull a, Opaleye.ConstExpr Opaleye.NullLit)
116+ ]
117+ -- Requires at least Postgres 13
118+ (Opaleye.CompositeExpr a "f1")
119+
120+
121+mapPrimExpr ::
122+ ( KnownBool (IsList _a), Nullabilizes _a a
123+ , KnownBool (IsList _b), Nullabilizes _b b
124+ )
125+ => (Opaleye.PrimExpr -> Opaleye.PrimExpr)
126+ -> Expr a -> Expr b
127+mapPrimExpr f = fromPrimExpr . f . toPrimExpr
128+
129+
130+zipPrimExprsWith ::
131+ ( KnownBool (IsList _a), Nullabilizes _a a
132+ , KnownBool (IsList _b), Nullabilizes _b b
133+ , KnownBool (IsList _c), Nullabilizes _c c
134+ )
135+ => (Opaleye.PrimExpr -> Opaleye.PrimExpr -> Opaleye.PrimExpr)
136+ -> Expr a -> Expr b -> Expr c
137+zipPrimExprsWith f a b = fromPrimExpr (f (toPrimExpr a) (toPrimExpr b))
138+
139+
140+toColumn :: Opaleye.PrimExpr -> Opaleye.Column b
141+toColumn = Opaleye.Column
142+
143+
144+fromColumn :: Opaleye.Column b -> Opaleye.PrimExpr
145+fromColumn (Opaleye.Column a) = a
src/Rel8/Expr/Ord.hsnew file+130
@@ -0,0 +1,130 @@
1+{-# language DataKinds #-}
2+{-# language LambdaCase #-}
3+{-# language GADTs #-}
4+{-# language ScopedTypeVariables #-}
5+{-# language TypeApplications #-}
6+
7+{-# options_ghc -fno-warn-redundant-constraints #-}
8+
9+module Rel8.Expr.Ord
10+ ( slt, sle, sgt, sge
11+ , (<.), (<=.), (>.), (>=.)
12+ , (<?), (<=?), (>?), (>=?)
13+ , leastExpr, greatestExpr
14+ )
15+where
16+
17+-- base
18+import Prelude
19+
20+-- opaleye
21+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
22+
23+-- rel8
24+import Rel8.Expr ( Expr( Expr ) )
25+import Rel8.Expr.Bool ( (&&.), (||.), fromTrool )
26+import Rel8.Expr.Null ( isNull, isNonNull, nullable, unsafeLiftOpNullable )
27+import Rel8.Expr.Opaleye ( unsafeZipPrimExprsWith )
28+import Rel8.Schema.Nullability
29+ ( Nullability( NonNullable, Nullable )
30+ , Nullabilizes, nullabilization
31+ )
32+import Rel8.Type.Ord ( DBOrd )
33+
34+
35+lt :: DBOrd a => Expr a -> Expr a -> Expr Bool
36+lt = unsafeZipPrimExprsWith (Opaleye.BinExpr (Opaleye.:<))
37+
38+
39+le :: DBOrd a => Expr a -> Expr a -> Expr Bool
40+le = unsafeZipPrimExprsWith (Opaleye.BinExpr (Opaleye.:<=))
41+
42+
43+gt :: DBOrd a => Expr a -> Expr a -> Expr Bool
44+gt = unsafeZipPrimExprsWith (Opaleye.BinExpr (Opaleye.:>))
45+
46+
47+ge :: DBOrd a => Expr a -> Expr a -> Expr Bool
48+ge = unsafeZipPrimExprsWith (Opaleye.BinExpr (Opaleye.:>=))
49+
50+
51+slt :: DBOrd db => Nullability db a -> Expr a -> Expr a -> Expr Bool
52+slt = \case
53+ Nullable -> \ma mb -> isNull ma &&. isNonNull mb ||. ma <? mb
54+ NonNullable -> lt
55+
56+
57+sle :: DBOrd db => Nullability db a -> Expr a -> Expr a -> Expr Bool
58+sle = \case
59+ Nullable -> \ma mb -> isNull ma ||. ma <=? mb
60+ NonNullable -> le
61+
62+
63+sgt :: DBOrd db => Nullability db a -> Expr a -> Expr a -> Expr Bool
64+sgt = \case
65+ Nullable -> \ma mb -> isNonNull ma &&. isNull mb ||. ma >? mb
66+ NonNullable -> gt
67+
68+
69+sge :: DBOrd db => Nullability db a -> Expr a -> Expr a -> Expr Bool
70+sge = \case
71+ Nullable -> \ma mb -> isNull mb ||. ma >=? mb
72+ NonNullable -> ge
73+
74+
75+(<.) :: (DBOrd db, Nullabilizes db a) => Expr a -> Expr a -> Expr Bool
76+(<.) = slt nullabilization
77+infix 4 <.
78+
79+
80+(<=.) :: (DBOrd db, Nullabilizes db a) => Expr a -> Expr a -> Expr Bool
81+(<=.) = sle nullabilization
82+infix 4 <=.
83+
84+
85+(>.) :: (DBOrd db, Nullabilizes db a) => Expr a -> Expr a -> Expr Bool
86+(>.) = sgt nullabilization
87+infix 4 >.
88+
89+
90+(>=.) :: (DBOrd db, Nullabilizes db a) => Expr a -> Expr a -> Expr Bool
91+(>=.) = sge nullabilization
92+infix 4 >=.
93+
94+
95+(<?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
96+a <? b = fromTrool $ unsafeLiftOpNullable lt a b
97+infix 4 <?
98+
99+
100+(<=?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
101+a <=? b = fromTrool $ unsafeLiftOpNullable le a b
102+infix 4 <=?
103+
104+
105+(>?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
106+a >? b = fromTrool $ unsafeLiftOpNullable gt a b
107+infix 4 >?
108+
109+
110+(>=?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
111+a >=? b = fromTrool $ unsafeLiftOpNullable ge a b
112+infix 4 >=?
113+
114+
115+leastExpr :: forall a db. (DBOrd db, Nullabilizes db a)
116+ => Expr a -> Expr a -> Expr a
117+leastExpr ma mb = case nullabilization @a of
118+ Nullable -> nullable ma (\a -> nullable mb (least_ a) mb) ma
119+ NonNullable -> least_ ma mb
120+ where
121+ least_ (Expr a) (Expr b) = Expr (Opaleye.FunExpr "LEAST" [a, b])
122+
123+
124+greatestExpr :: forall a db. (DBOrd db, Nullabilizes db a)
125+ => Expr a -> Expr a -> Expr a
126+greatestExpr ma mb = case nullabilization @a of
127+ Nullable -> nullable mb (\a -> nullable ma (greatest_ a) mb) ma
128+ NonNullable -> greatest_ ma mb
129+ where
130+ greatest_ (Expr a) (Expr b) = Expr (Opaleye.FunExpr "GREATEST" [a, b])
src/Rel8/Expr/Order.hsnew file+63
@@ -0,0 +1,63 @@
1+{-# language DataKinds #-}
2+
3+{-# options_ghc -fno-warn-redundant-constraints #-}
4+
5+module Rel8.Expr.Order
6+ ( asc
7+ , desc
8+ , nullsFirst
9+ , nullsLast
10+ )
11+where
12+
13+-- base
14+import Data.Bifunctor ( first )
15+import Prelude
16+
17+-- opaleye
18+import Opaleye.Internal.HaskellDB.PrimQuery ( OrderOp( orderDirection, orderNulls ) )
19+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
20+import qualified Opaleye.Internal.Order as Opaleye
21+
22+-- rel8
23+import Rel8.Expr ( Expr )
24+import Rel8.Expr.Null ( unsafeUnnullify )
25+import Rel8.Expr.Opaleye ( unsafeToPrimExpr )
26+import Rel8.Order ( Order( Order ) )
27+import Rel8.Type.Ord ( DBOrd )
28+
29+
30+asc :: DBOrd a => Order (Expr a)
31+asc = Order $ Opaleye.Order (\expr -> [(orderOp, unsafeToPrimExpr expr)])
32+ where
33+ orderOp :: Opaleye.OrderOp
34+ orderOp = Opaleye.OrderOp
35+ { orderDirection = Opaleye.OpAsc
36+ , orderNulls = Opaleye.NullsLast
37+ }
38+
39+
40+desc :: DBOrd a => Order (Expr a)
41+desc = Order $ Opaleye.Order (\expr -> [(orderOp, unsafeToPrimExpr expr)])
42+ where
43+ orderOp :: Opaleye.OrderOp
44+ orderOp = Opaleye.OrderOp
45+ { orderDirection = Opaleye.OpDesc
46+ , orderNulls = Opaleye.NullsFirst
47+ }
48+
49+
50+nullsFirst :: Order (Expr a) -> Order (Expr (Maybe a))
51+nullsFirst (Order (Opaleye.Order f)) =
52+ Order $ Opaleye.Order $ fmap (first g) . f . unsafeUnnullify
53+ where
54+ g :: Opaleye.OrderOp -> Opaleye.OrderOp
55+ g orderOp = orderOp { Opaleye.orderNulls = Opaleye.NullsFirst }
56+
57+
58+nullsLast :: Order (Expr a) -> Order (Expr (Maybe a))
59+nullsLast (Order (Opaleye.Order f)) =
60+ Order $ Opaleye.Order $ fmap (first g) . f . unsafeUnnullify
61+ where
62+ g :: Opaleye.OrderOp -> Opaleye.OrderOp
63+ g orderOp = orderOp { Opaleye.orderNulls = Opaleye.NullsLast }
src/Rel8/Expr/Serialize.hsnew file+47
@@ -0,0 +1,47 @@
1+{-# language NamedFieldPuns #-}
2+{-# language TypeFamilies #-}
3+
4+module Rel8.Expr.Serialize
5+ ( litExpr
6+ , slitExpr
7+ , sparseValue
8+ )
9+where
10+
11+-- base
12+import Prelude
13+
14+-- hasql
15+import qualified Hasql.Decoders as Hasql
16+
17+-- opaleye
18+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
19+
20+-- rel8
21+import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
22+import Rel8.Expr.Opaleye ( scastExpr )
23+import Rel8.Schema.Nullability
24+ ( Nullability( Nullable, NonNullable )
25+ , Nullabilizes, nullabilization
26+ )
27+import Rel8.Type ( DBType, typeInformation )
28+import Rel8.Type.Information ( TypeInformation(..) )
29+
30+
31+litExpr :: (DBType db, Nullabilizes db a) => a -> Expr a
32+litExpr = slitExpr nullabilization typeInformation
33+
34+
35+slitExpr :: Nullability db a -> TypeInformation db -> a -> Expr a
36+slitExpr nullable info@TypeInformation {encode} =
37+ scastExpr nullable info . Expr . encoder
38+ where
39+ encoder = case nullable of
40+ Nullable -> maybe (Opaleye.ConstExpr Opaleye.NullLit) encode
41+ NonNullable -> encode
42+
43+
44+sparseValue :: Nullability db a -> TypeInformation db -> Hasql.Row a
45+sparseValue nullability TypeInformation {decode} = case nullability of
46+ Nullable -> Hasql.column $ Hasql.nullable decode
47+ NonNullable -> Hasql.column $ Hasql.nonNullable decode
src/Rel8/Expr/Text.hsnew file+241
@@ -0,0 +1,241 @@
1+{-# language DataKinds #-}
2+
3+module Rel8.Expr.Text
4+ (
5+ -- * String concatenation
6+ (++.)
7+
8+ -- * Regular expression operators
9+ , (~.), (~*), (!~), (!~*)
10+
11+ -- * Standard SQL functions
12+ , bitLength, charLength, lower, octetLength, upper
13+
14+ -- * PostgreSQL functions
15+ , ascii, btrim, chr, convert, convertFrom, convertTo, decode, encode
16+ , initcap, left, length, lengthEncoding, lpad, ltrim, md5
17+ , pgClientEncoding, quoteIdent, quoteLiteral, quoteNullable, regexpReplace
18+ , regexpSplitToArray, repeat, replace, reverse, right, rpad, rtrim
19+ , splitPart, strpos, substr, toAscii, toHex, translate
20+ )
21+where
22+
23+-- base
24+import Data.Bool ( Bool )
25+import Data.Int ( Int32 )
26+import Data.List.NonEmpty ( NonEmpty )
27+import Data.Maybe ( Maybe( Nothing, Just ) )
28+import Prelude ()
29+
30+-- bytestring
31+import Data.ByteString ( ByteString )
32+
33+-- rel8
34+import Rel8.Expr ( Expr )
35+import Rel8.Expr.Function ( binaryOperator, function, nullaryFunction )
36+
37+-- text
38+import Data.Text (Text)
39+
40+
41+-- | The PostgreSQL string concatenation operator.
42+(++.) :: Expr Text -> Expr Text -> Expr Text
43+(++.) = binaryOperator "||"
44+infixr 6 ++.
45+
46+
47+-- * Regular expression operators
48+
49+-- See https://www.postgresql.org/docs/9.5/static/functions-matching.html#FUNCTIONS-POSIX-REGEXP
50+
51+
52+-- | Matches regular expression, case sensitive
53+(~.) :: Expr Text -> Expr Text -> Expr Bool
54+(~.) = binaryOperator "~."
55+infix 2 ~.
56+
57+
58+-- | Matches regular expression, case insensitive
59+(~*) :: Expr Text -> Expr Text -> Expr Bool
60+(~*) = binaryOperator "~*"
61+infix 2 ~*
62+
63+
64+-- | Does not match regular expression, case sensitive
65+(!~) :: Expr Text -> Expr Text -> Expr Bool
66+(!~) = binaryOperator "!~"
67+infix 2 !~
68+
69+
70+-- | Does not match regular expression, case insensitive
71+(!~*) :: Expr Text -> Expr Text -> Expr Bool
72+(!~*) = binaryOperator "!~*"
73+infix 2 !~*
74+
75+
76+-- See https://www.postgresql.org/docs/9.5/static/functions-Expr.'PGHtml
77+
78+-- * Standard SQL functions
79+
80+
81+bitLength :: Expr Text -> Expr Int32
82+bitLength = function "bit_length"
83+
84+
85+charLength :: Expr Text -> Expr Int32
86+charLength = function "char_length"
87+
88+
89+lower :: Expr Text -> Expr Text
90+lower = function "lower"
91+
92+
93+octetLength :: Expr Text -> Expr Int32
94+octetLength = function "octet_length"
95+
96+
97+upper :: Expr Text -> Expr Text
98+upper = function "upper"
99+
100+
101+-- * PostgreSQL functions
102+ascii :: Expr Text -> Expr Int32
103+ascii = function "ascii"
104+
105+
106+btrim :: Expr Text -> Maybe (Expr Text) -> Expr Text
107+btrim a (Just b) = function "btrim" a b
108+btrim a Nothing = function "btrim" a
109+
110+
111+chr :: Expr Int32 -> Expr Text
112+chr = function "chr"
113+
114+
115+convert :: Expr ByteString -> Expr Text -> Expr Text -> Expr ByteString
116+convert = function "convert"
117+
118+
119+convertFrom :: Expr ByteString -> Expr Text -> Expr Text
120+convertFrom = function "convert_from"
121+
122+
123+convertTo :: Expr Text -> Expr Text -> Expr ByteString
124+convertTo = function "convert_to"
125+
126+
127+decode :: Expr Text -> Expr Text -> Expr ByteString
128+decode = function "decode"
129+
130+
131+encode :: Expr ByteString -> Expr Text -> Expr Text
132+encode = function "encode"
133+
134+
135+initcap :: Expr Text -> Expr Text
136+initcap = function "initcap"
137+
138+
139+left :: Expr Text -> Expr Int32 -> Expr Text
140+left = function "left"
141+
142+
143+length :: Expr Text -> Expr Int32
144+length = function "length"
145+
146+
147+lengthEncoding :: Expr ByteString -> Expr Text -> Expr Int32
148+lengthEncoding = function "length"
149+
150+
151+lpad :: Expr Text -> Expr Int32 -> Maybe (Expr Text) -> Expr Text
152+lpad a b (Just c) = function "lpad" a b c
153+lpad a b Nothing = function "lpad" a b
154+
155+
156+ltrim :: Expr Text -> Maybe (Expr Text) -> Expr Text
157+ltrim a (Just b) = function "ltrim" a b
158+ltrim a Nothing = function "ltrim" a
159+
160+
161+md5 :: Expr Text -> Expr Text
162+md5 = function "md5"
163+
164+
165+pgClientEncoding :: Expr Text
166+pgClientEncoding = nullaryFunction "pg_client_encoding"
167+
168+
169+quoteIdent :: Expr Text -> Expr Text
170+quoteIdent = function "quote_ident"
171+
172+
173+quoteLiteral :: Expr Text -> Expr Text
174+quoteLiteral = function "quote_literal"
175+
176+
177+quoteNullable :: Expr Text -> Expr Text
178+quoteNullable = function "quote_nullable"
179+
180+
181+regexpReplace :: ()
182+ => Expr Text -> Expr Text -> Expr Text -> Maybe (Expr Text) -> Expr Text
183+regexpReplace a b c (Just d) = function "regexp_replace" a b c d
184+regexpReplace a b c Nothing = function "regexp_replace" a b c
185+
186+
187+regexpSplitToArray :: ()
188+ => Expr Text -> Expr Text -> Maybe (Expr Text) -> Expr (NonEmpty Text)
189+regexpSplitToArray a b (Just c) = function "regexp_split_to_array" a b c
190+regexpSplitToArray a b Nothing = function "regexp_split_to_array" a b
191+
192+
193+repeat :: Expr Text -> Expr Int32 -> Expr Text
194+repeat = function "repeat"
195+
196+
197+replace :: Expr Text -> Expr Text -> Expr Text -> Expr Text
198+replace = function "replace"
199+
200+
201+reverse :: Expr Text -> Expr Text
202+reverse = function "reverse"
203+
204+
205+right :: Expr Text -> Expr Int32 -> Expr Text
206+right = function "right"
207+
208+
209+rpad :: Expr Text -> Expr Int32 -> Maybe (Expr Text) -> Expr Text
210+rpad a b (Just c) = function "rpad" a b c
211+rpad a b Nothing = function "rpad" a b
212+
213+
214+rtrim :: Expr Text -> Maybe (Expr Text) -> Expr Text
215+rtrim a (Just b) = function "rtrim" a b
216+rtrim a Nothing = function "rtrim" a
217+
218+
219+splitPart :: Expr Text -> Expr Text -> Expr Int32 -> Expr Text
220+splitPart = function "split_part"
221+
222+
223+strpos :: Expr Text -> Expr Text -> Expr Int32
224+strpos = function "strpos"
225+
226+
227+substr :: Expr Text -> Expr Int32 -> Maybe (Expr Int32) -> Expr Text
228+substr a b (Just c) = function "substr" a b c
229+substr a b Nothing = function "substr" a b
230+
231+
232+toAscii :: Expr Text -> Expr Text -> Expr Text
233+toAscii = function "toAscii"
234+
235+
236+toHex :: Expr Int32 -> Expr Text
237+toHex = function "toHex"
238+
239+
240+translate :: Expr Text -> Expr Text -> Expr Text -> Expr Text
241+translate = function "translate"
src/Rel8/Expr/Time.hsnew file+155
@@ -0,0 +1,155 @@
1+module Rel8.Expr.Time
2+ ( -- * Working with @Day@
3+ today
4+ , toDay
5+ , fromDay
6+ , addDays
7+ , diffDays
8+ , subtractDays
9+
10+ -- * Working with @UTCTime@
11+ , now
12+ , addTime
13+ , diffTime
14+ , subtractTime
15+
16+ -- Working with @DiffTime@
17+ , scaleInterval
18+ , second, seconds
19+ , minute, minutes
20+ , hour, hours
21+ , day, days
22+ , month, months
23+ , year, years
24+ ) where
25+
26+-- base
27+import Data.Int ( Int32 )
28+import Prelude
29+
30+-- rel8
31+import Rel8.Expr ( Expr )
32+import Rel8.Expr.Function ( binaryOperator, nullaryFunction )
33+import Rel8.Expr.Opaleye ( unsafeCastExpr, unsafeLiteral )
34+
35+-- time
36+import Data.Time.Calendar ( Day )
37+import Data.Time.Clock ( DiffTime, UTCTime )
38+
39+
40+-- | Corresponds to @date(now())@.
41+today :: Expr Day
42+today = toDay now
43+
44+
45+-- | Corresponds to calling the @date@ function with a given time.
46+toDay :: Expr UTCTime -> Expr Day
47+toDay = unsafeCastExpr
48+
49+
50+-- | Corresponds to @x::timestamptz@.
51+fromDay :: Expr Day -> Expr UTCTime
52+fromDay = unsafeCastExpr
53+
54+
55+-- | Move forward a given number of days from a particular day.
56+addDays :: Expr Int32 -> Expr Day -> Expr Day
57+addDays = flip (binaryOperator "+")
58+
59+
60+-- | Find the number of days between two days. Corresponds to the @-@ operator.
61+diffDays :: Expr Day -> Expr Day -> Expr Int32
62+diffDays = binaryOperator "-"
63+
64+
65+-- | Subtract a given number of days from a particular 'Day'.
66+subtractDays :: Expr Int32 -> Expr Day -> Expr Day
67+subtractDays = flip (binaryOperator "-")
68+
69+
70+-- | Corresponds to @now()@.
71+now :: Expr UTCTime
72+now = nullaryFunction "now"
73+
74+
75+-- | Add a time interval to a point in time, yielding a new point in time.
76+addTime :: Expr DiffTime -> Expr UTCTime -> Expr UTCTime
77+addTime = flip (binaryOperator "+")
78+
79+
80+-- | Find the duration between two times.
81+diffTime :: Expr UTCTime -> Expr UTCTime -> Expr DiffTime
82+diffTime = binaryOperator "-"
83+
84+
85+-- | Subtract a time interval from a point in time, yielding a new point in time.
86+subtractTime :: Expr DiffTime -> Expr UTCTime -> Expr UTCTime
87+subtractTime = flip (binaryOperator "-")
88+
89+
90+scaleInterval :: Expr Double -> Expr DiffTime -> Expr DiffTime
91+scaleInterval = binaryOperator "*"
92+
93+
94+-- | An interval of one second.
95+second :: Expr DiffTime
96+second = singleton "second"
97+
98+
99+-- | Create a literal interval from an integral number of seconds.
100+seconds :: Expr Double -> Expr DiffTime
101+seconds = (`scaleInterval` second)
102+
103+
104+-- | An interval of one minute.
105+minute :: Expr DiffTime
106+minute = singleton "minute"
107+
108+
109+-- | Create a literal interval from an integral number of minutes.
110+minutes :: Expr Double -> Expr DiffTime
111+minutes = (`scaleInterval` minute)
112+
113+
114+-- | An interval of one hour.
115+hour :: Expr DiffTime
116+hour = singleton "hour"
117+
118+
119+-- | Create a literal interval from an integral number of hours.
120+hours :: Expr Double -> Expr DiffTime
121+hours = (`scaleInterval` hour)
122+
123+
124+-- | An interval of one day.
125+day :: Expr DiffTime
126+day = singleton "day"
127+
128+
129+-- | Create a literal interval from a number of days.
130+days :: Expr Double -> Expr DiffTime
131+days = (`scaleInterval` day)
132+
133+
134+-- | An interval of one month.
135+month :: Expr DiffTime
136+month = singleton "month"
137+
138+
139+-- | Create a literal interval from a number of months.
140+months :: Expr Double -> Expr DiffTime
141+months = (`scaleInterval` month)
142+
143+
144+-- | An interval of one year.
145+year :: Expr DiffTime
146+year = singleton "year"
147+
148+
149+-- | Create a literal interval from a number of years.
150+years :: Expr Double -> Expr DiffTime
151+years = (`scaleInterval` year)
152+
153+
154+singleton :: String -> Expr DiffTime
155+singleton unit = unsafeLiteral $ "'1 " ++ unit ++ "'"
src/Rel8/Kind/Bool.hsnew file+43
@@ -0,0 +1,43 @@
1+{-# language DataKinds #-}
2+{-# language GADTs #-}
3+{-# language StandaloneKindSignatures #-}
4+{-# language TypeFamilies #-}
5+
6+module Rel8.Kind.Bool
7+ ( Bool( False, True )
8+ , SBool ( SFalse, STrue )
9+ , KnownBool( boolSing )
10+ , IsList
11+ )
12+where
13+
14+-- base
15+import Data.Kind ( Constraint, Type )
16+import Data.List.NonEmpty ( NonEmpty )
17+import Prelude
18+
19+
20+type SBool :: Bool -> Type
21+data SBool bool where
22+ SFalse :: SBool 'False
23+ STrue :: SBool 'True
24+
25+
26+type KnownBool :: Bool -> Constraint
27+class KnownBool bool where
28+ boolSing :: SBool bool
29+
30+
31+instance KnownBool 'False where
32+ boolSing = SFalse
33+
34+
35+instance KnownBool 'True where
36+ boolSing = STrue
37+
38+
39+type IsList :: Type -> Bool
40+type family IsList a where
41+ IsList [_] = 'True
42+ IsList (NonEmpty _) = 'True
43+ IsList _ = 'False
src/Rel8/Kind/Labels.hsnew file+61
@@ -0,0 +1,61 @@
1+{-# language DataKinds #-}
2+{-# language FlexibleContexts #-}
3+{-# language FlexibleInstances #-}
4+{-# language GADTs #-}
5+{-# language LambdaCase #-}
6+{-# language StandaloneKindSignatures #-}
7+{-# language TypeOperators #-}
8+
9+module Rel8.Kind.Labels
10+ ( Labels
11+ , SLabels( SLabel, SLabels )
12+ , KnownLabels( labelsSing )
13+ , renderLabels
14+ )
15+where
16+
17+-- base
18+import Data.Kind ( Constraint, Type )
19+import Data.List.NonEmpty ( NonEmpty( (:|) ), (<|) )
20+import Data.Proxy ( Proxy( Proxy ) )
21+import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )
22+import Prelude
23+
24+
25+type Labels :: Type
26+type Labels = [Symbol]
27+
28+
29+type SLabels :: Labels -> Type
30+data SLabels labels where
31+ SLabel :: KnownSymbol label => Proxy label -> SLabels '[label]
32+ SLabels :: KnownSymbol label => Proxy label -> SLabels labels -> SLabels (label ': labels)
33+
34+
35+type KnownLabels :: Labels -> Constraint
36+class KnownLabels labels where
37+ labelsSing :: SLabels labels
38+
39+
40+instance KnownSymbol label => KnownLabels (label ': '[]) where
41+ labelsSing = SLabel Proxy
42+
43+
44+instance (KnownSymbol label, KnownLabels (label_ ': labels)) =>
45+ KnownLabels (label ': (label_ ': labels))
46+ where
47+ labelsSing = SLabels Proxy labelsSing
48+
49+
50+renderLabels :: SLabels labels -> NonEmpty String
51+renderLabels = cleanup . go
52+ where
53+ go :: SLabels labels -> NonEmpty String
54+ go = \case
55+ SLabel label -> pure (symbolVal label)
56+ SLabels label labels -> symbolVal label <| go labels
57+
58+ cleanup ("" :| []) = "anon" :| []
59+ cleanup (a :| []) = a :| []
60+ cleanup (a :| [""]) = a :| []
61+ cleanup (a :| (b : c)) = a <| cleanup (b :| c)
src/Rel8/Kind/Necessity.hsnew file+38
@@ -0,0 +1,38 @@
1+{-# language DataKinds #-}
2+{-# language FlexibleContexts #-}
3+{-# language GADTs #-}
4+{-# language StandaloneKindSignatures #-}
5+
6+module Rel8.Kind.Necessity
7+ ( Necessity( Optional, Required )
8+ , SNecessity( SOptional, SRequired )
9+ , KnownNecessity( necessitySing )
10+ )
11+where
12+
13+-- base
14+import Data.Kind ( Constraint, Type )
15+import Prelude ()
16+
17+
18+type Necessity :: Type
19+data Necessity = Optional | Required
20+
21+
22+type SNecessity :: Necessity -> Type
23+data SNecessity necessity where
24+ SOptional :: SNecessity 'Optional
25+ SRequired :: SNecessity 'Required
26+
27+
28+type KnownNecessity :: Necessity -> Constraint
29+class KnownNecessity necessity where
30+ necessitySing :: SNecessity necessity
31+
32+
33+instance KnownNecessity 'Optional where
34+ necessitySing = SOptional
35+
36+
37+instance KnownNecessity 'Required where
38+ necessitySing = SRequired
src/Rel8/Opaque.hsnew file+20
@@ -0,0 +1,20 @@
1+{-# language PolyKinds #-}
2+{-# language StandaloneKindSignatures #-}
3+
4+module Rel8.Opaque
5+ ( Opaque
6+ , Opaque1
7+ )
8+where
9+
10+-- base
11+import Data.Kind ( Type )
12+import Prelude ()
13+
14+
15+type Opaque :: Type
16+data Opaque
17+
18+
19+type Opaque1 :: k -> Type -> Type
20+data Opaque1 a x
src/Rel8/Order.hsnew file+24
@@ -0,0 +1,24 @@
1+{-# language DerivingStrategies #-}
2+{-# language GeneralizedNewtypeDeriving #-}
3+{-# language StandaloneKindSignatures #-}
4+
5+module Rel8.Order
6+ ( Order(..)
7+ )
8+where
9+
10+-- base
11+import Data.Functor.Contravariant ( Contravariant )
12+import Data.Kind ( Type )
13+import Prelude
14+
15+-- contravariant
16+import Data.Functor.Contravariant.Divisible ( Decidable, Divisible )
17+
18+-- opaleye
19+import qualified Opaleye.Internal.Order as Opaleye
20+
21+
22+type Order :: Type -> Type
23+newtype Order a = Order (Opaleye.Order a)
24+ deriving newtype (Contravariant, Divisible, Decidable, Semigroup, Monoid)
src/Rel8/Query.hsnew file+36
@@ -0,0 +1,36 @@
1+{-# language DerivingStrategies #-}
2+{-# language GeneralizedNewtypeDeriving #-}
3+{-# language StandaloneKindSignatures #-}
4+
5+module Rel8.Query
6+ ( Query( Query )
7+ )
8+where
9+
10+-- base
11+import Data.Kind ( Type )
12+import Prelude
13+
14+-- opaleye
15+import qualified Opaleye.Select as Opaleye
16+
17+-- rel8
18+import Rel8.Query.Set ( unionAll )
19+import Rel8.Query.Values ( values )
20+import Rel8.Table.Alternative
21+ ( AltTable, (<|>:)
22+ , AlternativeTable, emptyTable
23+ )
24+
25+
26+type Query :: Type -> Type
27+newtype Query a = Query (Opaleye.Select a)
28+ deriving newtype (Functor, Applicative, Monad)
29+
30+
31+instance AltTable Query where
32+ (<|>:) = unionAll
33+
34+
35+instance AlternativeTable Query where
36+ emptyTable = values []
src/Rel8/Query.hs-bootnew file+17
@@ -0,0 +1,17 @@
1+{-# language StandaloneKindSignatures #-}
2+
3+module Rel8.Query
4+ ( Query( Query )
5+ )
6+where
7+
8+-- base
9+import Data.Kind ( Type )
10+import Prelude ()
11+
12+-- opaleye
13+import qualified Opaleye.Select as Opaleye
14+
15+
16+type Query :: Type -> Type
17+newtype Query a = Query (Opaleye.Select a)
src/Rel8/Query/Aggregate.hsnew file+22
@@ -0,0 +1,22 @@
1+{-# language FlexibleContexts #-}
2+
3+module Rel8.Query.Aggregate
4+ ( aggregate
5+ )
6+where
7+
8+-- base
9+import Prelude ()
10+
11+-- opaleye
12+import qualified Opaleye.Aggregate as Opaleye
13+
14+-- rel8
15+import Rel8.Aggregate ( Aggregate )
16+import Rel8.Query ( Query )
17+import Rel8.Query.Opaleye ( mapOpaleye )
18+import Rel8.Table.Opaleye ( aggregator )
19+
20+
21+aggregate :: Query (Aggregate exprs) -> Query exprs
22+aggregate = mapOpaleye (Opaleye.aggregate aggregator)
src/Rel8/Query/Distinct.hsnew file+37
@@ -0,0 +1,37 @@
1+{-# options_ghc -fno-warn-redundant-constraints #-}
2+
3+module Rel8.Query.Distinct
4+ ( distinct
5+ , distinctOn
6+ , distinctOnBy
7+ )
8+where
9+
10+-- base
11+import Prelude
12+
13+-- opaleye
14+import qualified Opaleye.Distinct as Opaleye
15+import qualified Opaleye.Internal.Order as Opaleye
16+import qualified Opaleye.Internal.QueryArr as Opaleye
17+
18+-- rel8
19+import Rel8.Order ( Order( Order ) )
20+import Rel8.Query ( Query )
21+import Rel8.Query.Opaleye ( mapOpaleye )
22+import Rel8.Table.Eq ( EqTable )
23+import Rel8.Table.Opaleye ( distinctspec, unpackspec )
24+
25+
26+distinct :: EqTable a => Query a -> Query a
27+distinct = mapOpaleye (Opaleye.distinctExplicit distinctspec)
28+
29+
30+distinctOn :: EqTable b => (a -> b) -> Query a -> Query a
31+distinctOn proj =
32+ mapOpaleye (\q -> Opaleye.productQueryArr (Opaleye.distinctOn unpackspec proj . Opaleye.runSimpleQueryArr q))
33+
34+
35+distinctOnBy :: EqTable b => (a -> b) -> Order a -> Query a -> Query a
36+distinctOnBy proj (Order order) =
37+ mapOpaleye (\q -> Opaleye.productQueryArr (Opaleye.distinctOnBy unpackspec proj order . Opaleye.runSimpleQueryArr q))
src/Rel8/Query/Each.hsnew file+29
@@ -0,0 +1,29 @@
1+{-# language FlexibleContexts #-}
2+
3+module Rel8.Query.Each
4+ ( each
5+ )
6+where
7+
8+-- base
9+import Prelude
10+
11+-- opaleye
12+import qualified Opaleye.Table as Opaleye
13+
14+-- rel8
15+import Rel8.Query ( Query )
16+import Rel8.Query.Opaleye ( fromOpaleye )
17+import Rel8.Schema.Table ( TableSchema )
18+import Rel8.Table ( fromColumns, toColumns )
19+import Rel8.Table.Opaleye ( table, unpackspec )
20+import Rel8.Table.Recontextualize ( Selects )
21+
22+
23+each :: Selects names exprs => TableSchema names -> Query exprs
24+each =
25+ fmap fromColumns .
26+ fromOpaleye .
27+ Opaleye.selectTableExplicit unpackspec .
28+ table .
29+ fmap toColumns
src/Rel8/Query/Either.hsnew file+64
@@ -0,0 +1,64 @@
1+{-# language FlexibleContexts #-}
2+
3+module Rel8.Query.Either
4+ ( keepLeftTable
5+ , keepRightTable
6+ , bindEitherTable
7+ , bitraverseEitherTable
8+ )
9+where
10+
11+-- base
12+import Prelude
13+
14+-- rel8
15+import Rel8.Expr.Eq ( (==.) )
16+import Rel8.Query ( Query )
17+import Rel8.Query.Filter ( where_ )
18+import Rel8.Query.Maybe ( optional )
19+import Rel8.Query.Set ( unionAll )
20+import Rel8.Schema.Context ( DB )
21+import Rel8.Table ( Table )
22+import Rel8.Table.Bool ( bool )
23+import Rel8.Table.Either
24+ ( EitherTable( EitherTable )
25+ , leftTable, rightTable
26+ , isLeftTable, isRightTable
27+ )
28+import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
29+
30+
31+keepLeftTable :: EitherTable a b -> Query a
32+keepLeftTable e@(EitherTable _ a _) = do
33+ where_ $ isLeftTable e
34+ pure a
35+
36+
37+keepRightTable :: EitherTable a b -> Query b
38+keepRightTable e@(EitherTable _ _ b) = do
39+ where_ $ isRightTable e
40+ pure b
41+
42+
43+bindEitherTable :: (Table DB a, Monad m)
44+ => (i -> m (EitherTable a b)) -> EitherTable a i -> m (EitherTable a b)
45+bindEitherTable query e@(EitherTable input a i) = do
46+ EitherTable output a' b <- query i
47+ pure $ EitherTable (input <> output) (bool a a' (isRightTable e)) b
48+
49+
50+bitraverseEitherTable :: (Table DB c, Table DB d)
51+ => (a -> Query c)
52+ -> (b -> Query d)
53+ -> EitherTable a b
54+ -> Query (EitherTable c d)
55+bitraverseEitherTable f g e = traverseLeftTable `unionAll` traverseRightTable
56+ where
57+ traverseLeftTable = do
58+ mc@(MaybeTable _ c) <- optional (f =<< keepLeftTable e)
59+ where_ $ isJustTable mc ==. isLeftTable e
60+ pure $ leftTable c
61+ traverseRightTable = do
62+ md@(MaybeTable _ d) <- optional (g =<< keepRightTable e)
63+ where_ $ isJustTable md ==. isRightTable e
64+ pure $ rightTable d
src/Rel8/Query/Exists.hsnew file+57
@@ -0,0 +1,57 @@
1+{-# language DataKinds #-}
2+
3+module Rel8.Query.Exists
4+ ( exists, inQuery
5+ , whereExists, with, withBy
6+ , whereNotExists, without, withoutBy
7+ )
8+where
9+
10+-- base
11+import Prelude hiding ( filter )
12+
13+-- opaleye
14+import qualified Opaleye.Operators as Opaleye
15+
16+-- rel8
17+import Rel8.Expr ( Expr )
18+import Rel8.Query ( Query )
19+import Rel8.Query.Filter ( filter )
20+import Rel8.Query.Maybe ( optional )
21+import Rel8.Query.Opaleye ( mapOpaleye )
22+import Rel8.Table.Eq ( EqTable, (==:) )
23+import Rel8.Table.Maybe ( isJustTable )
24+
25+
26+exists :: Query a -> Query (Expr Bool)
27+exists = fmap isJustTable . optional . whereExists
28+-- FIXME: change this when b7aacc07c6392654cae439fc3b997620c3aa7a87 makes it
29+-- into a release of Opaleye
30+
31+
32+inQuery :: EqTable a => a -> Query a -> Query (Expr Bool)
33+inQuery a = exists . (>>= filter (a ==:))
34+
35+
36+whereExists :: Query a -> Query ()
37+whereExists = mapOpaleye Opaleye.restrictExists
38+
39+
40+whereNotExists :: Query a -> Query ()
41+whereNotExists = mapOpaleye Opaleye.restrictNotExists
42+
43+
44+with :: (a -> Query b) -> a -> Query a
45+with f a = a <$ whereExists (f a)
46+
47+
48+withBy :: (a -> b -> Expr Bool) -> Query b -> a -> Query a
49+withBy predicate bs = with $ \a -> bs >>= filter (predicate a)
50+
51+
52+without :: (a -> Query b) -> a -> Query a
53+without f a = a <$ whereNotExists (f a)
54+
55+
56+withoutBy :: (a -> b -> Expr Bool) -> Query b -> a -> Query a
57+withoutBy predicate bs = without $ \a -> bs >>= filter (predicate a)
src/Rel8/Query/Filter.hsnew file+29
@@ -0,0 +1,29 @@
1+module Rel8.Query.Filter
2+ ( filter
3+ , where_
4+ )
5+where
6+
7+-- base
8+import Prelude hiding ( filter )
9+
10+-- opaleye
11+import qualified Opaleye.Operators as Opaleye
12+
13+-- profunctors
14+import Data.Profunctor ( lmap )
15+
16+-- rel8
17+import Rel8.Expr ( Expr )
18+import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )
19+import Rel8.Query ( Query )
20+import Rel8.Query.Opaleye ( fromOpaleye )
21+
22+
23+filter :: (a -> Expr Bool) -> a -> Query a
24+filter f a = a <$ where_ (f a)
25+
26+
27+where_ :: Expr Bool -> Query ()
28+where_ condition =
29+ fromOpaleye $ lmap (\_ -> toColumn $ toPrimExpr condition) Opaleye.restrict
src/Rel8/Query/Limit.hsnew file+23
@@ -0,0 +1,23 @@
1+module Rel8.Query.Limit
2+ ( limit
3+ , offset
4+ )
5+where
6+
7+-- base
8+import Prelude
9+
10+-- opaleye
11+import qualified Opaleye
12+
13+-- rel8
14+import Rel8.Query ( Query )
15+import Rel8.Query.Opaleye ( mapOpaleye )
16+
17+
18+limit :: Word -> Query a -> Query a
19+limit = mapOpaleye . Opaleye.limit . fromIntegral
20+
21+
22+offset :: Word -> Query a -> Query a
23+offset = mapOpaleye . Opaleye.offset . fromIntegral
src/Rel8/Query/List.hsnew file+28
@@ -0,0 +1,28 @@
1+{-# language FlexibleContexts #-}
2+
3+module Rel8.Query.List
4+ ( many, some
5+ )
6+where
7+
8+-- base
9+import Prelude
10+
11+-- rel8
12+import Rel8.Query ( Query )
13+import Rel8.Query.Aggregate ( aggregate )
14+import Rel8.Query.Maybe ( optional )
15+import Rel8.Schema.Context ( DB )
16+import Rel8.Table ( Table )
17+import Rel8.Table.Aggregate ( listAgg, nonEmptyAgg )
18+import Rel8.Table.List ( ListTable )
19+import Rel8.Table.Maybe ( maybeTable )
20+import Rel8.Table.NonEmpty ( NonEmptyTable )
21+
22+
23+some :: Table DB a => Query a -> Query (NonEmptyTable a)
24+some = aggregate . fmap nonEmptyAgg
25+
26+
27+many :: Table DB a => Query a -> Query (ListTable a)
28+many = fmap (maybeTable mempty id) . optional . aggregate . fmap listAgg
src/Rel8/Query/Maybe.hsnew file+60
@@ -0,0 +1,60 @@
1+module Rel8.Query.Maybe
2+ ( optional
3+ , catMaybeTable
4+ , bindMaybeTable
5+ , traverseMaybeTable
6+ )
7+where
8+
9+-- base
10+import Prelude
11+
12+-- opaleye
13+import qualified Opaleye.Internal.PackMap as Opaleye
14+import qualified Opaleye.Internal.PrimQuery as Opaleye
15+import qualified Opaleye.Internal.QueryArr as Opaleye
16+import qualified Opaleye.Internal.Tag as Opaleye
17+import qualified Opaleye.Internal.Unpackspec as Opaleye
18+
19+-- rel8
20+import Rel8.Expr.Bool ( true )
21+import Rel8.Expr.Eq ( (==.) )
22+import Rel8.Expr.Opaleye ( unsafeToPrimExpr )
23+import Rel8.Query ( Query )
24+import Rel8.Query.Filter ( where_ )
25+import Rel8.Query.Opaleye ( mapOpaleye )
26+import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
27+import Rel8.Table.Opaleye ( unpackspec )
28+
29+
30+optional :: Query a -> Query (MaybeTable a)
31+optional = mapOpaleye $ Opaleye.QueryArr . go
32+ where
33+ go query (i, left, tag) = (MaybeTable t' a, join, Opaleye.next tag')
34+ where
35+ (MaybeTable t a, right, tag') =
36+ Opaleye.runSimpleQueryArr (pure <$> query) (i, tag)
37+ (t', bindings) = Opaleye.run $
38+ Opaleye.runUnpackspec unpackspec (Opaleye.extractAttr "maybe" tag') t
39+ join = Opaleye.Join Opaleye.LeftJoin condition [] bindings left right
40+ condition = unsafeToPrimExpr true
41+
42+
43+catMaybeTable :: MaybeTable a -> Query a
44+catMaybeTable ma@(MaybeTable _ a) = do
45+ where_ $ isJustTable ma
46+ pure a
47+
48+
49+bindMaybeTable :: Monad m
50+ => (a -> m (MaybeTable b)) -> MaybeTable a -> m (MaybeTable b)
51+bindMaybeTable query (MaybeTable input a) = do
52+ MaybeTable output b <- query a
53+ pure $ MaybeTable (input <> output) b
54+
55+
56+traverseMaybeTable :: (a -> Query b) -> MaybeTable a -> Query (MaybeTable b)
57+traverseMaybeTable query ma@(MaybeTable input _) = do
58+ MaybeTable output b <- optional (query =<< catMaybeTable ma)
59+ where_ $ output ==. input
60+ pure $ MaybeTable input b
src/Rel8/Query/Null.hsnew file+19
@@ -0,0 +1,19 @@
1+module Rel8.Query.Null
2+ ( catNullable
3+ )
4+where
5+
6+-- base
7+import Prelude
8+
9+-- rel8
10+import Rel8.Expr ( Expr )
11+import Rel8.Expr.Null ( isNonNull, unsafeUnnullify )
12+import Rel8.Query ( Query )
13+import Rel8.Query.Filter ( where_ )
14+
15+
16+catNullable :: Expr (Maybe a) -> Query (Expr a)
17+catNullable a = do
18+ where_ $ isNonNull a
19+ pure $ unsafeUnnullify a
src/Rel8/Query/Opaleye.hsnew file+34
@@ -0,0 +1,34 @@
1+module Rel8.Query.Opaleye
2+ ( fromOpaleye
3+ , toOpaleye
4+ , mapOpaleye
5+ , zipOpaleyeWith
6+ )
7+where
8+
9+-- base
10+import Prelude
11+
12+-- opaleye
13+import qualified Opaleye.Select as Opaleye
14+
15+-- rel8
16+import {-# SOURCE #-} Rel8.Query ( Query( Query ) )
17+
18+
19+fromOpaleye :: Opaleye.Select a -> Query a
20+fromOpaleye = Query
21+
22+
23+toOpaleye :: Query a -> Opaleye.Select a
24+toOpaleye (Query a) = a
25+
26+
27+mapOpaleye :: (Opaleye.Select a -> Opaleye.Select b) -> Query a -> Query b
28+mapOpaleye f = fromOpaleye . f . toOpaleye
29+
30+
31+zipOpaleyeWith :: ()
32+ => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)
33+ -> Query a -> Query b -> Query c
34+zipOpaleyeWith f a b = fromOpaleye $ f (toOpaleye a) (toOpaleye b)
src/Rel8/Query/Optimize.hsnew file+200
@@ -0,0 +1,200 @@
1+{-# language ApplicativeDo #-}
2+{-# language LambdaCase #-}
3+
4+{-# options -fno-warn-name-shadowing #-}
5+
6+module Rel8.Query.Optimize
7+ ( optimize
8+ )
9+where
10+
11+-- base
12+import Control.Applicative
13+import Data.Functor.Identity
14+import Prelude
15+
16+-- opaleye
17+import Opaleye.Internal.HaskellDB.PrimQuery
18+import Opaleye.Internal.PrimQuery
19+
20+
21+optimize :: PrimQuery' a -> PrimQuery' a
22+optimize =
23+ transformOf primQuery optimisePredicates
24+
25+
26+primQuery
27+ :: Applicative f
28+ => ( PrimQuery' a -> f ( PrimQuery' a ) ) -> PrimQuery' a -> f ( PrimQuery' a )
29+primQuery f = \case
30+ Aggregate bindingsAndPrimExpr primQuery -> do
31+ primQuery <- f primQuery
32+
33+ return ( Aggregate bindingsAndPrimExpr primQuery )
34+
35+ DistinctOnOrderBy maybePrimExprs orderExprs primQuery -> do
36+ primQuery <- f primQuery
37+
38+ return ( DistinctOnOrderBy maybePrimExprs orderExprs primQuery )
39+
40+ Limit limitOp primQuery -> do
41+ primQuery <- f primQuery
42+
43+ return ( Limit limitOp primQuery )
44+
45+ Join joinType primExpr bindingsA bindingsB primQueryA primQueryB -> do
46+ primQueryA <- f primQueryA
47+ primQueryB <- f primQueryB
48+
49+ return ( Join joinType primExpr bindingsA bindingsB primQueryA primQueryB )
50+
51+ Exists bool primQueryA primQueryB -> do
52+ primQueryA <- f primQueryA
53+ primQueryB <- f primQueryB
54+
55+ return ( Exists bool primQueryA primQueryB )
56+
57+ Binary binOp primQueries -> do
58+ primQueries <- both f primQueries
59+
60+ return ( Binary binOp primQueries )
61+
62+ Label label primQuery -> do
63+ primQuery <- f primQuery
64+
65+ return ( Label label primQuery )
66+
67+ other ->
68+ pure other
69+
70+
71+optimisePredicates :: PrimQuery' a -> PrimQuery' a
72+optimisePredicates = \case
73+ Join joinType predicate bindingsA bindingsB primQueryA primQueryB ->
74+ Join joinType ( nullIsFalse predicate ) bindingsA bindingsB primQueryA primQueryB
75+
76+ other ->
77+ other
78+
79+
80+nullIsFalse :: PrimExpr -> PrimExpr
81+nullIsFalse =
82+ rewriteOf primExprs simplifyCaseAnalysis
83+
84+ where
85+
86+ simplifyCaseAnalysis = \case
87+ CaseExpr [ ( UnExpr OpIsNull _, ConstExpr ( BoolLit False ) ) ] notNullBranch ->
88+ Just notNullBranch
89+
90+ CaseExpr [ ( UnExpr OpIsNull x, UnExpr OpIsNull y ) ] notNullBranch ->
91+ Just
92+ ( BinExpr
93+ (:||)
94+ ( BinExpr (:&&) ( UnExpr OpIsNull x ) ( UnExpr OpIsNull y ) )
95+ notNullBranch
96+ )
97+
98+ _ ->
99+ Nothing
100+
101+
102+
103+-- | Traverse all immediate 'PrimExpr's
104+primExprs :: Applicative f => ( PrimExpr -> f PrimExpr ) -> PrimExpr -> f PrimExpr
105+primExprs f = \case
106+ AttrExpr ( Symbol string tag ) ->
107+ pure ( AttrExpr ( Symbol string tag ) )
108+
109+ BaseTableAttrExpr attribute ->
110+ pure ( BaseTableAttrExpr attribute )
111+
112+ CompositeExpr primExpr attribute -> do
113+ primExpr <- f primExpr
114+
115+ return ( CompositeExpr primExpr attribute )
116+
117+ BinExpr binOp a b -> do
118+ a <- f a
119+ b <- f b
120+
121+ return ( BinExpr binOp a b )
122+
123+ UnExpr unOp primExpr -> do
124+ primExpr <- f primExpr
125+
126+ return ( UnExpr unOp primExpr )
127+
128+ AggrExpr aggrDistinct aggrOp primExpr orderExprs -> do
129+ aggrOp <- aggrOpPrimExprs f aggrOp
130+ primExpr <- f primExpr
131+ orderExprs <- traverse ( orderExprPrimExprs f ) orderExprs
132+
133+ return ( AggrExpr aggrDistinct aggrOp primExpr orderExprs )
134+
135+ ConstExpr l ->
136+ pure ( ConstExpr l )
137+
138+ CaseExpr cases def -> do
139+ cases <- traverse ( both f ) cases
140+ def <- f def
141+
142+ return ( CaseExpr cases def )
143+
144+ other ->
145+ pure other
146+
147+
148+
149+aggrOpPrimExprs :: Applicative f => ( PrimExpr -> f PrimExpr ) -> AggrOp -> f AggrOp
150+aggrOpPrimExprs f = \case
151+ AggrStringAggr primExpr -> do
152+ primExpr <- f primExpr
153+
154+ return ( AggrStringAggr primExpr )
155+
156+ other ->
157+ pure other
158+
159+
160+orderExprPrimExprs :: Applicative f => ( PrimExpr -> f PrimExpr ) -> OrderExpr -> f OrderExpr
161+orderExprPrimExprs f ( OrderExpr orderOp primExpr ) = do
162+ primExpr <- f primExpr
163+
164+ return ( OrderExpr orderOp primExpr )
165+
166+
167+-- | Traverse both sides of a homogeneous tuple.
168+both :: Applicative f => ( t -> f b ) -> ( t, t ) -> f ( b, b )
169+both f ( a,b ) =
170+ liftA2 (,) ( f a ) ( f b )
171+
172+
173+rewriteOf
174+ :: ( ( a -> Identity a ) -> a -> Identity a )
175+ -> ( a -> Maybe a ) -> a -> a
176+rewriteOf l f =
177+ go where
178+
179+ go = transformOf l ( \x -> maybe x go ( f x ) )
180+
181+
182+transformOf
183+ :: ( ( a -> Identity a ) -> a -> Identity a )
184+ -> ( a -> a )
185+ -> a
186+ -> a
187+{-# inline transformOf #-}
188+transformOf l f = go where
189+
190+ go =
191+ f . over l go
192+
193+
194+over
195+ :: ( ( s -> Identity t ) -> a -> Identity b )
196+ -> ( s -> t )
197+ -> a
198+ -> b
199+over l f =
200+ runIdentity . l (Identity . f)
src/Rel8/Query/Order.hsnew file+19
@@ -0,0 +1,19 @@
1+module Rel8.Query.Order
2+ ( orderBy
3+ )
4+where
5+
6+-- base
7+import Prelude ()
8+
9+-- opaleye
10+import qualified Opaleye.Order as Opaleye ( orderBy )
11+
12+-- rel8
13+import Rel8.Order ( Order( Order ) )
14+import Rel8.Query ( Query )
15+import Rel8.Query.Opaleye ( mapOpaleye )
16+
17+
18+orderBy :: Order a -> Query a -> Query a
19+orderBy (Order o) = mapOpaleye (Opaleye.orderBy o)
src/Rel8/Query/SQL.hsnew file+72
@@ -0,0 +1,72 @@
1+{-# language FlexibleContexts #-}
2+{-# language TypeFamilies #-}
3+{-# language ViewPatterns #-}
4+
5+module Rel8.Query.SQL
6+ ( showQuery
7+ , sqlForQuery, sqlForQueryWithNames
8+ )
9+where
10+
11+-- base
12+import Data.Foldable ( fold )
13+import Data.Functor.Const ( Const( Const ), getConst )
14+import Data.Void ( Void )
15+import Prelude
16+
17+-- opaleye
18+import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye
19+import qualified Opaleye.Internal.PrimQuery as Opaleye
20+import qualified Opaleye.Internal.Print as Opaleye
21+import qualified Opaleye.Internal.Optimize as Opaleye
22+import qualified Opaleye.Internal.QueryArr as Opaleye hiding ( Select )
23+import qualified Opaleye.Internal.Sql as Opaleye
24+
25+-- rel8
26+import Rel8.Expr.Opaleye ( unsafeToPrimExpr )
27+import Rel8.Query ( Query )
28+import Rel8.Query.Opaleye ( toOpaleye )
29+import qualified Rel8.Query.Optimize as Rel8 ( optimize )
30+import Rel8.Schema.Context ( DB( DB ), Name( Name ) )
31+import Rel8.Schema.HTable ( htabulateA, hfield )
32+import Rel8.Table ( Table, toColumns )
33+import Rel8.Table.Name ( namesFromLabels )
34+import Rel8.Table.Recontextualize ( Selects )
35+
36+
37+showQuery :: Table DB a => Query a -> String
38+showQuery = fold . sqlForQuery
39+
40+
41+sqlForQuery :: Table DB a
42+ => Query a -> Maybe String
43+sqlForQuery = sqlForQueryWithNames namesFromLabels . fmap toColumns
44+
45+
46+sqlForQueryWithNames :: Selects names exprs
47+ => names -> Query exprs -> Maybe String
48+sqlForQueryWithNames names query =
49+ show . Opaleye.ppSql . selectFrom names exprs <$> optimize primQuery
50+ where
51+ (exprs, primQuery, _) =
52+ Opaleye.runSimpleQueryArrStart (toOpaleye query) ()
53+
54+
55+optimize :: Opaleye.PrimQuery' a -> Maybe (Opaleye.PrimQuery' Void)
56+optimize = Opaleye.removeEmpty . Rel8.optimize . Opaleye.optimize
57+
58+
59+selectFrom :: Selects names exprs
60+ => names -> exprs -> Opaleye.PrimQuery' Void -> Opaleye.Select
61+selectFrom (toColumns -> names) (toColumns -> exprs) query =
62+ Opaleye.SelectFrom $ Opaleye.newSelect
63+ { Opaleye.attrs = Opaleye.SelectAttrs attributes
64+ , Opaleye.tables = Opaleye.oneTable select
65+ }
66+ where
67+ select = Opaleye.foldPrimQuery Opaleye.sqlQueryGenerator query
68+ attributes = getConst $ htabulateA $ \field -> case hfield names field of
69+ Name name -> case hfield exprs field of
70+ DB (unsafeToPrimExpr -> expr) -> Const (pure (makeAttr name expr))
71+ makeAttr label expr =
72+ (Opaleye.sqlExpr expr, Just (Opaleye.SqlColumn label))
src/Rel8/Query/Set.hsnew file+46
@@ -0,0 +1,46 @@
1+{-# language FlexibleContexts #-}
2+
3+module Rel8.Query.Set
4+ ( union, unionAll
5+ , intersect, intersectAll
6+ , except, exceptAll
7+ )
8+where
9+
10+-- base
11+import Prelude ()
12+
13+-- opaleye
14+import qualified Opaleye.Binary as Opaleye
15+
16+-- rel8
17+import {-# SOURCE #-} Rel8.Query ( Query )
18+import Rel8.Query.Opaleye ( zipOpaleyeWith )
19+import Rel8.Table ( Table )
20+import Rel8.Table.Eq ( EqTable )
21+import Rel8.Table.Opaleye ( binaryspec )
22+import Rel8.Schema.Context ( DB )
23+
24+
25+union :: EqTable a => Query a -> Query a -> Query a
26+union = zipOpaleyeWith (Opaleye.unionExplicit binaryspec)
27+
28+
29+unionAll :: Table DB a => Query a -> Query a -> Query a
30+unionAll = zipOpaleyeWith (Opaleye.unionAllExplicit binaryspec)
31+
32+
33+intersect :: EqTable a => Query a -> Query a -> Query a
34+intersect = zipOpaleyeWith (Opaleye.intersectExplicit binaryspec)
35+
36+
37+intersectAll :: Table DB a => Query a -> Query a -> Query a
38+intersectAll = zipOpaleyeWith (Opaleye.intersectAllExplicit binaryspec)
39+
40+
41+except :: EqTable a => Query a -> Query a -> Query a
42+except = zipOpaleyeWith (Opaleye.exceptExplicit binaryspec)
43+
44+
45+exceptAll :: Table DB a => Query a -> Query a -> Query a
46+exceptAll = zipOpaleyeWith (Opaleye.exceptAllExplicit binaryspec)
src/Rel8/Query/These.hsnew file+129
@@ -0,0 +1,129 @@
1+{-# language FlexibleContexts #-}
2+
3+module Rel8.Query.These
4+ ( alignBy
5+ , keepHereTable, loseHereTable
6+ , keepThereTable, loseThereTable
7+ , keepThisTable, loseThisTable
8+ , keepThatTable, loseThatTable
9+ , keepThoseTable, loseThoseTable
10+ , bindTheseTable
11+ , bitraverseTheseTable
12+ )
13+where
14+
15+-- base
16+import Data.Bifunctor ( bimap )
17+import Prelude
18+
19+-- opaleye
20+import qualified Opaleye.Internal.Join as Opaleye
21+import qualified Opaleye.Internal.PrimQuery as Opaleye
22+
23+-- rel8
24+import Rel8.Expr ( Expr )
25+import Rel8.Expr.Bool ( (&&.), boolExpr, not_ )
26+import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )
27+import Rel8.Expr.Serialize ( litExpr )
28+import Rel8.Query ( Query )
29+import Rel8.Query.Filter ( where_ )
30+import Rel8.Query.Maybe ( traverseMaybeTable )
31+import Rel8.Query.Opaleye ( zipOpaleyeWith )
32+import Rel8.Schema.Context ( DB )
33+import Rel8.Table ( Table )
34+import Rel8.Table.Either ( EitherTable( EitherTable ) )
35+import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
36+import Rel8.Table.Opaleye ( unpackspec )
37+import Rel8.Table.These
38+ ( TheseTable( TheseTable )
39+ , isThisTable, isThatTable, isThoseTable
40+ )
41+import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ) )
42+
43+
44+alignBy :: (Table DB a, Table DB b)
45+ => (a -> b -> Expr Bool)
46+ -> Query a -> Query b -> Query (TheseTable a b)
47+alignBy condition as bs =
48+ uncurry TheseTable <$> zipOpaleyeWith fullOuterJoin as bs
49+ where
50+ fullOuterJoin a b =
51+ Opaleye.joinExplicit unpackspec unpackspec pure pure full a b on
52+ where
53+ full = Opaleye.FullJoin
54+ on = toColumn . toPrimExpr . uncurry condition
55+
56+
57+keepHereTable :: TheseTable a b -> Query (a, MaybeTable b)
58+keepHereTable = loseThatTable
59+
60+
61+loseHereTable :: TheseTable a b -> Query b
62+loseHereTable = keepThatTable
63+
64+
65+keepThereTable :: TheseTable a b -> Query (MaybeTable a, b)
66+keepThereTable = loseThisTable
67+
68+
69+loseThereTable :: TheseTable a b -> Query a
70+loseThereTable = keepThisTable
71+
72+
73+keepThisTable :: TheseTable a b -> Query a
74+keepThisTable t@(TheseTable (MaybeTable _ a) _) = do
75+ where_ $ isThisTable t
76+ pure a
77+
78+
79+loseThisTable :: TheseTable a b -> Query (MaybeTable a, b)
80+loseThisTable t@(TheseTable ma (MaybeTable _ b)) = do
81+ where_ $ not_ $ isThisTable t
82+ pure (ma, b)
83+
84+
85+keepThatTable :: TheseTable a b -> Query b
86+keepThatTable t@(TheseTable _ (MaybeTable _ b)) = do
87+ where_ $ isThatTable t
88+ pure b
89+
90+
91+loseThatTable :: TheseTable a b -> Query (a, MaybeTable b)
92+loseThatTable t@(TheseTable (MaybeTable _ a) mb) = do
93+ where_ $ not_ $ isThatTable t
94+ pure (a, mb)
95+
96+
97+keepThoseTable :: TheseTable a b -> Query (a, b)
98+keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
99+ where_ $ isThoseTable t
100+ pure (a, b)
101+
102+
103+loseThoseTable :: TheseTable a b -> Query (EitherTable a b)
104+loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
105+ where_ $ not_ $ isThoseTable t
106+ pure $ EitherTable tag a b
107+ where
108+ tag = boolExpr (litExpr IsLeft) (litExpr IsRight) (isThatTable t)
109+
110+
111+bindTheseTable :: (Table DB a, Semigroup a, Monad m)
112+ => (i -> m (TheseTable a b)) -> TheseTable a i -> m (TheseTable a b)
113+bindTheseTable query (TheseTable here (MaybeTable input i)) = do
114+ TheseTable here' (MaybeTable output b) <- query i
115+ pure $ TheseTable (here <> here') (MaybeTable (input <> output) b)
116+
117+
118+bitraverseTheseTable :: (Table DB c, Table DB d)
119+ => (a -> Query c)
120+ -> (b -> Query d)
121+ -> TheseTable a b
122+ -> Query (TheseTable c d)
123+bitraverseTheseTable f g (TheseTable here there) =
124+ bimap fromJustTable fromJustTable <$>
125+ alignBy (\l r -> isJustTable l &&. isJustTable r)
126+ (traverseMaybeTable f here)
127+ (traverseMaybeTable g there)
128+ where
129+ fromJustTable (MaybeTable _ a) = a
src/Rel8/Query/Values.hsnew file+24
@@ -0,0 +1,24 @@
1+{-# language FlexibleContexts #-}
2+
3+module Rel8.Query.Values
4+ ( values
5+ )
6+where
7+
8+-- base
9+import Data.Foldable ( toList )
10+import Prelude
11+
12+-- opaleye
13+import qualified Opaleye.Values as Opaleye
14+
15+-- rel8
16+import {-# SOURCE #-} Rel8.Query ( Query )
17+import Rel8.Query.Opaleye ( fromOpaleye )
18+import Rel8.Table ( Table )
19+import Rel8.Table.Opaleye ( valuesspec )
20+import Rel8.Schema.Context ( DB )
21+
22+
23+values :: (Table DB a, Foldable f) => f a -> Query a
24+values = fromOpaleye . Opaleye.valuesExplicit valuesspec . toList
src/Rel8/Schema/Column.hsnew file+141
@@ -0,0 +1,141 @@
1+{-# language DataKinds #-}
2+{-# language TypeFamilies #-}
3+{-# language StandaloneKindSignatures #-}
4+
5+module Rel8.Schema.Column
6+ ( Column, Default, Label
7+ , HEither
8+ , HList
9+ , HMaybe
10+ , HNonEmpty
11+ , HThese
12+ )
13+where
14+
15+-- base
16+import Data.Kind ( Type )
17+import Data.List.NonEmpty ( NonEmpty )
18+import GHC.TypeLits ( Symbol )
19+import Prelude
20+
21+-- rel8
22+import Rel8.Kind.Labels ( Labels )
23+import Rel8.Kind.Necessity ( Necessity( Required, Optional ) )
24+import Rel8.Schema.Context ( Result, IsSpecialContext )
25+import Rel8.Schema.Field ( Field )
26+import Rel8.Schema.Nullability ( Unnullify )
27+import Rel8.Schema.Spec ( Context )
28+import Rel8.Schema.Structure
29+ ( Structure
30+ , Shape( Either, List, Maybe, NonEmpty, These )
31+ , Shape1
32+ , Shape2
33+ )
34+import Rel8.Table.Either ( EitherTable )
35+import Rel8.Table.List ( ListTable )
36+import Rel8.Table.Maybe ( MaybeTable )
37+import Rel8.Table.NonEmpty ( NonEmptyTable )
38+import Rel8.Table.These ( TheseTable )
39+
40+-- these
41+import Data.These ( These )
42+
43+
44+type Label :: Symbol -> Type -> Type
45+data Label label a
46+
47+
48+type Default :: Type -> Type
49+data Default a
50+
51+
52+type GetLabel :: Type -> Labels
53+type family GetLabel a where
54+ GetLabel (Label label _) = '[label]
55+ GetLabel _ = '[]
56+
57+
58+type UnwrapLabel :: Type -> Type
59+type family UnwrapLabel a where
60+ UnwrapLabel (Label _ a) = a
61+ UnwrapLabel a = a
62+
63+
64+type GetNecessity :: Type -> Necessity
65+type family GetNecessity a where
66+ GetNecessity (Default _) = 'Optional
67+ GetNecessity _ = 'Required
68+
69+
70+type UnwrapDefault :: Type -> Type
71+type family UnwrapDefault a where
72+ UnwrapDefault (Default a) = a
73+ UnwrapDefault a = a
74+
75+
76+type Column :: Context -> Type -> Type
77+type Column context a =
78+ Field context (GetLabel a)
79+ (GetNecessity (UnwrapLabel a))
80+ (Unnullify (UnwrapDefault (UnwrapLabel a)))
81+ (UnwrapDefault (UnwrapLabel a))
82+
83+
84+type IHEither :: Bool -> Context -> Type -> Type -> Type
85+type family IHEither isSpecialContext context where
86+ IHEither 'False _ = EitherTable
87+ IHEither 'True Result = Either
88+ IHEither 'True Structure = Shape2 'Either
89+ IHEither 'True _ = EitherTable
90+
91+
92+type IHList :: Bool -> Context -> Type -> Type
93+type family IHList isSpecialContext context where
94+ IHList 'False _ = ListTable
95+ IHList 'True Result = []
96+ IHList 'True Structure = Shape1 'List
97+ IHList 'True _ = ListTable
98+
99+
100+type IHMaybe :: Bool -> Context -> Type -> Type
101+type family IHMaybe isSpecialContext context where
102+ IHMaybe 'False _ = MaybeTable
103+ IHMaybe 'True Result = Maybe
104+ IHMaybe 'True Structure = Shape1 'Maybe
105+ IHMaybe 'True _ = MaybeTable
106+
107+
108+type IHNonEmpty :: Bool -> Context -> Type -> Type
109+type family IHNonEmpty isSpecialContext context where
110+ IHNonEmpty 'False _ = NonEmptyTable
111+ IHNonEmpty 'True Result = NonEmpty
112+ IHNonEmpty 'True Structure = Shape1 'NonEmpty
113+ IHNonEmpty 'True _ = NonEmptyTable
114+
115+
116+type IHThese :: Bool -> Context -> Type -> Type -> Type
117+type family IHThese isSpecialContext context where
118+ IHThese 'False _ = TheseTable
119+ IHThese 'True Result = These
120+ IHThese 'True Structure = Shape2 'These
121+ IHThese 'True _ = TheseTable
122+
123+
124+type HEither :: Context -> Type -> Type -> Type
125+type HEither context = IHEither (IsSpecialContext context) context
126+
127+
128+type HList :: Context -> Type -> Type
129+type HList context = IHList (IsSpecialContext context) context
130+
131+
132+type HMaybe :: Context -> Type -> Type
133+type HMaybe context = IHMaybe (IsSpecialContext context) context
134+
135+
136+type HNonEmpty :: Context -> Type -> Type
137+type HNonEmpty context = IHNonEmpty (IsSpecialContext context) context
138+
139+
140+type HThese :: Context -> Type -> Type -> Type
141+type HThese context = IHThese (IsSpecialContext context) context
src/Rel8/Schema/Context.hsnew file+144
@@ -0,0 +1,144 @@
1+{-# language DataKinds #-}
2+{-# language DerivingStrategies #-}
3+{-# language FlexibleInstances #-}
4+{-# language GADTs #-}
5+{-# language GeneralizedNewtypeDeriving #-}
6+{-# language ScopedTypeVariables #-}
7+{-# language StandaloneDeriving #-}
8+{-# language StandaloneKindSignatures #-}
9+{-# language TypeApplications #-}
10+{-# language TypeFamilies #-}
11+{-# language UndecidableInstances #-}
12+
13+module Rel8.Schema.Context
14+ ( Aggregation( Aggregation )
15+ , DB( DB, unDB )
16+ , Insertion( RequiredInsert, OptionalInsert )
17+ , Name( Name )
18+ , Result( Result )
19+ , IsSpecialContext
20+ )
21+where
22+
23+-- base
24+import Control.Applicative ( liftA2 )
25+import Data.String ( IsString )
26+import Prelude
27+
28+-- rel8
29+import Rel8.Aggregate ( Aggregate )
30+import Rel8.Expr ( Expr )
31+import Rel8.Kind.Necessity
32+ ( Necessity( Optional, Required )
33+ , SNecessity( SOptional, SRequired )
34+ , KnownNecessity, necessitySing
35+ )
36+import Rel8.Schema.Nullability ( Nullabilizes )
37+import Rel8.Schema.Spec ( Context, Spec( Spec ) )
38+import Rel8.Schema.Structure ( Structure )
39+import Rel8.Type.Monoid ( DBMonoid )
40+import Rel8.Type.Semigroup ( DBSemigroup )
41+
42+
43+type Aggregation :: Context
44+data Aggregation spec where
45+ Aggregation :: ()
46+ => Aggregate (Expr a)
47+ -> Aggregation ('Spec labels necessity dbType a)
48+
49+
50+type DB :: Context
51+data DB spec where
52+ DB :: ()
53+ => { unDB :: Expr a }
54+ -> DB ('Spec labels necessity dbType a)
55+deriving stock instance Show (DB spec)
56+
57+
58+instance
59+ ( spec ~ 'Spec labels necessity dbType a
60+ , DBSemigroup dbType
61+ , Nullabilizes dbType a
62+ ) =>
63+ Semigroup (DB spec)
64+ where
65+ DB a <> DB b = DB (a <> b)
66+
67+
68+instance
69+ ( spec ~ 'Spec labels necessity dbType a
70+ , DBMonoid dbType
71+ , Nullabilizes dbType a
72+ ) =>
73+ Monoid (DB spec)
74+ where
75+ mempty = DB mempty
76+
77+
78+type Insertion :: Context
79+data Insertion spec where
80+ RequiredInsert :: ()
81+ => Expr a
82+ -> Insertion ('Spec labels 'Required dbType a)
83+ OptionalInsert :: ()
84+ => Maybe (Expr a)
85+ -> Insertion ('Spec labels 'Optional dbType a)
86+deriving stock instance Show (Insertion spec)
87+
88+
89+instance
90+ ( spec ~ 'Spec labels necessity dbType a
91+ , DBSemigroup dbType
92+ , Nullabilizes dbType a
93+ ) =>
94+ Semigroup (Insertion spec)
95+ where
96+ RequiredInsert a <> RequiredInsert b = RequiredInsert (a <> b)
97+ OptionalInsert ma <> OptionalInsert mb = OptionalInsert (liftA2 (<>) ma mb)
98+
99+
100+instance
101+ ( spec ~ 'Spec labels necessity dbType a
102+ , KnownNecessity necessity
103+ , DBMonoid dbType
104+ , Nullabilizes dbType a
105+ ) => Monoid (Insertion spec)
106+ where
107+ mempty = case necessitySing @necessity of
108+ SRequired -> RequiredInsert mempty
109+ SOptional -> OptionalInsert (Just mempty)
110+
111+
112+type Name :: Context
113+newtype Name spec = Name String
114+ deriving stock Show
115+ deriving newtype (IsString, Monoid, Semigroup)
116+
117+
118+type Result :: Context
119+data Result spec where
120+ Result :: a -> Result ('Spec labels necessity dbType a)
121+deriving stock instance Show a =>
122+ Show (Result ('Spec labels necessity dbType a))
123+
124+
125+instance (spec ~ 'Spec labels necessity dbType a, Semigroup a) =>
126+ Semigroup (Result spec)
127+ where
128+ Result a <> Result b = Result (a <> b)
129+
130+
131+instance (spec ~ 'Spec labels necessity dbType a, Monoid a) =>
132+ Monoid (Result spec)
133+ where
134+ mempty = Result mempty
135+
136+
137+type IsSpecialContext :: Context -> Bool
138+type family IsSpecialContext context where
139+ IsSpecialContext Aggregation = 'True
140+ IsSpecialContext DB = 'True
141+ IsSpecialContext Insertion = 'True
142+ IsSpecialContext Result = 'True
143+ IsSpecialContext Structure = 'True
144+ IsSpecialContext _ = 'False
src/Rel8/Schema/Context/Label.hsnew file+67
@@ -0,0 +1,67 @@
1+{-# language DataKinds #-}
2+{-# language LambdaCase #-}
3+{-# language FlexibleInstances #-}
4+{-# language MultiParamTypeClasses #-}
5+{-# language StandaloneKindSignatures #-}
6+{-# language TypeFamilies #-}
7+{-# language TypeOperators #-}
8+
9+module Rel8.Schema.Context.Label
10+ ( Labelable( labeler, unlabeler )
11+ )
12+where
13+
14+-- base
15+import Data.Kind ( Constraint )
16+import Prelude hiding ( null )
17+
18+-- rel8
19+import Rel8.Schema.Context
20+ ( Aggregation( Aggregation )
21+ , DB( DB )
22+ , Insertion( RequiredInsert, OptionalInsert )
23+ , Name( Name )
24+ , Result( Result )
25+ )
26+import Rel8.Schema.Spec ( Context, Spec( Spec ) )
27+
28+
29+type Labelable :: Context -> Constraint
30+class Labelable context where
31+ labeler :: ()
32+ => context ('Spec labels necessity db a)
33+ -> context ('Spec (label ': labels) necessity db a)
34+
35+ unlabeler :: ()
36+ => context ('Spec (label ': labels) necessity db a)
37+ -> context ('Spec labels necessity db a)
38+
39+
40+instance Labelable Aggregation where
41+ labeler (Aggregation aggregate) = Aggregation aggregate
42+ unlabeler (Aggregation aggregate) = Aggregation aggregate
43+
44+
45+instance Labelable DB where
46+ labeler (DB a) = DB a
47+ unlabeler (DB a) = DB a
48+
49+
50+instance Labelable Insertion where
51+ labeler = \case
52+ RequiredInsert a -> RequiredInsert a
53+ OptionalInsert ma -> OptionalInsert ma
54+
55+ unlabeler = \case
56+ RequiredInsert a -> RequiredInsert a
57+ OptionalInsert ma -> OptionalInsert ma
58+
59+
60+instance Labelable Name where
61+ labeler (Name name) = Name name
62+ unlabeler (Name name) = Name name
63+
64+
65+instance Labelable Result where
66+ labeler (Result a) = Result a
67+ unlabeler (Result a) = Result a
src/Rel8/Schema/Context/Nullify.hsnew file+165
@@ -0,0 +1,165 @@
1+{-# language DataKinds #-}
2+{-# language LambdaCase #-}
3+{-# language FlexibleContexts #-}
4+{-# language FlexibleInstances #-}
5+{-# language MultiParamTypeClasses #-}
6+{-# language NamedFieldPuns #-}
7+{-# language ScopedTypeVariables #-}
8+{-# language StandaloneKindSignatures #-}
9+{-# language TypeApplications #-}
10+{-# language TypeFamilies #-}
11+
12+module Rel8.Schema.Context.Nullify
13+ ( Nullifiable( encodeTag, decodeTag, nullifier, unnullifier )
14+ , NullifiableEq
15+ )
16+where
17+
18+-- base
19+import Control.Applicative ( empty )
20+import Data.Foldable ( fold )
21+import Data.Kind ( Constraint )
22+import qualified Data.List.NonEmpty as NonEmpty
23+import Data.Monoid ( First( First ), getFirst )
24+import Prelude hiding ( null )
25+
26+-- opaleye
27+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
28+
29+-- rel8
30+import Rel8.Aggregate ( Aggregate, foldInputs, mapInputs )
31+import Rel8.Expr ( Expr( Expr ) )
32+import Rel8.Expr.Aggregate ( groupByExpr )
33+import Rel8.Expr.Bool ( boolExpr )
34+import Rel8.Expr.Null ( nullify, unsafeUnnullify )
35+import Rel8.Expr.Opaleye ( unsafeFromPrimExpr, unsafeToPrimExpr )
36+import Rel8.Kind.Labels ( KnownLabels, labelsSing, renderLabels )
37+import Rel8.Kind.Necessity ( Necessity( Required ) )
38+import Rel8.Schema.Context
39+ ( Aggregation( Aggregation )
40+ , DB( DB )
41+ , Insertion( RequiredInsert, OptionalInsert )
42+ , Name( Name )
43+ )
44+import Rel8.Schema.Nullability
45+ ( Nullability( Nullable, NonNullable )
46+ , Nullabilizes
47+ )
48+import Rel8.Schema.Spec ( Context, Spec( Spec ), SSpec(..) )
49+import Rel8.Type.Eq ( DBEq )
50+import Rel8.Type.Monoid ( DBMonoid )
51+
52+
53+type Nullifiable :: Context -> Constraint
54+class Nullifiable context where
55+ encodeTag :: (DBEq db, Nullabilizes db a, KnownLabels labels)
56+ => Expr a
57+ -> context ('Spec labels 'Required db a)
58+
59+ decodeTag :: (DBMonoid db, Nullabilizes db a)
60+ => context ('Spec labels 'Required db a)
61+ -> Expr a
62+
63+ nullifier :: ()
64+ => Expr Bool
65+ -> SSpec ('Spec labels necessity db a)
66+ -> context ('Spec labels necessity db a)
67+ -> context ('Spec labels necessity db (Maybe db))
68+
69+ unnullifier :: ()
70+ => Expr Bool
71+ -> SSpec ('Spec labels necessity db a)
72+ -> context ('Spec labels necessity db (Maybe db))
73+ -> context ('Spec labels necessity db a)
74+
75+
76+instance Nullifiable Aggregation where
77+ encodeTag = Aggregation . groupByExpr
78+ decodeTag (Aggregation aggregate) = fold $ undoGroupBy aggregate
79+
80+ nullifier tag SSpec {nullability} (Aggregation aggregate) = Aggregation $
81+ mapInputs (unsafeToPrimExpr . runTag nullability tag . unsafeFromPrimExpr) $
82+ runTag nullability tag <$> aggregate
83+
84+ unnullifier _ SSpec {nullability} (Aggregation aggregate) =
85+ Aggregation $ unnull nullability <$> aggregate
86+
87+ {-# INLINABLE encodeTag #-}
88+ {-# INLINABLE decodeTag #-}
89+ {-# INLINABLE nullifier #-}
90+ {-# INLINABLE unnullifier #-}
91+
92+
93+instance Nullifiable DB where
94+ encodeTag = DB
95+ decodeTag (DB a) = a
96+ nullifier tag SSpec {nullability} (DB a) = DB $ runTag nullability tag a
97+ unnullifier _ SSpec {nullability} (DB a) = DB $ unnull nullability a
98+
99+ {-# INLINABLE encodeTag #-}
100+ {-# INLINABLE decodeTag #-}
101+ {-# INLINABLE nullifier #-}
102+ {-# INLINABLE unnullifier #-}
103+
104+
105+instance Nullifiable Insertion where
106+ encodeTag = RequiredInsert
107+ decodeTag (RequiredInsert a) = a
108+
109+ nullifier tag SSpec {nullability} = \case
110+ RequiredInsert a -> RequiredInsert $ runTag nullability tag a
111+ OptionalInsert ma -> OptionalInsert $ runTag nullability tag <$> ma
112+
113+ unnullifier _ SSpec {nullability} = \case
114+ RequiredInsert a -> RequiredInsert $ unnull nullability a
115+ OptionalInsert ma -> OptionalInsert $ unnull nullability <$> ma
116+
117+ {-# INLINABLE encodeTag #-}
118+ {-# INLINABLE decodeTag #-}
119+ {-# INLINABLE nullifier #-}
120+ {-# INLINABLE unnullifier #-}
121+
122+
123+instance Nullifiable Name where
124+ encodeTag _ = nameFromLabel
125+ decodeTag _ = mempty
126+ nullifier _ _ (Name name) = Name name
127+ unnullifier _ _ (Name name) = Name name
128+
129+ {-# INLINABLE encodeTag #-}
130+ {-# INLINABLE decodeTag #-}
131+ {-# INLINABLE nullifier #-}
132+ {-# INLINABLE unnullifier #-}
133+
134+
135+type NullifiableEq :: Context -> Context -> Constraint
136+class (a ~ b, Nullifiable b) => NullifiableEq a b
137+instance (a ~ b, Nullifiable b) => NullifiableEq a b
138+
139+
140+runTag :: Nullability db a -> Expr Bool -> Expr a -> Expr (Maybe db)
141+runTag nullability tag a = case nullability of
142+ Nullable -> boolExpr null a tag
143+ NonNullable -> boolExpr null (nullify a) tag
144+ where
145+ null = Expr (Opaleye.ConstExpr Opaleye.NullLit)
146+
147+
148+unnull :: Nullability db a -> Expr (Maybe db) -> Expr a
149+unnull nullability a = case nullability of
150+ Nullable -> a
151+ NonNullable -> unsafeUnnullify a
152+
153+
154+-- HACK
155+undoGroupBy :: Aggregate (Expr _a) -> Maybe (Expr a)
156+undoGroupBy = getFirst . foldInputs go
157+ where
158+ go Nothing a = pure (Expr a)
159+ go _ _ = First empty
160+
161+
162+nameFromLabel :: forall labels necessity db a.
163+ KnownLabels labels => Name ('Spec labels necessity db a)
164+nameFromLabel = case labelsSing @labels of
165+ labels -> Name (NonEmpty.last (renderLabels labels))
src/Rel8/Schema/Context/Result.hsnew file+198
@@ -0,0 +1,198 @@
1+{-# language DataKinds #-}
2+{-# language DisambiguateRecordFields #-}
3+{-# language NamedFieldPuns #-}
4+{-# language TypeFamilies #-}
5+
6+module Rel8.Schema.Context.Result
7+ ( fromHEitherTable, toHEitherTable
8+ , fromHListTable, toHListTable
9+ , fromHMaybeTable, toHMaybeTable
10+ , fromHNonEmptyTable, toHNonEmptyTable
11+ , fromHTheseTable, toHTheseTable
12+ )
13+where
14+
15+-- base
16+import Data.Functor ( ($>) )
17+import Data.List.NonEmpty ( NonEmpty )
18+import Prelude hiding ( null )
19+
20+-- rel8
21+import Rel8.Schema.Context ( Result( Result ) )
22+import Rel8.Schema.HTable ( HTable )
23+import Rel8.Schema.HTable.Context ( H )
24+import Rel8.Schema.HTable.Either ( HEitherTable(..) )
25+import Rel8.Schema.HTable.Identity ( HIdentity(..) )
26+import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
27+import Rel8.Schema.HTable.List ( HListTable )
28+import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
29+import Rel8.Schema.HTable.Nullify ( hnulls, hnullify, hunnullify )
30+import Rel8.Schema.HTable.These ( HTheseTable(..) )
31+import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize )
32+import Rel8.Schema.Nullability
33+ ( Nullability( Nullable, NonNullable )
34+ )
35+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
36+import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), MaybeTag( IsJust ) )
37+
38+-- these
39+import Data.These ( These( This, That, These ) )
40+import Data.These.Combinators ( justHere, justThere )
41+
42+
43+toHEitherTable :: (HTable t, HTable u)
44+ => Either (t (H Result)) (u (H Result))
45+ -> HEitherTable t u (H Result)
46+toHEitherTable = either hleft hright
47+ where
48+ hleft table = HEitherTable
49+ { htag = HIdentity (Result IsLeft)
50+ , hleft = hnullify nullifier table
51+ , hright = hnulls null
52+ }
53+ hright table = HEitherTable
54+ { htag = HIdentity (Result IsRight)
55+ , hleft = hnulls null
56+ , hright = hnullify nullifier table
57+ }
58+{-# INLINABLE toHEitherTable #-}
59+
60+
61+fromHEitherTable :: (HTable t, HTable u)
62+ => HEitherTable t u (H Result)
63+ -> Either (t (H Result)) (u (H Result))
64+fromHEitherTable HEitherTable {htag, hleft, hright} = case htag of
65+ HIdentity (Result tag) -> case tag of
66+ IsLeft -> maybe err Left $ hunnullify unnullifier hleft
67+ IsRight -> maybe err Right $ hunnullify unnullifier hright
68+ where
69+ err = error "fromHEitherTable: mismatch between tag and data"
70+{-# INLINABLE fromHEitherTable #-}
71+
72+
73+toHListTable :: HTable t => [t (H Result)] -> HListTable t (H Result)
74+toHListTable = hvectorize vectorizer
75+{-# INLINABLE toHListTable #-}
76+
77+
78+fromHListTable :: HTable t => HListTable t (H Result) -> [t (H Result)]
79+fromHListTable = hunvectorize unvectorizer
80+{-# INLINABLE fromHListTable #-}
81+
82+
83+toHMaybeTable :: HTable t => Maybe (t (H Result)) -> HMaybeTable t (H Result)
84+toHMaybeTable = maybe hnothing hjust
85+ where
86+ hnothing = HMaybeTable
87+ { htag = HIdentity (Result Nothing)
88+ , hjust = hnulls null
89+ }
90+ hjust table = HMaybeTable
91+ { htag = HIdentity (Result (Just IsJust))
92+ , hjust = hnullify nullifier table
93+ }
94+{-# INLINABLE toHMaybeTable #-}
95+
96+
97+fromHMaybeTable :: HTable t => HMaybeTable t (H Result) -> Maybe (t (H Result))
98+fromHMaybeTable HMaybeTable {htag, hjust} = case htag of
99+ HIdentity (Result tag) -> tag $>
100+ case hunnullify unnullifier hjust of
101+ Nothing -> error "fromHMaybeTable: mismatch between tag and data"
102+ Just just -> just
103+{-# INLINABLE fromHMaybeTable #-}
104+
105+
106+toHNonEmptyTable :: HTable t => NonEmpty (t (H Result)) -> HNonEmptyTable t (H Result)
107+toHNonEmptyTable = hvectorize vectorizer
108+{-# INLINABLE toHNonEmptyTable #-}
109+
110+
111+fromHNonEmptyTable :: HTable t => HNonEmptyTable t (H Result) -> NonEmpty (t (H Result))
112+fromHNonEmptyTable = hunvectorize unvectorizer
113+{-# INLINABLE fromHNonEmptyTable #-}
114+
115+
116+toHTheseTable :: (HTable t, HTable u)
117+ => These (t (H Result)) (u (H Result))
118+ -> HTheseTable t u (H Result)
119+toHTheseTable tables = HTheseTable
120+ { hhereTag = relabel hhereTag
121+ , hhere
122+ , hthereTag = relabel hthereTag
123+ , hthere
124+ }
125+ where
126+ HMaybeTable
127+ { htag = hhereTag
128+ , hjust = hhere
129+ } = toHMaybeTable (justHere tables)
130+ HMaybeTable
131+ { htag = hthereTag
132+ , hjust = hthere
133+ } = toHMaybeTable (justThere tables)
134+{-# INLINABLE toHTheseTable #-}
135+
136+
137+fromHTheseTable :: (HTable t, HTable u)
138+ => HTheseTable t u (H Result)
139+ -> These (t (H Result)) (u (H Result))
140+fromHTheseTable HTheseTable {hhereTag, hhere, hthereTag, hthere} =
141+ case (fromHMaybeTable mhere, fromHMaybeTable mthere) of
142+ (Just a, Nothing) -> This a
143+ (Nothing, Just b) -> That b
144+ (Just a, Just b) -> These a b
145+ _ -> error "fromHTheseTable: mismatch between tags and data"
146+ where
147+ mhere = HMaybeTable
148+ { htag = relabel hhereTag
149+ , hjust = hhere
150+ }
151+ mthere = HMaybeTable
152+ { htag = relabel hthereTag
153+ , hjust = hthere
154+ }
155+{-# INLINABLE fromHTheseTable #-}
156+
157+
158+null :: Result ('Spec labels necessity db (Maybe db))
159+null = Result Nothing
160+
161+
162+nullifier :: ()
163+ => SSpec ('Spec labels necessity db a)
164+ -> Result ('Spec labels necessity db a)
165+ -> Result ('Spec labels necessity db (Maybe db))
166+nullifier SSpec {nullability} (Result a) = Result $ case nullability of
167+ Nullable -> a
168+ NonNullable -> Just a
169+
170+
171+unnullifier :: ()
172+ => SSpec ('Spec labels necessity db a)
173+ -> Result ('Spec labels necessity db (Maybe db))
174+ -> Maybe (Result ('Spec labels necessity db a))
175+unnullifier SSpec {nullability} (Result a) =
176+ case nullability of
177+ Nullable -> pure $ Result a
178+ NonNullable -> Result <$> a
179+
180+
181+vectorizer :: Functor f
182+ => SSpec ('Spec labels necessity db a)
183+ -> f (Result ('Spec labels necessity db a))
184+ -> Result ('Spec labels necessity (f a) (f a))
185+vectorizer _ = Result . fmap (\(Result a) -> a)
186+
187+
188+unvectorizer :: Functor f
189+ => SSpec ('Spec labels necessity db a)
190+ -> Result ('Spec labels necessity (f a) (f a))
191+ -> f (Result ('Spec labels necessity db a))
192+unvectorizer _ (Result results) = Result <$> results
193+
194+
195+relabel :: ()
196+ => HIdentity ('Spec labels necessity db a) (H Result)
197+ -> HIdentity ('Spec relabels necessity db a) (H Result)
198+relabel (HIdentity (Result a)) = HIdentity (Result a)
src/Rel8/Schema/Dict.hsnew file+18
@@ -0,0 +1,18 @@
1+{-# language ConstraintKinds #-}
2+{-# language GADTs #-}
3+{-# language PolyKinds #-}
4+{-# language StandaloneKindSignatures #-}
5+
6+module Rel8.Schema.Dict
7+ ( Dict( Dict )
8+ )
9+where
10+
11+-- base
12+import Data.Kind ( Constraint, Type )
13+import Prelude ()
14+
15+
16+type Dict :: (a -> Constraint) -> a -> Type
17+data Dict c a where
18+ Dict :: c a => Dict c a
src/Rel8/Schema/Field.hsnew file+41
@@ -0,0 +1,41 @@
1+{-# language DataKinds #-}
2+{-# language StandaloneKindSignatures #-}
3+{-# language TypeFamilies #-}
4+{-# language UndecidableInstances #-}
5+
6+module Rel8.Schema.Field
7+ ( Field
8+ )
9+where
10+
11+-- base
12+import Data.Kind ( Type )
13+import Prelude
14+
15+-- rel8
16+import Rel8.Aggregate ( Aggregate )
17+import Rel8.Expr ( Expr )
18+import Rel8.Kind.Labels ( Labels )
19+import Rel8.Kind.Necessity ( Necessity( Required, Optional ) )
20+import Rel8.Schema.Context
21+ ( Aggregation, DB, Insertion, Result
22+ , IsSpecialContext
23+ )
24+import Rel8.Schema.Spec ( Context, Spec( Spec ) )
25+import Rel8.Schema.Structure ( Structure, Shape( Column ), Shape1 )
26+
27+
28+type IField :: Bool -> Context -> Labels -> Necessity -> Type -> Type -> Type
29+type family IField isSpecialContext labels context necessity db a where
30+ IField 'False context labels necessity db a = context ('Spec labels necessity db a)
31+ IField 'True Result _labels _necessity _db a = a
32+ IField 'True DB _labels _necessity _db a = Expr a
33+ IField 'True Insertion _labels 'Required _db a = Expr a
34+ IField 'True Insertion _labels 'Optional _db a = Maybe (Expr a)
35+ IField 'True Aggregation _labels _necessity _db a = Aggregate (Expr a)
36+ IField 'True Structure labels necessity db a = Shape1 'Column ('Spec labels necessity db a)
37+
38+
39+type Field :: Context -> Labels -> Necessity -> Type -> Type -> Type
40+type Field context labels necessity db a =
41+ IField (IsSpecialContext context) context labels necessity db a
src/Rel8/Schema/Generic.hsnew file+1021
@@ -0,0 +1,1021 @@
1+{-# language AllowAmbiguousTypes #-}
2+{-# language DataKinds #-}
3+{-# language DisambiguateRecordFields #-}
4+{-# language DefaultSignatures #-}
5+{-# language FlexibleContexts #-}
6+{-# language FlexibleInstances #-}
7+{-# language GADTs #-}
8+{-# language MultiParamTypeClasses #-}
9+{-# language ScopedTypeVariables #-}
10+{-# language StandaloneKindSignatures #-}
11+{-# language TypeApplications #-}
12+{-# language TypeFamilies #-}
13+{-# language TypeOperators #-}
14+{-# language UndecidableInstances #-}
15+{-# language ViewPatterns #-}
16+
17+{-# options_ghc -fno-warn-orphans #-}
18+
19+module Rel8.Schema.Generic
20+ ( Rel8able
21+ )
22+where
23+
24+-- base
25+import Data.Bifunctor ( bimap )
26+import Data.Kind ( Constraint, Type )
27+import Data.List.NonEmpty ( NonEmpty )
28+import GHC.Generics
29+ ( Generic, Rep, from, to
30+ , (:*:)( (:*:) ), K1( K1 ), M1( M1 )
31+ , D, C, S
32+ , Meta( MetaSel )
33+ )
34+import GHC.TypeLits ( Symbol )
35+import Prelude
36+
37+-- rel8
38+import Rel8.Kind.Necessity
39+ ( SNecessity( SRequired, SOptional )
40+ , KnownNecessity, necessitySing
41+ )
42+import Rel8.Schema.Context
43+ ( Aggregation( Aggregation )
44+ , DB( DB )
45+ , Insertion( RequiredInsert, OptionalInsert )
46+ , Result( Result )
47+ , IsSpecialContext
48+ )
49+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
50+import Rel8.Schema.Context.Nullify ( Nullifiable )
51+import Rel8.Schema.Context.Result
52+ ( fromHEitherTable, toHEitherTable
53+ , fromHListTable, toHListTable
54+ , fromHMaybeTable, toHMaybeTable
55+ , fromHNonEmptyTable, toHNonEmptyTable
56+ , fromHTheseTable, toHTheseTable
57+ )
58+import Rel8.Schema.Field ( Field )
59+import Rel8.Schema.HTable ( HTable )
60+import Rel8.Schema.HTable.Context ( H, HKTable )
61+import Rel8.Schema.HTable.Either ( HEitherTable )
62+import Rel8.Schema.HTable.Identity ( HIdentity(..) )
63+import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
64+import Rel8.Schema.HTable.List ( HListTable )
65+import Rel8.Schema.HTable.Maybe ( HMaybeTable )
66+import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
67+import Rel8.Schema.HTable.Pair ( HPair(..) )
68+import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
69+import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
70+import Rel8.Schema.HTable.These ( HTheseTable )
71+import Rel8.Schema.HTable.Trio ( HTrio(..) )
72+import Rel8.Schema.HTable.Vectorize ( hrelabel )
73+import Rel8.Schema.Spec ( Spec( Spec ), KTable )
74+import qualified Rel8.Schema.Spec as Kind ( Context )
75+import Rel8.Schema.Structure
76+ ( IsStructure, Shape(..), Shape1, Shape2
77+ , Structure
78+ )
79+import Rel8.Table
80+ ( Table, Columns, Context, fromColumns, toColumns
81+ )
82+import Rel8.Table.Either ( EitherTable )
83+import Rel8.Table.Lifted
84+ ( fromColumns1, toColumns1
85+ , fromColumns2, toColumns2
86+ )
87+import Rel8.Table.List ( ListTable )
88+import Rel8.Table.Maybe ( MaybeTable(..) )
89+import Rel8.Table.NonEmpty ( NonEmptyTable )
90+import Rel8.Table.These ( TheseTable )
91+
92+-- these
93+import Data.These ( These )
94+
95+
96+instance (Rel8able t, TableHelper (IsSpecialContext context) context) =>
97+ Table context (t context)
98+ where
99+ type Columns (t context) = GRep t
100+ type Context (t context) = context
101+ fromColumns = gfromColumns
102+ toColumns = gtoColumns
103+
104+
105+type TableHelper :: Bool -> Kind.Context -> Constraint
106+class IsSpecialContext context ~ isSpecialContext =>
107+ TableHelper isSpecialContext context
108+ where
109+ gfromColumns :: Rel8able t => GRep t (H context) -> t context
110+ gtoColumns :: Rel8able t => t context -> GRep t (H context)
111+
112+
113+instance TableHelper 'True Aggregation where
114+ gfromColumns = fromAggregationColumns
115+ gtoColumns = toAggregationColumns
116+
117+
118+instance TableHelper 'True DB where
119+ gfromColumns = fromDBColumns
120+ gtoColumns = toDBColumns
121+
122+
123+instance TableHelper 'True Insertion where
124+ gfromColumns = fromInsertionColumns
125+ gtoColumns = toInsertionColumns
126+
127+
128+instance TableHelper 'True Result where
129+ gfromColumns = fromResultColumns
130+ gtoColumns = toResultColumns
131+
132+
133+instance (IsSpecialContext context ~ 'False, Labelable context, Nullifiable context) =>
134+ TableHelper 'False context
135+ where
136+ gfromColumns = fromUnspecialColumns
137+ gtoColumns = toUnspecialColumns
138+
139+
140+type Rel8able :: KTable -> Constraint
141+class HTable (GRep t) => Rel8able t where
142+ type GRep t :: HKTable
143+
144+ fromAggregationColumns :: GRep t (H Aggregation) -> t Aggregation
145+ toAggregationColumns :: t Aggregation -> GRep t (H Aggregation)
146+
147+ fromDBColumns :: GRep t (H DB) -> t DB
148+ toDBColumns :: t DB -> GRep t (H DB)
149+
150+ fromInsertionColumns :: GRep t (H Insertion) -> t Insertion
151+ toInsertionColumns :: t Insertion -> GRep t (H Insertion)
152+
153+ fromResultColumns :: GRep t (H Result) -> t Result
154+ toResultColumns :: t Result -> GRep t (H Result)
155+
156+ fromUnspecialColumns ::
157+ ( IsSpecialContext context ~ 'False
158+ , Labelable context, Nullifiable context
159+ )
160+ => GRep t (H context) -> t context
161+ toUnspecialColumns ::
162+ ( IsSpecialContext context ~ 'False
163+ , Labelable context, Nullifiable context
164+ )
165+ => t context -> GRep t (H context)
166+
167+ type GRep t = GColumns (Rep (t Structure))
168+
169+ default fromAggregationColumns ::
170+ ( Generic (t Aggregation)
171+ , GColumns (Rep (t Structure)) ~ GRep t
172+ , GRel8able Aggregation (Rep (t Structure)) (Rep (t Aggregation))
173+ ) => GRep t (H Aggregation) -> t Aggregation
174+ fromAggregationColumns = to . fromGColumns @_ @(Rep (t Structure))
175+
176+ default toAggregationColumns ::
177+ ( Generic (t Aggregation)
178+ , GColumns (Rep (t Structure)) ~ GRep t
179+ , GRel8able Aggregation (Rep (t Structure)) (Rep (t Aggregation))
180+ ) => t Aggregation -> GRep t (H Aggregation)
181+ toAggregationColumns = toGColumns @_ @(Rep (t Structure)) . from
182+
183+ default fromDBColumns ::
184+ ( Generic (t DB)
185+ , GColumns (Rep (t Structure)) ~ GRep t
186+ , GRel8able DB (Rep (t Structure)) (Rep (t DB))
187+ ) => GRep t (H DB) -> t DB
188+ fromDBColumns = to . fromGColumns @_ @(Rep (t Structure))
189+
190+ default toDBColumns ::
191+ ( Generic (t DB)
192+ , GColumns (Rep (t Structure)) ~ GRep t
193+ , GRel8able DB (Rep (t Structure)) (Rep (t DB))
194+ ) => t DB -> GRep t (H DB)
195+ toDBColumns = toGColumns @_ @(Rep (t Structure)) . from
196+
197+ default fromInsertionColumns ::
198+ ( Generic (t Insertion)
199+ , GColumns (Rep (t Structure)) ~ GRep t
200+ , GRel8able Insertion (Rep (t Structure)) (Rep (t Insertion))
201+ ) => GRep t (H Insertion) -> t Insertion
202+ fromInsertionColumns = to . fromGColumns @_ @(Rep (t Structure))
203+
204+ default toInsertionColumns ::
205+ ( Generic (t Insertion)
206+ , GColumns (Rep (t Structure)) ~ GRep t
207+ , GRel8able Insertion (Rep (t Structure)) (Rep (t Insertion))
208+ ) => t Insertion -> GRep t (H Insertion)
209+ toInsertionColumns = toGColumns @_ @(Rep (t Structure)) . from
210+
211+ default fromResultColumns ::
212+ ( Generic (t Result)
213+ , GColumns (Rep (t Structure)) ~ GRep t
214+ , GRel8able Result (Rep (t Structure)) (Rep (t Result))
215+ ) => GRep t (H Result) -> t Result
216+ fromResultColumns = to . fromGColumns @_ @(Rep (t Structure))
217+
218+ default toResultColumns ::
219+ ( Generic (t Result)
220+ , GColumns (Rep (t Structure)) ~ GRep t
221+ , GRel8able Result (Rep (t Structure)) (Rep (t Result))
222+ ) => t Result -> GRep t (H Result)
223+ toResultColumns = toGColumns @_ @(Rep (t Structure)) . from
224+
225+ default fromUnspecialColumns ::
226+ ( Generic (t context)
227+ , GColumns (Rep (t Structure)) ~ GRep t
228+ , GRel8able context (Rep (t Structure)) (Rep (t context))
229+ ) => GRep t (H context) -> t context
230+ fromUnspecialColumns = to . fromGColumns @_ @(Rep (t Structure))
231+
232+ default toUnspecialColumns ::
233+ ( Generic (t context)
234+ , GColumns (Rep (t Structure)) ~ GRep t
235+ , GRel8able context (Rep (t Structure)) (Rep (t context))
236+ ) => t context -> GRep t (H context)
237+ toUnspecialColumns = toGColumns @_ @(Rep (t Structure)) . from
238+
239+
240+type GColumns :: (Type -> Type) -> HKTable
241+type family GColumns structure where
242+ GColumns (M1 D _ structure) = GColumns structure
243+ GColumns (M1 C _ structure) = GColumns structure
244+ GColumns (a :*: b) = HPair (GColumns a) (GColumns b)
245+ GColumns (M1 S ('MetaSel ('Just label) _ _ _) (K1 _ structure)) =
246+ K1Columns label structure
247+
248+
249+type GRel8able :: Kind.Context -> (Type -> Type) -> (Type -> Type) -> Constraint
250+class GRel8able context structure rep where
251+ fromGColumns :: GColumns structure (H context) -> rep x
252+ toGColumns :: rep x -> GColumns structure (H context)
253+
254+
255+instance GRel8able context structure rep => GRel8able context (M1 D c structure) (M1 D c rep) where
256+ fromGColumns = M1 . fromGColumns @context @structure @rep
257+ toGColumns (M1 a) = toGColumns @context @structure @rep a
258+
259+
260+instance GRel8able context structure rep => GRel8able context (M1 C c structure) (M1 C c rep) where
261+ fromGColumns = M1 . fromGColumns @context @structure @rep
262+ toGColumns (M1 a) = toGColumns @context @structure @rep a
263+
264+
265+instance (GRel8able context structure1 rep1, GRel8able context structure2 rep2) =>
266+ GRel8able context (structure1 :*: structure2) (rep1 :*: rep2)
267+ where
268+ fromGColumns (HPair a b) =
269+ fromGColumns @context @structure1 @rep1 a :*:
270+ fromGColumns @context @structure2 @rep2 b
271+ toGColumns (a :*: b) =
272+ HPair
273+ (toGColumns @context @structure1 @rep1 a)
274+ (toGColumns @context @structure2 @rep2 b)
275+
276+
277+instance
278+ ( K1Table label isSpecialContext context isStructure structure a
279+ , meta ~ 'MetaSel ('Just label) _su _ss _ds
280+ , structureK1 ~ K1 i structure
281+ , k1 ~ K1 i a
282+ ) => GRel8able context (M1 S meta structureK1) (M1 S meta k1)
283+ where
284+ fromGColumns = M1 . K1 . fromK1Columns @label @_ @_ @_ @structure
285+ toGColumns (M1 (K1 a)) = toK1Columns @label @_ @_ @_ @structure a
286+
287+
288+type K1Columns :: Symbol -> Type -> HKTable
289+type family K1Columns label structure where
290+ K1Columns label (Shape1 'Column ('Spec '[] necessity nullability blueprint)) =
291+ HIdentity ('Spec '[label] necessity nullability blueprint)
292+ K1Columns _label (Shape1 'Column ('Spec (label ': labels) necessity nullability blueprint)) =
293+ HIdentity ('Spec (label ': labels) necessity nullability blueprint)
294+ K1Columns label (Shape2 'Either a b) =
295+ HLabel label (HEitherTable (K1Columns "Left" a) (K1Columns "Right" b))
296+ K1Columns label (Shape1 'List a) = HListTable (K1Columns label a)
297+ K1Columns label (Shape1 'Maybe a) = HLabel label (HMaybeTable (K1Columns "Just" a))
298+ K1Columns label (Shape1 'NonEmpty a) = HNonEmptyTable (K1Columns label a)
299+ K1Columns label (Shape2 'These a b) =
300+ HLabel label (HTheseTable (K1Columns "Here" a) (K1Columns "There" b))
301+ K1Columns label (a, b) =
302+ HLabel label
303+ (HPair
304+ (K1Columns "fst" a)
305+ (K1Columns "snd" b))
306+ K1Columns label (a, b, c) =
307+ HLabel label
308+ (HTrio
309+ (K1Columns "fst" a)
310+ (K1Columns "snd" b)
311+ (K1Columns "trd" c))
312+ K1Columns label (a, b, c, d) =
313+ HLabel label
314+ (HQuartet
315+ (K1Columns "fst" a)
316+ (K1Columns "snd" b)
317+ (K1Columns "trd" c)
318+ (K1Columns "frt" d))
319+ K1Columns label (a, b, c, d, e) =
320+ HLabel label
321+ (HQuintet
322+ (K1Columns "fst" a)
323+ (K1Columns "snd" b)
324+ (K1Columns "trd" c)
325+ (K1Columns "frt" d)
326+ (K1Columns "fft" e))
327+ K1Columns label a = HLabel label (Columns a)
328+
329+
330+type K1Table :: Symbol -> Bool -> Kind.Context -> Bool -> Type -> Type -> Constraint
331+class
332+ ( isSpecialContext ~ IsSpecialContext context
333+ , isStructure ~ IsStructure structure
334+ ) => K1Table label isSpecialContext context isStructure structure a
335+ where
336+ fromK1Columns :: K1Columns label structure (H context) -> a
337+ toK1Columns :: a -> K1Columns label structure (H context)
338+
339+
340+instance
341+ ( x ~ Field Aggregation '[] necessity db a
342+ ) => K1Table label 'True Aggregation 'True (Shape1 'Column ('Spec '[] necessity db a)) x
343+ where
344+ fromK1Columns (HIdentity (Aggregation a)) = a
345+ toK1Columns = HIdentity . Aggregation
346+ {-# INLINABLE fromK1Columns #-}
347+ {-# INLINABLE toK1Columns #-}
348+
349+
350+instance
351+ ( x ~ Field Aggregation (label ': labels) necessity db a
352+ ) => K1Table _label 'True Aggregation 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x
353+ where
354+ fromK1Columns (HIdentity (Aggregation a)) = a
355+ toK1Columns = HIdentity . Aggregation
356+ {-# INLINABLE fromK1Columns #-}
357+ {-# INLINABLE toK1Columns #-}
358+
359+
360+instance
361+ ( x ~ Field DB '[] necessity db a
362+ ) => K1Table label 'True DB 'True (Shape1 'Column ('Spec '[] necessity db a)) x
363+ where
364+ fromK1Columns (HIdentity (DB a)) = a
365+ toK1Columns = HIdentity . DB
366+ {-# INLINABLE fromK1Columns #-}
367+ {-# INLINABLE toK1Columns #-}
368+
369+
370+instance
371+ ( x ~ Field DB (label ': labels) necessity db a
372+ ) => K1Table _label 'True DB 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x
373+ where
374+ fromK1Columns (HIdentity (DB a)) = a
375+ toK1Columns = HIdentity . DB
376+ {-# INLINABLE fromK1Columns #-}
377+ {-# INLINABLE toK1Columns #-}
378+
379+
380+instance
381+ ( x ~ Field Insertion '[] necessity db a
382+ , KnownNecessity necessity
383+ ) => K1Table label 'True Insertion 'True (Shape1 'Column ('Spec '[] necessity db a)) x
384+ where
385+ fromK1Columns (HIdentity insert) = case insert of
386+ RequiredInsert a -> a
387+ OptionalInsert ma -> ma
388+ toK1Columns a = HIdentity $ case necessitySing @necessity of
389+ SRequired -> RequiredInsert a
390+ SOptional -> OptionalInsert a
391+ {-# INLINABLE fromK1Columns #-}
392+ {-# INLINABLE toK1Columns #-}
393+
394+
395+instance
396+ ( x ~ Field Insertion (label ': labels) necessity db a
397+ , KnownNecessity necessity
398+ ) => K1Table _label 'True Insertion 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x
399+ where
400+ fromK1Columns (HIdentity insert) = case insert of
401+ RequiredInsert a -> a
402+ OptionalInsert ma -> ma
403+ toK1Columns a = HIdentity $ case necessitySing @necessity of
404+ SRequired -> RequiredInsert a
405+ SOptional -> OptionalInsert a
406+ {-# INLINABLE fromK1Columns #-}
407+ {-# INLINABLE toK1Columns #-}
408+
409+
410+instance
411+ ( x ~ Field Result '[] necessity db a
412+ ) => K1Table label 'True Result 'True (Shape1 'Column ('Spec '[] necessity db a)) x
413+ where
414+ fromK1Columns (HIdentity (Result a)) = a
415+ toK1Columns = HIdentity . Result
416+ {-# INLINABLE fromK1Columns #-}
417+ {-# INLINABLE toK1Columns #-}
418+
419+
420+instance
421+ ( x ~ Field Result (label ': labels) necessity db a
422+ ) => K1Table _label 'True Result 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x
423+ where
424+ fromK1Columns (HIdentity (Result a)) = a
425+ toK1Columns = HIdentity . Result
426+ {-# INLINABLE fromK1Columns #-}
427+ {-# INLINABLE toK1Columns #-}
428+
429+
430+instance
431+ ( IsSpecialContext context ~ 'False
432+ , x ~ context ('Spec (label ': labels) necessity db a)
433+ ) => K1Table _label 'False context 'True (Shape1 'Column ('Spec (label ': labels) necessity db a)) x
434+ where
435+ fromK1Columns = unHIdentity
436+ toK1Columns = HIdentity
437+ {-# INLINABLE fromK1Columns #-}
438+ {-# INLINABLE toK1Columns #-}
439+
440+
441+instance
442+ ( IsSpecialContext context ~ 'False
443+ , x ~ context ('Spec '[] necessity db a)
444+ , Labelable context
445+ ) => K1Table label 'False context 'True (Shape1 'Column ('Spec '[] necessity db a)) x
446+ where
447+ fromK1Columns = unlabeler . unHIdentity
448+ toK1Columns = HIdentity . labeler
449+ {-# INLINABLE fromK1Columns #-}
450+ {-# INLINABLE toK1Columns #-}
451+
452+
453+instance
454+ ( HTable (K1Columns "Left" structure1)
455+ , HTable (K1Columns "Right" structure2)
456+ , K1Table "Left" 'True Aggregation (IsStructure structure1) structure1 a
457+ , K1Table "Right" 'True Aggregation (IsStructure structure2) structure2 b
458+ , e ~ EitherTable a b
459+ ) => K1Table label 'True Aggregation 'True (Shape2 'Either structure1 structure2) e
460+ where
461+ fromK1Columns =
462+ fromColumns2
463+ (fromK1Columns @"Left" @_ @_ @_ @structure1)
464+ (fromK1Columns @"Right" @_ @_ @_ @structure2) .
465+ hunlabel unlabeler
466+ toK1Columns =
467+ hlabel labeler .
468+ toColumns2
469+ (toK1Columns @"Left" @_ @_ @_ @structure1)
470+ (toK1Columns @"Right" @_ @_ @_ @structure2)
471+ {-# INLINABLE fromK1Columns #-}
472+ {-# INLINABLE toK1Columns #-}
473+
474+
475+instance
476+ ( HTable (K1Columns "Left" structure1)
477+ , HTable (K1Columns "Right" structure2)
478+ , K1Table "Left" 'True DB (IsStructure structure1) structure1 a
479+ , K1Table "Right" 'True DB (IsStructure structure2) structure2 b
480+ , e ~ EitherTable a b
481+ ) => K1Table label 'True DB 'True (Shape2 'Either structure1 structure2) e
482+ where
483+ fromK1Columns =
484+ fromColumns2
485+ (fromK1Columns @"Left" @_ @_ @_ @structure1)
486+ (fromK1Columns @"Right" @_ @_ @_ @structure2) .
487+ hunlabel unlabeler
488+ toK1Columns =
489+ hlabel labeler .
490+ toColumns2
491+ (toK1Columns @"Left" @_ @_ @_ @structure1)
492+ (toK1Columns @"Right" @_ @_ @_ @structure2)
493+ {-# INLINABLE fromK1Columns #-}
494+ {-# INLINABLE toK1Columns #-}
495+
496+
497+instance
498+ ( HTable (K1Columns "Left" structure1)
499+ , HTable (K1Columns "Right" structure2)
500+ , K1Table "Left" 'True Insertion (IsStructure structure1) structure1 a
501+ , K1Table "Right" 'True Insertion (IsStructure structure2) structure2 b
502+ , e ~ EitherTable a b
503+ ) => K1Table label 'True Insertion 'True (Shape2 'Either structure1 structure2) e
504+ where
505+ fromK1Columns =
506+ fromColumns2
507+ (fromK1Columns @"Left" @_ @_ @_ @structure1)
508+ (fromK1Columns @"Right" @_ @_ @_ @structure2) .
509+ hunlabel unlabeler
510+ toK1Columns =
511+ hlabel labeler .
512+ toColumns2
513+ (toK1Columns @"Left" @_ @_ @_ @structure1)
514+ (toK1Columns @"Right" @_ @_ @_ @structure2)
515+ {-# INLINABLE fromK1Columns #-}
516+ {-# INLINABLE toK1Columns #-}
517+
518+
519+instance
520+ ( HTable (K1Columns "Left" structure1)
521+ , HTable (K1Columns "Right" structure2)
522+ , K1Table "Left" 'True Result (IsStructure structure1) structure1 a
523+ , K1Table "Right" 'True Result (IsStructure structure2) structure2 b
524+ , e ~ Either a b
525+ ) => K1Table label 'True Result 'True (Shape2 'Either structure1 structure2) e
526+ where
527+ fromK1Columns
528+ = bimap
529+ (fromK1Columns @"Left" @_ @_ @_ @structure1)
530+ (fromK1Columns @"Right" @_ @_ @_ @structure2)
531+ . fromHEitherTable
532+ . hunlabel unlabeler
533+ toK1Columns
534+ = hlabel labeler
535+ . toHEitherTable
536+ . bimap
537+ (toK1Columns @"Left" @_ @_ @_ @structure1)
538+ (toK1Columns @"Right" @_ @_ @_ @structure2)
539+ {-# INLINABLE fromK1Columns #-}
540+ {-# INLINABLE toK1Columns #-}
541+
542+
543+instance
544+ ( HTable (K1Columns "Left" structure1)
545+ , HTable (K1Columns "Right" structure2)
546+ , K1Table "Left" 'False context (IsStructure structure1) structure1 a
547+ , K1Table "Right" 'False context (IsStructure structure2) structure2 b
548+ , IsSpecialContext context ~ 'False
549+ , Labelable context
550+ , Nullifiable context
551+ , e ~ EitherTable a b
552+ ) => K1Table label 'False context 'True (Shape2 'Either structure1 structure2) e
553+ where
554+ fromK1Columns =
555+ fromColumns2
556+ (fromK1Columns @"Left" @_ @_ @_ @structure1)
557+ (fromK1Columns @"Right" @_ @_ @_ @structure2) .
558+ hunlabel unlabeler
559+ toK1Columns =
560+ hlabel labeler .
561+ toColumns2
562+ (toK1Columns @"Left" @_ @_ @_ @structure1)
563+ (toK1Columns @"Right" @_ @_ @_ @structure2)
564+ {-# INLINABLE fromK1Columns #-}
565+ {-# INLINABLE toK1Columns #-}
566+
567+
568+instance
569+ ( K1Table label 'True Aggregation (IsStructure structure) structure a
570+ , Table Aggregation a
571+ , K1Columns label structure ~ HLabel label (Columns a)
572+ , as ~ ListTable a
573+ ) => K1Table label 'True Aggregation 'True (Shape1 'List structure) as
574+ where
575+ fromK1Columns = fromColumns . hrelabel (hunlabel unlabeler)
576+ toK1Columns = hrelabel (hlabel labeler) . toColumns
577+ {-# INLINABLE fromK1Columns #-}
578+ {-# INLINABLE toK1Columns #-}
579+
580+
581+instance
582+ ( K1Table label 'True DB (IsStructure structure) structure a
583+ , Table DB a
584+ , K1Columns label structure ~ HLabel label (Columns a)
585+ , as ~ ListTable a
586+ ) => K1Table label 'True DB 'True (Shape1 'List structure) as
587+ where
588+ fromK1Columns = fromColumns . hrelabel (hunlabel unlabeler)
589+ toK1Columns = hrelabel (hlabel labeler) . toColumns
590+ {-# INLINABLE fromK1Columns #-}
591+ {-# INLINABLE toK1Columns #-}
592+
593+
594+instance
595+ ( K1Table label 'True Insertion (IsStructure structure) structure a
596+ , Table Insertion a
597+ , K1Columns label structure ~ HLabel label (Columns a)
598+ , as ~ ListTable a
599+ ) => K1Table label 'True Insertion 'True (Shape1 'List structure) as
600+ where
601+ fromK1Columns = fromColumns . hrelabel (hunlabel unlabeler)
602+ toK1Columns = hrelabel (hlabel labeler) . toColumns
603+ {-# INLINABLE fromK1Columns #-}
604+ {-# INLINABLE toK1Columns #-}
605+
606+
607+instance
608+ ( K1Table label 'True Result (IsStructure structure) structure a
609+ , HTable (K1Columns label structure)
610+ , as ~ [a]
611+ ) => K1Table label 'True Result 'True (Shape1 'List structure) as
612+ where
613+ fromK1Columns = fmap (fromK1Columns @label @'True @Result @_ @structure) . fromHListTable
614+ toK1Columns = toHListTable . fmap (toK1Columns @label @'True @Result @_ @structure)
615+ {-# INLINABLE fromK1Columns #-}
616+ {-# INLINABLE toK1Columns #-}
617+
618+
619+instance
620+ ( K1Table label 'False context (IsStructure structure) structure a
621+ , IsSpecialContext context ~ 'False
622+ , Table context a
623+ , K1Columns label structure ~ HLabel label (Columns a)
624+ , Labelable context
625+ , as ~ ListTable a
626+ ) => K1Table label 'False context 'True (Shape1 'List structure) as
627+ where
628+ fromK1Columns = fromColumns . hrelabel (hunlabel unlabeler)
629+ toK1Columns = hrelabel (hlabel labeler) . toColumns
630+ {-# INLINABLE fromK1Columns #-}
631+ {-# INLINABLE toK1Columns #-}
632+
633+
634+instance
635+ ( HTable (K1Columns "Just" structure)
636+ , K1Table "Just" 'True Aggregation (IsStructure structure) structure a
637+ , ma ~ MaybeTable a
638+ ) => K1Table label 'True Aggregation 'True (Shape1 'Maybe structure) ma
639+ where
640+ fromK1Columns =
641+ fromColumns1 (fromK1Columns @"Just" @_ @_ @_ @structure) .
642+ hunlabel unlabeler
643+ toK1Columns =
644+ hlabel labeler .
645+ toColumns1 (toK1Columns @"Just" @_ @_ @_ @structure)
646+ {-# INLINABLE fromK1Columns #-}
647+ {-# INLINABLE toK1Columns #-}
648+
649+
650+instance
651+ ( HTable (K1Columns "Just" structure)
652+ , K1Table "Just" 'True DB (IsStructure structure) structure a
653+ , ma ~ MaybeTable a
654+ ) => K1Table label 'True DB 'True (Shape1 'Maybe structure) ma
655+ where
656+ fromK1Columns =
657+ fromColumns1 (fromK1Columns @"Just" @_ @_ @_ @structure) .
658+ hunlabel unlabeler
659+ toK1Columns =
660+ hlabel labeler .
661+ toColumns1 (toK1Columns @"Just" @_ @_ @_ @structure)
662+ {-# INLINABLE fromK1Columns #-}
663+ {-# INLINABLE toK1Columns #-}
664+
665+
666+instance
667+ ( HTable (K1Columns "Just" structure)
668+ , K1Table "Just" 'True Insertion (IsStructure structure) structure a
669+ , ma ~ MaybeTable a
670+ ) => K1Table label 'True Insertion 'True (Shape1 'Maybe structure) ma
671+ where
672+ fromK1Columns =
673+ fromColumns1 (fromK1Columns @"Just" @_ @_ @_ @structure) .
674+ hunlabel unlabeler
675+ toK1Columns =
676+ hlabel labeler .
677+ toColumns1 (toK1Columns @"Just" @_ @_ @_ @structure)
678+ {-# INLINABLE fromK1Columns #-}
679+ {-# INLINABLE toK1Columns #-}
680+
681+
682+instance
683+ ( HTable (K1Columns "Just" structure)
684+ , K1Table "Just" 'True Result (IsStructure structure) structure a
685+ , ma ~ Maybe a
686+ ) => K1Table label 'True Result 'True (Shape1 'Maybe structure) ma
687+ where
688+ fromK1Columns
689+ = fmap (fromK1Columns @"Just" @_ @_ @_ @structure)
690+ . fromHMaybeTable
691+ . hunlabel unlabeler
692+ toK1Columns
693+ = hlabel labeler
694+ . toHMaybeTable
695+ . fmap (toK1Columns @"Just" @_ @_ @_ @structure)
696+ {-# INLINABLE fromK1Columns #-}
697+ {-# INLINABLE toK1Columns #-}
698+
699+
700+instance
701+ ( HTable (K1Columns "Just" structure)
702+ , K1Table "Just" 'False context (IsStructure structure) structure a
703+ , IsSpecialContext context ~ 'False
704+ , Labelable context
705+ , Nullifiable context
706+ , ma ~ MaybeTable a
707+ ) => K1Table label 'False context 'True (Shape1 'Maybe structure) ma
708+ where
709+ fromK1Columns =
710+ fromColumns1 (fromK1Columns @"Just" @_ @_ @_ @structure) .
711+ hunlabel unlabeler
712+ toK1Columns =
713+ hlabel labeler .
714+ toColumns1 (toK1Columns @"Just" @_ @_ @_ @structure)
715+ {-# INLINABLE fromK1Columns #-}
716+ {-# INLINABLE toK1Columns #-}
717+
718+
719+instance
720+ ( K1Table label 'True Aggregation (IsStructure structure) structure a
721+ , Table Aggregation a
722+ , K1Columns label structure ~ HLabel label (Columns a)
723+ , as ~ NonEmptyTable a
724+ ) => K1Table label 'True Aggregation 'True (Shape1 'NonEmpty structure) as
725+ where
726+ fromK1Columns = fromColumns . hrelabel (hunlabel unlabeler)
727+ toK1Columns = hrelabel (hlabel labeler) . toColumns
728+ {-# INLINABLE fromK1Columns #-}
729+ {-# INLINABLE toK1Columns #-}
730+
731+
732+instance
733+ ( K1Table label 'True DB (IsStructure structure) structure a
734+ , Table DB a
735+ , K1Columns label structure ~ HLabel label (Columns a)
736+ , as ~ NonEmptyTable a
737+ ) => K1Table label 'True DB 'True (Shape1 'NonEmpty structure) as
738+ where
739+ fromK1Columns = fromColumns . hrelabel (hunlabel unlabeler)
740+ toK1Columns = hrelabel (hlabel labeler) . toColumns
741+ {-# INLINABLE fromK1Columns #-}
742+ {-# INLINABLE toK1Columns #-}
743+
744+
745+instance
746+ ( K1Table label 'True Insertion (IsStructure structure) structure a
747+ , Table Insertion a
748+ , K1Columns label structure ~ HLabel label (Columns a)
749+ , as ~ NonEmptyTable a
750+ ) => K1Table label 'True Insertion 'True (Shape1 'NonEmpty structure) as
751+ where
752+ fromK1Columns = fromColumns . hrelabel (hunlabel unlabeler)
753+ toK1Columns = hrelabel (hlabel labeler) . toColumns
754+ {-# INLINABLE fromK1Columns #-}
755+ {-# INLINABLE toK1Columns #-}
756+
757+
758+instance
759+ ( K1Table label 'True Result (IsStructure structure) structure a
760+ , HTable (K1Columns label structure)
761+ , as ~ NonEmpty a
762+ ) => K1Table label 'True Result 'True (Shape1 'NonEmpty structure) as
763+ where
764+ fromK1Columns = fmap (fromK1Columns @label @'True @Result @_ @structure) . fromHNonEmptyTable
765+ toK1Columns = toHNonEmptyTable . fmap (toK1Columns @label @'True @Result @_ @structure)
766+ {-# INLINABLE fromK1Columns #-}
767+ {-# INLINABLE toK1Columns #-}
768+
769+
770+instance
771+ ( K1Table label 'False context (IsStructure structure) structure a
772+ , IsSpecialContext context ~ 'False
773+ , Table context a
774+ , K1Columns label structure ~ HLabel label (Columns a)
775+ , Labelable context
776+ , as ~ NonEmptyTable a
777+ ) => K1Table label 'False context 'True (Shape1 'NonEmpty structure) as
778+ where
779+ fromK1Columns = fromColumns . hrelabel (hunlabel unlabeler)
780+ toK1Columns = hrelabel (hlabel labeler) . toColumns
781+ {-# INLINABLE fromK1Columns #-}
782+ {-# INLINABLE toK1Columns #-}
783+
784+
785+instance
786+ ( HTable (K1Columns "Here" structure1)
787+ , HTable (K1Columns "There" structure2)
788+ , K1Table "Here" 'True Aggregation (IsStructure structure1) structure1 a
789+ , K1Table "There" 'True Aggregation (IsStructure structure2) structure2 b
790+ , e ~ TheseTable a b
791+ ) => K1Table label 'True Aggregation 'True (Shape2 'These structure1 structure2) e
792+ where
793+ fromK1Columns =
794+ fromColumns2
795+ (fromK1Columns @"Here" @_ @_ @_ @structure1)
796+ (fromK1Columns @"There" @_ @_ @_ @structure2) .
797+ hunlabel unlabeler
798+ toK1Columns =
799+ hlabel labeler .
800+ toColumns2
801+ (toK1Columns @"Here" @_ @_ @_ @structure1)
802+ (toK1Columns @"There" @_ @_ @_ @structure2)
803+ {-# INLINABLE fromK1Columns #-}
804+ {-# INLINABLE toK1Columns #-}
805+
806+
807+instance
808+ ( HTable (K1Columns "Here" structure1)
809+ , HTable (K1Columns "There" structure2)
810+ , K1Table "Here" 'True DB (IsStructure structure1) structure1 a
811+ , K1Table "There" 'True DB (IsStructure structure2) structure2 b
812+ , e ~ TheseTable a b
813+ ) => K1Table label 'True DB 'True (Shape2 'These structure1 structure2) e
814+ where
815+ fromK1Columns =
816+ fromColumns2
817+ (fromK1Columns @"Here" @_ @_ @_ @structure1)
818+ (fromK1Columns @"There" @_ @_ @_ @structure2) .
819+ hunlabel unlabeler
820+ toK1Columns =
821+ hlabel labeler .
822+ toColumns2
823+ (toK1Columns @"Here" @_ @_ @_ @structure1)
824+ (toK1Columns @"There" @_ @_ @_ @structure2)
825+ {-# INLINABLE fromK1Columns #-}
826+ {-# INLINABLE toK1Columns #-}
827+
828+
829+instance
830+ ( HTable (K1Columns "Here" structure1)
831+ , HTable (K1Columns "There" structure2)
832+ , K1Table "Here" 'True Insertion (IsStructure structure1) structure1 a
833+ , K1Table "There" 'True Insertion (IsStructure structure2) structure2 b
834+ , e ~ TheseTable a b
835+ ) => K1Table label 'True Insertion 'True (Shape2 'These structure1 structure2) e
836+ where
837+ fromK1Columns =
838+ fromColumns2
839+ (fromK1Columns @"Here" @_ @_ @_ @structure1)
840+ (fromK1Columns @"There" @_ @_ @_ @structure2) .
841+ hunlabel unlabeler
842+ toK1Columns =
843+ hlabel labeler .
844+ toColumns2
845+ (toK1Columns @"Here" @_ @_ @_ @structure1)
846+ (toK1Columns @"There" @_ @_ @_ @structure2)
847+ {-# INLINABLE fromK1Columns #-}
848+ {-# INLINABLE toK1Columns #-}
849+
850+
851+instance
852+ ( HTable (K1Columns "Here" structure1)
853+ , HTable (K1Columns "There" structure2)
854+ , K1Table "Here" 'True Result (IsStructure structure1) structure1 a
855+ , K1Table "There" 'True Result (IsStructure structure2) structure2 b
856+ , e ~ These a b
857+ ) => K1Table label 'True Result 'True (Shape2 'These structure1 structure2) e
858+ where
859+ fromK1Columns
860+ = bimap
861+ (fromK1Columns @"Here" @_ @_ @_ @structure1)
862+ (fromK1Columns @"There" @_ @_ @_ @structure2)
863+ . fromHTheseTable
864+ . hunlabel unlabeler
865+ toK1Columns
866+ = hlabel labeler
867+ . toHTheseTable
868+ . bimap
869+ (toK1Columns @"Here" @_ @_ @_ @structure1)
870+ (toK1Columns @"There" @_ @_ @_ @structure2)
871+ {-# INLINABLE fromK1Columns #-}
872+ {-# INLINABLE toK1Columns #-}
873+
874+
875+instance
876+ ( HTable (K1Columns "Here" structure1)
877+ , HTable (K1Columns "There" structure2)
878+ , K1Table "Here" 'False context (IsStructure structure1) structure1 a
879+ , K1Table "There" 'False context (IsStructure structure2) structure2 b
880+ , IsSpecialContext context ~ 'False
881+ , Labelable context
882+ , Nullifiable context
883+ , e ~ TheseTable a b
884+ ) => K1Table label 'False context 'True (Shape2 'These structure1 structure2) e
885+ where
886+ fromK1Columns =
887+ fromColumns2
888+ (fromK1Columns @"Here" @_ @_ @_ @structure1)
889+ (fromK1Columns @"There" @_ @_ @_ @structure2) .
890+ hunlabel unlabeler
891+ toK1Columns =
892+ hlabel labeler .
893+ toColumns2
894+ (toK1Columns @"Here" @_ @_ @_ @structure1)
895+ (toK1Columns @"There" @_ @_ @_ @structure2)
896+ {-# INLINABLE fromK1Columns #-}
897+ {-# INLINABLE toK1Columns #-}
898+
899+
900+
901+instance
902+ ( K1Table "fst" isSpecialContext context (IsStructure structure1) structure1 a1
903+ , K1Table "snd" isSpecialContext context (IsStructure structure2) structure2 a2
904+ , HTable (K1Columns "fst" structure1)
905+ , HTable (K1Columns "snd" structure2)
906+ , Labelable context
907+ , a ~ (a1, a2)
908+ ) => K1Table label isSpecialContext context 'True (structure1, structure2) a
909+ where
910+ fromK1Columns (hunlabel unlabeler -> (HPair a b)) =
911+ ( fromK1Columns @"fst" @_ @_ @_ @structure1 a
912+ , fromK1Columns @"snd" @_ @_ @_ @structure2 b
913+ )
914+ toK1Columns (a, b) = hlabel labeler $ HPair
915+ { hfst = toK1Columns @"fst" @_ @_ @_ @structure1 a
916+ , hsnd = toK1Columns @"snd" @_ @_ @_ @structure2 b
917+ }
918+ {-# INLINABLE fromK1Columns #-}
919+ {-# INLINABLE toK1Columns #-}
920+
921+
922+instance
923+ ( K1Table "fst" isSpecialContext context (IsStructure structure1) structure1 a1
924+ , K1Table "snd" isSpecialContext context (IsStructure structure2) structure2 a2
925+ , K1Table "trd" isSpecialContext context (IsStructure structure3) structure3 a3
926+ , HTable (K1Columns "fst" structure1)
927+ , HTable (K1Columns "snd" structure2)
928+ , HTable (K1Columns "trd" structure3)
929+ , Labelable context
930+ , a ~ (a1, a2, a3)
931+ ) => K1Table label isSpecialContext context 'True (structure1, structure2, structure3) a
932+ where
933+ fromK1Columns (hunlabel unlabeler -> (HTrio a b c)) =
934+ ( fromK1Columns @"fst" @_ @_ @_ @structure1 a
935+ , fromK1Columns @"snd" @_ @_ @_ @structure2 b
936+ , fromK1Columns @"trd" @_ @_ @_ @structure3 c
937+ )
938+ toK1Columns (a, b, c) = hlabel labeler $ HTrio
939+ { hfst = toK1Columns @"fst" @_ @_ @_ @structure1 a
940+ , hsnd = toK1Columns @"snd" @_ @_ @_ @structure2 b
941+ , htrd = toK1Columns @"trd" @_ @_ @_ @structure3 c
942+ }
943+ {-# INLINABLE fromK1Columns #-}
944+ {-# INLINABLE toK1Columns #-}
945+
946+
947+instance
948+ ( K1Table "fst" isSpecialContext context (IsStructure structure1) structure1 a1
949+ , K1Table "snd" isSpecialContext context (IsStructure structure2) structure2 a2
950+ , K1Table "trd" isSpecialContext context (IsStructure structure3) structure3 a3
951+ , K1Table "frt" isSpecialContext context (IsStructure structure3) structure4 a4
952+ , HTable (K1Columns "fst" structure1)
953+ , HTable (K1Columns "snd" structure2)
954+ , HTable (K1Columns "trd" structure3)
955+ , HTable (K1Columns "frt" structure4)
956+ , Labelable context
957+ , a ~ (a1, a2, a3, a4)
958+ ) => K1Table label isSpecialContext context 'True (structure1, structure2, structure3, structure4) a
959+ where
960+ fromK1Columns (hunlabel unlabeler -> (HQuartet a b c d)) =
961+ ( fromK1Columns @"fst" @_ @_ @_ @structure1 a
962+ , fromK1Columns @"snd" @_ @_ @_ @structure2 b
963+ , fromK1Columns @"trd" @_ @_ @_ @structure3 c
964+ , fromK1Columns @"frt" @_ @_ @_ @structure4 d
965+ )
966+ toK1Columns (a, b, c, d) = hlabel labeler $ HQuartet
967+ { hfst = toK1Columns @"fst" @_ @_ @_ @structure1 a
968+ , hsnd = toK1Columns @"snd" @_ @_ @_ @structure2 b
969+ , htrd = toK1Columns @"trd" @_ @_ @_ @structure3 c
970+ , hfrt = toK1Columns @"frt" @_ @_ @_ @structure4 d
971+ }
972+ {-# INLINABLE fromK1Columns #-}
973+ {-# INLINABLE toK1Columns #-}
974+
975+
976+instance
977+ ( K1Table "fst" isSpecialContext context (IsStructure structure1) structure1 a1
978+ , K1Table "snd" isSpecialContext context (IsStructure structure2) structure2 a2
979+ , K1Table "trd" isSpecialContext context (IsStructure structure3) structure3 a3
980+ , K1Table "frt" isSpecialContext context (IsStructure structure3) structure4 a4
981+ , K1Table "fft" isSpecialContext context (IsStructure structure3) structure5 a5
982+ , HTable (K1Columns "fst" structure1)
983+ , HTable (K1Columns "snd" structure2)
984+ , HTable (K1Columns "trd" structure3)
985+ , HTable (K1Columns "frt" structure4)
986+ , HTable (K1Columns "fft" structure5)
987+ , Labelable context
988+ , a ~ (a1, a2, a3, a4, a5)
989+ ) => K1Table label isSpecialContext context 'True (structure1, structure2, structure3, structure4, structure5) a
990+ where
991+ fromK1Columns (hunlabel unlabeler -> (HQuintet a b c d e)) =
992+ ( fromK1Columns @"fst" @_ @_ @_ @structure1 a
993+ , fromK1Columns @"snd" @_ @_ @_ @structure2 b
994+ , fromK1Columns @"trd" @_ @_ @_ @structure3 c
995+ , fromK1Columns @"frt" @_ @_ @_ @structure4 d
996+ , fromK1Columns @"fft" @_ @_ @_ @structure5 e
997+ )
998+ toK1Columns (a, b, c, d, e) = hlabel labeler $ HQuintet
999+ { hfst = toK1Columns @"fst" @_ @_ @_ @structure1 a
1000+ , hsnd = toK1Columns @"snd" @_ @_ @_ @structure2 b
1001+ , htrd = toK1Columns @"trd" @_ @_ @_ @structure3 c
1002+ , hfrt = toK1Columns @"frt" @_ @_ @_ @structure4 d
1003+ , hfft = toK1Columns @"fft" @_ @_ @_ @structure5 e
1004+ }
1005+ {-# INLINABLE fromK1Columns #-}
1006+ {-# INLINABLE toK1Columns #-}
1007+
1008+
1009+instance
1010+ ( IsSpecialContext context ~ isSpecialContext
1011+ , IsStructure structure ~ 'False
1012+ , K1Columns label structure ~ HLabel label (Columns structure)
1013+ , Columns structure ~ Columns a
1014+ , Labelable context
1015+ , Table context a
1016+ ) => K1Table label isSpecialContext context 'False structure a
1017+ where
1018+ fromK1Columns = fromColumns . hunlabel unlabeler
1019+ toK1Columns = hlabel labeler . toColumns
1020+ {-# INLINABLE fromK1Columns #-}
1021+ {-# INLINABLE toK1Columns #-}
src/Rel8/Schema/Generic/Test.hsnew file+79
@@ -0,0 +1,79 @@
1+{-# language DataKinds #-}
2+{-# language DeriveAnyClass #-}
3+{-# language DeriveGeneric #-}
4+{-# language DerivingStrategies #-}
5+{-# language DuplicateRecordFields #-}
6+
7+{-# options_ghc -O0 #-}
8+
9+module Rel8.Schema.Generic.Test
10+ ( module Rel8.Schema.Generic.Test
11+ )
12+where
13+
14+-- base
15+import GHC.Generics ( Generic )
16+import Prelude
17+
18+-- rel8
19+import Rel8.Schema.Column
20+import Rel8.Schema.Generic
21+
22+-- text
23+import Data.Text ( Text )
24+
25+
26+data Table f = Table
27+ { foo :: Column f (Label "blah" Bool)
28+ , bar :: Column f (Maybe Bool)
29+ }
30+ deriving stock Generic
31+ deriving anyclass Rel8able
32+
33+
34+data TablePair f = TablePair
35+ { foo :: Column f (Default Bool)
36+ , bars :: (Column f Text, Column f Text)
37+ }
38+ deriving stock Generic
39+ deriving anyclass Rel8able
40+
41+
42+data TableMaybe f = TableMaybe
43+ { foo :: Column f (Label "ABC" [Maybe Bool])
44+ , bars :: HMaybe f (TablePair f, TablePair f)
45+ }
46+ deriving stock Generic
47+ deriving anyclass Rel8able
48+
49+
50+data TableEither f = TableEither
51+ { foo :: Column f Bool
52+ , bars :: HEither f (HMaybe f (TablePair f, TablePair f)) (Column f (Label "XYZ" Char))
53+ }
54+ deriving stock Generic
55+ deriving anyclass Rel8able
56+
57+
58+data TableThese f = TableThese
59+ { foo :: Column f Bool
60+ , bars :: HThese f (TableMaybe f) (TableEither f)
61+ }
62+ deriving stock Generic
63+ deriving anyclass Rel8able
64+
65+
66+data TableList f = TableList
67+ { foo :: Column f Bool
68+ , bars :: HList f (TableThese f)
69+ }
70+ deriving stock Generic
71+ deriving anyclass Rel8able
72+
73+
74+data TableNonEmpty f = TableNonEmpty
75+ { foo :: Column f Bool
76+ , bars :: HNonEmpty f (TableList f)
77+ }
78+ deriving stock Generic
79+ deriving anyclass Rel8able
src/Rel8/Schema/HTable.hsnew file+173
@@ -0,0 +1,173 @@
1+{-# language AllowAmbiguousTypes #-}
2+{-# language DataKinds #-}
3+{-# language DefaultSignatures #-}
4+{-# language FlexibleContexts #-}
5+{-# language FlexibleInstances #-}
6+{-# language FunctionalDependencies #-}
7+{-# language LambdaCase #-}
8+{-# language RankNTypes #-}
9+{-# language ScopedTypeVariables #-}
10+{-# language StandaloneKindSignatures #-}
11+{-# language TypeApplications #-}
12+{-# language TypeFamilyDependencies #-}
13+{-# language TypeOperators #-}
14+{-# language UndecidableInstances #-}
15+
16+module Rel8.Schema.HTable
17+ ( HTable (HField, HConstrainTable)
18+ , hfield, htabulate, htraverse, hdicts, hspecs
19+ , htabulateA
20+
21+ , HPair(..)
22+ )
23+where
24+
25+-- base
26+import Data.Kind ( Constraint, Type )
27+import Data.Functor.Compose ( Compose( Compose ), getCompose )
28+import Data.Proxy ( Proxy )
29+import GHC.Generics
30+ ( (:*:)( (:*:) )
31+ , Generic (Rep, from, to)
32+ , K1( K1 )
33+ , M1( M1 )
34+ )
35+import Prelude
36+
37+-- rel8
38+import Rel8.Schema.Dict ( Dict )
39+import Rel8.Schema.Spec ( Spec, SSpec, Context )
40+import Rel8.Schema.HTable.Context ( HKTable, H )
41+import Rel8.Schema.HTable.Pair ( HPair( HPair ) )
42+
43+-- semigroupoids
44+import Data.Functor.Apply ( Apply, (<.>) )
45+
46+
47+type HTable :: HKTable -> Constraint
48+class HTable t where
49+ type HField t = (field :: Context) | field -> t
50+ type HConstrainTable t (c :: Spec -> Constraint) :: Constraint
51+
52+ hfield :: t (H context) -> HField t spec -> context spec
53+ htabulate :: (forall spec. HField t spec -> context spec) -> t (H context)
54+ htraverse :: Apply m => (forall spec. f spec -> m (g spec)) -> t (H f) -> m (t (H g))
55+ hdicts :: HConstrainTable t c => t (H (Dict c))
56+ hspecs :: t (H SSpec)
57+
58+ type HField t = GHField t
59+ type HConstrainTable t c = HConstrainTable (GHColumns (Rep (t (H Proxy)))) c
60+
61+ default hfield ::
62+ ( Generic (t (H context))
63+ , HField t ~ GHField t
64+ , HField (GHColumns (Rep (t (H Proxy)))) ~ HField (GHColumns (Rep (t (H context))))
65+ , GHTable context (Rep (t (H context)))
66+ )
67+ => t (H context) -> HField t spec -> context spec
68+ hfield table (GHField field) = hfield (toGHColumns (from table)) field
69+
70+ default htabulate ::
71+ ( Generic (t (H context))
72+ , HField t ~ GHField t
73+ , HField (GHColumns (Rep (t (H Proxy)))) ~ HField (GHColumns (Rep (t (H context))))
74+ , GHTable context (Rep (t (H context)))
75+ )
76+ => (forall spec. HField t spec -> context spec) -> t (H context)
77+ htabulate f = to $ fromGHColumns $ htabulate (f . GHField)
78+
79+ default htraverse
80+ :: forall f g m
81+ . ( Apply m
82+ , Generic (t (H f)), GHTable f (Rep (t (H f)))
83+ , Generic (t (H g)), GHTable g (Rep (t (H g)))
84+ , GHColumns (Rep (t (H f))) ~ GHColumns (Rep (t (H g)))
85+ )
86+ => (forall spec. f spec -> m (g spec)) -> t (H f) -> m (t (H g))
87+ htraverse f = fmap (to . fromGHColumns) . htraverse f . toGHColumns . from
88+
89+ default hdicts
90+ :: forall c
91+ . ( Generic (t (H (Dict c)))
92+ , GHTable (Dict c) (Rep (t (H (Dict c))))
93+ , GHColumns (Rep (t (H Proxy))) ~ GHColumns (Rep (t (H (Dict c))))
94+ , HConstrainTable (GHColumns (Rep (t (H Proxy)))) c
95+ )
96+ => t (H (Dict c))
97+ hdicts = to $ fromGHColumns (hdicts @(GHColumns (Rep (t (H Proxy)))) @c)
98+
99+ default hspecs ::
100+ ( Generic (t (H SSpec))
101+ , GHTable SSpec (Rep (t (H SSpec)))
102+ )
103+ => t (H SSpec)
104+ hspecs = to $ fromGHColumns hspecs
105+
106+ {-# INLINABLE hfield #-}
107+ {-# INLINABLE htabulate #-}
108+ {-# INLINABLE htraverse #-}
109+ {-# INLINABLE hdicts #-}
110+ {-# INLINABLE hspecs #-}
111+
112+
113+htabulateA :: (HTable t, Apply m)
114+ => (forall spec. HField t spec -> m (context spec))
115+ -> m (t (H context))
116+htabulateA f = htraverse getCompose $ htabulate $ Compose . f
117+{-# INLINABLE htabulateA #-}
118+
119+
120+type GHField :: HKTable -> Context
121+newtype GHField t spec = GHField (HField (GHColumns (Rep (t (H Proxy)))) spec)
122+
123+
124+type GHTable :: Context -> (Type -> Type) -> Constraint
125+class HTable (GHColumns rep) => GHTable context rep | rep -> context where
126+ type GHColumns rep :: HKTable
127+ toGHColumns :: rep x -> GHColumns rep (H context)
128+ fromGHColumns :: GHColumns rep (H context) -> rep x
129+
130+
131+instance GHTable context rep => GHTable context (M1 i c rep) where
132+ type GHColumns (M1 i c rep) = GHColumns rep
133+ toGHColumns (M1 a) = toGHColumns a
134+ fromGHColumns = M1 . fromGHColumns
135+
136+
137+instance HTable table => GHTable context (K1 i (table (H context))) where
138+ type GHColumns (K1 i (table (H context))) = table
139+ toGHColumns (K1 a) = a
140+ fromGHColumns = K1
141+
142+
143+instance (GHTable context a, GHTable context b) => GHTable context (a :*: b) where
144+ type GHColumns (a :*: b) = HPair (GHColumns a) (GHColumns b)
145+ toGHColumns (a :*: b) = HPair (toGHColumns a) (toGHColumns b)
146+ fromGHColumns (HPair a b) = fromGHColumns a :*: fromGHColumns b
147+
148+
149+-- | A HField type for indexing into HPair.
150+type HPairField :: HKTable -> HKTable -> Context
151+data HPairField x y spec
152+ = HFst (HField x spec)
153+ | HSnd (HField y spec)
154+
155+
156+instance (HTable x, HTable y) => HTable (HPair x y) where
157+ type HConstrainTable (HPair x y) c = (HConstrainTable x c, HConstrainTable y c)
158+ type HField (HPair x y) = HPairField x y
159+
160+ hfield (HPair l r) = \case
161+ HFst i -> hfield l i
162+ HSnd i -> hfield r i
163+
164+ htabulate f = HPair (htabulate (f . HFst)) (htabulate (f . HSnd))
165+ htraverse f (HPair x y) = HPair <$> htraverse f x <.> htraverse f y
166+ hdicts = HPair hdicts hdicts
167+ hspecs = HPair hspecs hspecs
168+
169+ {-# INLINABLE hfield #-}
170+ {-# INLINABLE htabulate #-}
171+ {-# INLINABLE htraverse #-}
172+ {-# INLINABLE hdicts #-}
173+ {-# INLINABLE hspecs #-}
src/Rel8/Schema/HTable/Context.hsnew file+26
@@ -0,0 +1,26 @@
1+{-# language DataKinds #-}
2+{-# language StandaloneKindSignatures #-}
3+
4+module Rel8.Schema.HTable.Context
5+ ( HContext, H, HKTable
6+ )
7+where
8+
9+-- base
10+import Data.Kind ( Type )
11+import Prelude ()
12+
13+-- rel8
14+import Rel8.Schema.Spec ( Context )
15+
16+
17+type HContext :: Type
18+newtype HContext = H Context
19+
20+
21+type H :: Context -> HContext
22+type H = 'H
23+
24+
25+type HKTable :: Type
26+type HKTable = HContext -> Type
src/Rel8/Schema/HTable/Either.hsnew file+33
@@ -0,0 +1,33 @@
1+{-# language DataKinds #-}
2+{-# language DeriveAnyClass #-}
3+{-# language DeriveGeneric #-}
4+{-# language DerivingStrategies #-}
5+{-# language StandaloneKindSignatures #-}
6+
7+module Rel8.Schema.HTable.Either
8+ ( HEitherTable(..)
9+ )
10+where
11+
12+-- base
13+import GHC.Generics ( Generic )
14+import Prelude ()
15+
16+-- rel8
17+import Rel8.Kind.Necessity ( Necessity( Required ) )
18+import Rel8.Schema.HTable ( HTable )
19+import Rel8.Schema.HTable.Context ( HKTable )
20+import Rel8.Schema.HTable.Identity ( HIdentity(..) )
21+import Rel8.Schema.HTable.Nullify ( HNullify )
22+import Rel8.Schema.Spec ( Spec( Spec ) )
23+import Rel8.Type.Tag ( EitherTag )
24+
25+
26+type HEitherTable :: HKTable -> HKTable -> HKTable
27+data HEitherTable left right context = HEitherTable
28+ { htag :: HIdentity ('Spec '["isRight"] 'Required EitherTag EitherTag) context
29+ , hleft :: HNullify left context
30+ , hright :: HNullify right context
31+ }
32+ deriving stock Generic
33+ deriving anyclass HTable
src/Rel8/Schema/HTable/Identity.hsnew file+44
@@ -0,0 +1,44 @@
1+{-# language DataKinds #-}
2+{-# language GADTs #-}
3+{-# language StandaloneKindSignatures #-}
4+{-# language TypeFamilies #-}
5+
6+module Rel8.Schema.HTable.Identity
7+ ( HIdentity(..)
8+ )
9+where
10+
11+-- base
12+import Prelude
13+
14+-- rel8
15+import Rel8.Schema.Dict ( Dict( Dict ) )
16+import Rel8.Schema.HTable
17+ ( HTable, HConstrainTable, HField
18+ , hfield, htabulate, htraverse, hdicts, hspecs
19+ )
20+import Rel8.Schema.HTable.Context ( H, HKTable )
21+import Rel8.Schema.Spec ( Context, Spec, KnownSpec, specSing )
22+
23+
24+type HIdentity :: Spec -> HKTable
25+data HIdentity spec context where
26+ HIdentity ::
27+ { unHIdentity :: context spec
28+ } -> HIdentity spec (H context)
29+
30+
31+type HIdentityField :: Spec -> Context
32+data HIdentityField _spec spec where
33+ HIdentityField :: HIdentityField spec spec
34+
35+
36+instance KnownSpec spec => HTable (HIdentity spec) where
37+ type HConstrainTable (HIdentity spec) c = c spec
38+ type HField (HIdentity spec) = HIdentityField spec
39+
40+ hfield (HIdentity a) HIdentityField = a
41+ htabulate f = HIdentity $ f HIdentityField
42+ htraverse f (HIdentity a) = HIdentity <$> f a
43+ hdicts = HIdentity Dict
44+ hspecs = HIdentity specSing
src/Rel8/Schema/HTable/Label.hsnew file+131
@@ -0,0 +1,131 @@
1+{-# language ConstraintKinds #-}
2+{-# language DataKinds #-}
3+{-# language FlexibleInstances #-}
4+{-# language GADTs #-}
5+{-# language InstanceSigs #-}
6+{-# language MultiParamTypeClasses #-}
7+{-# language QuantifiedConstraints #-}
8+{-# language RankNTypes #-}
9+{-# language RecordWildCards #-}
10+{-# language ScopedTypeVariables #-}
11+{-# language StandaloneKindSignatures #-}
12+{-# language TypeApplications #-}
13+{-# language TypeFamilies #-}
14+{-# language TypeOperators #-}
15+{-# language UndecidableInstances #-}
16+
17+module Rel8.Schema.HTable.Label
18+ ( HLabel( HLabel )
19+ , hlabel, hunlabel
20+ )
21+where
22+
23+-- base
24+import Data.Kind ( Constraint, Type )
25+import Data.Proxy ( Proxy( Proxy ) )
26+import GHC.TypeLits ( KnownSymbol, Symbol )
27+import Prelude
28+
29+-- rel8
30+import Rel8.Kind.Labels ( SLabels( SLabels ) )
31+import Rel8.Schema.Dict ( Dict( Dict ) )
32+import Rel8.Schema.HTable
33+ ( HTable, HConstrainTable, HField
34+ , hfield, htabulate, htraverse, hdicts, hspecs
35+ )
36+import Rel8.Schema.HTable.Context ( H, HKTable )
37+import Rel8.Schema.Spec ( Context, Spec( Spec ), SSpec(..) )
38+
39+
40+type HLabel :: Symbol -> HKTable -> HKTable
41+data HLabel label table context where
42+ HLabel :: table (H (LabelSpec label context)) -> HLabel label table (H context)
43+
44+
45+type HLabelField :: Symbol -> HKTable -> Context
46+data HLabelField label table spec where
47+ HLabelField
48+ :: HField table ('Spec labels necessity db a)
49+ -> HLabelField label table ('Spec (label ': labels) necessity db a)
50+
51+
52+instance (HTable table, KnownSymbol label) => HTable (HLabel label table) where
53+ type HField (HLabel label table) = HLabelField label table
54+ type HConstrainTable (HLabel label table) c =
55+ HConstrainTable table (LabelSpecC label c)
56+
57+ hfield (HLabel table) (HLabelField field) =
58+ getLabelSpec (hfield table field)
59+
60+ htabulate f = HLabel $ htabulate $ \field -> case hfield hspecs field of
61+ SSpec {} -> LabelSpec (f (HLabelField field))
62+ htraverse f (HLabel t) = HLabel <$> htraverse (traverseLabelSpec f) t
63+
64+ hdicts :: forall c. HConstrainTable table (LabelSpecC label c)
65+ => HLabel label table (H (Dict c))
66+ hdicts = HLabel $ htabulate $ \field -> case hfield hspecs field of
67+ SSpec {} -> case hfield (hdicts @_ @(LabelSpecC label c)) field of
68+ Dict -> LabelSpec Dict
69+
70+ hspecs = HLabel $ htabulate $ \field -> case hfield hspecs field of
71+ SSpec {..} -> LabelSpec SSpec {labels = SLabels Proxy labels, ..}
72+
73+ {-# INLINABLE hfield #-}
74+ {-# INLINABLE htabulate #-}
75+ {-# INLINABLE htraverse #-}
76+ {-# INLINABLE hdicts #-}
77+ {-# INLINABLE hspecs #-}
78+
79+
80+type LabelingSpec :: Type -> Type
81+type LabelingSpec r = Symbol -> (Spec -> r) -> Spec -> r
82+
83+
84+type LabelSpec :: LabelingSpec Type
85+data LabelSpec label context spec where
86+ LabelSpec
87+ :: { getLabelSpec :: context ('Spec (label ': labels) necessity db a) }
88+ -> LabelSpec label context ('Spec labels necessity db a)
89+
90+
91+type LabelSpecC :: LabelingSpec Constraint
92+class
93+ ( forall labels necessity db a.
94+ ( spec ~ 'Spec labels necessity db a =>
95+ constraint ('Spec (label ': labels) necessity db a)
96+ )
97+ ) => LabelSpecC label constraint spec
98+instance
99+ ( spec ~ 'Spec labels necessity db a
100+ , constraint ('Spec (label ': labels) necessity db a)
101+ ) => LabelSpecC label constraint spec
102+
103+
104+traverseLabelSpec :: forall context context' label spec m. Functor m
105+ => (forall x. context x -> m (context' x))
106+ -> LabelSpec label context spec -> m (LabelSpec label context' spec)
107+traverseLabelSpec f (LabelSpec a) = LabelSpec <$> f a
108+
109+
110+hlabel :: HTable t
111+ => (forall labels necessity db a. ()
112+ => context ('Spec labels necessity db a)
113+ -> context ('Spec (label ': labels) necessity db a))
114+ -> t (H context)
115+ -> HLabel label t (H context)
116+hlabel labeler a = HLabel $ htabulate $ \field ->
117+ case hfield hspecs field of
118+ SSpec {} -> LabelSpec (labeler (hfield a field))
119+{-# INLINABLE hlabel #-}
120+
121+
122+hunlabel :: HTable t
123+ => (forall labels necessity db a. ()
124+ => context ('Spec (label ': labels) necessity db a)
125+ -> context ('Spec labels necessity db a))
126+ -> HLabel label t (H context)
127+ -> t (H context)
128+hunlabel unlabler (HLabel as) =
129+ htabulate $ \field -> case hfield as field of
130+ LabelSpec a -> unlabler a
131+{-# INLINABLE hunlabel #-}
src/Rel8/Schema/HTable/List.hsnew file+18
@@ -0,0 +1,18 @@
1+{-# language DataKinds #-}
2+{-# language StandaloneKindSignatures #-}
3+
4+module Rel8.Schema.HTable.List
5+ ( HListTable
6+ )
7+where
8+
9+-- base
10+import Prelude ()
11+
12+-- rel8
13+import Rel8.Schema.HTable.Context ( HKTable )
14+import Rel8.Schema.HTable.Vectorize ( HVectorize )
15+
16+
17+type HListTable :: HKTable -> HKTable
18+type HListTable = HVectorize []
src/Rel8/Schema/HTable/Maybe.hsnew file+32
@@ -0,0 +1,32 @@
1+{-# language DataKinds #-}
2+{-# language DeriveAnyClass #-}
3+{-# language DeriveGeneric #-}
4+{-# language DerivingStrategies #-}
5+{-# language StandaloneKindSignatures #-}
6+
7+module Rel8.Schema.HTable.Maybe
8+ ( HMaybeTable(..)
9+ )
10+where
11+
12+-- base
13+import GHC.Generics ( Generic )
14+import Prelude
15+
16+-- rel8
17+import Rel8.Kind.Necessity ( Necessity( Required ) )
18+import Rel8.Schema.HTable ( HTable )
19+import Rel8.Schema.HTable.Context ( HKTable )
20+import Rel8.Schema.HTable.Identity ( HIdentity(..) )
21+import Rel8.Schema.HTable.Nullify ( HNullify )
22+import Rel8.Schema.Spec ( Spec( Spec ) )
23+import Rel8.Type.Tag ( MaybeTag )
24+
25+
26+type HMaybeTable :: HKTable -> HKTable
27+data HMaybeTable table context = HMaybeTable
28+ { htag :: HIdentity ('Spec '["isJust"] 'Required MaybeTag (Maybe MaybeTag)) context
29+ , hjust :: HNullify table context
30+ }
31+ deriving stock Generic
32+ deriving anyclass HTable
src/Rel8/Schema/HTable/NonEmpty.hsnew file+19
@@ -0,0 +1,19 @@
1+{-# language DataKinds #-}
2+{-# language StandaloneKindSignatures #-}
3+
4+module Rel8.Schema.HTable.NonEmpty
5+ ( HNonEmptyTable
6+ )
7+where
8+
9+-- base
10+import Data.List.NonEmpty ( NonEmpty )
11+import Prelude ()
12+
13+-- rel8
14+import Rel8.Schema.HTable.Context ( HKTable )
15+import Rel8.Schema.HTable.Vectorize ( HVectorize )
16+
17+
18+type HNonEmptyTable :: HKTable -> HKTable
19+type HNonEmptyTable = HVectorize NonEmpty
src/Rel8/Schema/HTable/Nullify.hsnew file+146
@@ -0,0 +1,146 @@
1+{-# language ConstraintKinds #-}
2+{-# language DataKinds #-}
3+{-# language FlexibleInstances #-}
4+{-# language GADTs #-}
5+{-# language InstanceSigs #-}
6+{-# language MultiParamTypeClasses #-}
7+{-# language QuantifiedConstraints #-}
8+{-# language RankNTypes #-}
9+{-# language RecordWildCards #-}
10+{-# language ScopedTypeVariables #-}
11+{-# language StandaloneKindSignatures #-}
12+{-# language TypeApplications #-}
13+{-# language TypeFamilies #-}
14+{-# language UndecidableInstances #-}
15+
16+module Rel8.Schema.HTable.Nullify
17+ ( HNullify( HNullify )
18+ , hnulls, hnullify, hunnullify
19+ )
20+where
21+
22+-- base
23+import Data.Kind ( Constraint, Type )
24+import Prelude hiding ( null )
25+
26+-- rel8
27+import Rel8.Schema.Dict ( Dict( Dict ) )
28+import Rel8.Schema.HTable
29+ ( HTable, HConstrainTable, HField
30+ , hfield, htabulate, htabulateA, htraverse, hdicts, hspecs
31+ )
32+import Rel8.Schema.HTable.Context ( H, HKTable )
33+import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )
34+import Rel8.Schema.Spec ( Context, Spec( Spec ), SSpec(..) )
35+
36+-- semigroupoids
37+import Data.Functor.Apply ( Apply )
38+
39+
40+type HNullify :: HKTable -> HKTable
41+data HNullify table context where
42+ HNullify :: table (H (NullifySpec context)) -> HNullify table (H context)
43+
44+
45+type HNullifyField :: HKTable -> Context
46+data HNullifyField table spec where
47+ HNullifyField
48+ :: HField table ('Spec labels necessity dbType a)
49+ -> HNullifyField table ('Spec labels necessity dbType (Maybe dbType))
50+
51+
52+instance HTable table => HTable (HNullify table) where
53+ type HField (HNullify table) = HNullifyField table
54+ type HConstrainTable (HNullify table) c =
55+ HConstrainTable table (NullifySpecC c)
56+
57+ hfield (HNullify table) (HNullifyField field) =
58+ getNullifySpec (hfield table field)
59+
60+ htabulate f = HNullify $ htabulate $ \field -> case hfield hspecs field of
61+ SSpec {} -> NullifySpec (f (HNullifyField field))
62+
63+ htraverse f (HNullify t) = HNullify <$> htraverse (traverseNullifySpec f) t
64+
65+ hdicts :: forall c. HConstrainTable table (NullifySpecC c)
66+ => HNullify table (H (Dict c))
67+ hdicts = HNullify $ htabulate $ \field -> case hfield hspecs field of
68+ SSpec {} -> case hfield (hdicts @_ @(NullifySpecC c)) field of
69+ Dict -> NullifySpec Dict
70+
71+ hspecs = HNullify $ htabulate $ \field -> case hfield hspecs field of
72+ SSpec {..} -> case nullability of
73+ Nullable -> NullifySpec SSpec {nullability = Nullable, ..}
74+ NonNullable -> NullifySpec SSpec {nullability = Nullable, ..}
75+
76+ {-# INLINABLE hfield #-}
77+ {-# INLINABLE htabulate #-}
78+ {-# INLINABLE htraverse #-}
79+ {-# INLINABLE hdicts #-}
80+ {-# INLINABLE hspecs #-}
81+
82+
83+type NullifyingSpec :: Type -> Type
84+type NullifyingSpec r = (Spec -> r) -> Spec -> r
85+
86+
87+type NullifySpec :: NullifyingSpec Type
88+data NullifySpec context spec where
89+ NullifySpec
90+ :: { getNullifySpec :: context ('Spec labels necessity dbType (Maybe dbType)) }
91+ -> NullifySpec context ('Spec labels necessity dbType a)
92+
93+
94+type NullifySpecC :: NullifyingSpec Constraint
95+class
96+ ( forall labels necessity dbType a.
97+ ( spec ~ 'Spec labels necessity dbType a =>
98+ constraint ('Spec labels necessity dbType (Maybe dbType))
99+ )
100+ ) => NullifySpecC constraint spec
101+instance
102+ ( spec ~ 'Spec labels necessity dbType a
103+ , constraint ('Spec labels necessity dbType (Maybe dbType))
104+ ) => NullifySpecC constraint spec
105+
106+
107+traverseNullifySpec :: forall context context' spec m. Functor m
108+ => (forall x. context x -> m (context' x))
109+ -> NullifySpec context spec -> m (NullifySpec context' spec)
110+traverseNullifySpec f (NullifySpec a) = NullifySpec <$> f a
111+
112+
113+hnulls :: HTable t
114+ => (forall labels necessity dbType. ()
115+ => context ('Spec labels necessity dbType (Maybe dbType)))
116+ -> HNullify t (H context)
117+hnulls null = HNullify $ htabulate $ \field -> case hfield hspecs field of
118+ SSpec {} -> NullifySpec null
119+{-# INLINABLE hnulls #-}
120+
121+
122+hnullify :: HTable t
123+ => (forall labels necessity dbType a. ()
124+ => SSpec ('Spec labels necessity dbType a)
125+ -> context ('Spec labels necessity dbType a)
126+ -> context ('Spec labels necessity dbType (Maybe dbType)))
127+ -> t (H context)
128+ -> HNullify t (H context)
129+hnullify nullifier a = HNullify $ htabulate $ \field ->
130+ case hfield hspecs field of
131+ spec@SSpec {} -> NullifySpec (nullifier spec (hfield a field))
132+{-# INLINABLE hnullify #-}
133+
134+
135+hunnullify :: (HTable t, Apply m)
136+ => (forall labels necessity dbType a. ()
137+ => SSpec ('Spec labels necessity dbType a)
138+ -> context ('Spec labels necessity dbType (Maybe dbType))
139+ -> m (context ('Spec labels necessity dbType a)))
140+ -> HNullify t (H context)
141+ -> m (t (H context))
142+hunnullify unnullifier (HNullify as) =
143+ htabulateA $ \field -> case hfield hspecs field of
144+ spec@SSpec {} -> case hfield as field of
145+ NullifySpec a -> unnullifier spec a
146+{-# INLINABLE hunnullify #-}
src/Rel8/Schema/HTable/Pair.hsnew file+20
@@ -0,0 +1,20 @@
1+{-# language DataKinds #-}
2+{-# language StandaloneKindSignatures #-}
3+
4+module Rel8.Schema.HTable.Pair
5+ ( HPair(..)
6+ )
7+where
8+
9+-- base
10+import Prelude ()
11+
12+-- rel8
13+import Rel8.Schema.HTable.Context ( HKTable )
14+
15+
16+type HPair :: HKTable -> HKTable -> HKTable
17+data HPair fst snd context = HPair
18+ { hfst :: fst context
19+ , hsnd :: snd context
20+ }
src/Rel8/Schema/HTable/Quartet.hsnew file+29
@@ -0,0 +1,29 @@
1+{-# language DataKinds #-}
2+{-# language DeriveAnyClass #-}
3+{-# language DeriveGeneric #-}
4+{-# language DerivingStrategies #-}
5+{-# language StandaloneKindSignatures #-}
6+
7+module Rel8.Schema.HTable.Quartet
8+ ( HQuartet(..)
9+ )
10+where
11+
12+-- base
13+import GHC.Generics ( Generic )
14+import Prelude ()
15+
16+-- rel8
17+import Rel8.Schema.HTable ( HTable )
18+import Rel8.Schema.HTable.Context ( HKTable )
19+
20+
21+type HQuartet :: HKTable -> HKTable -> HKTable -> HKTable -> HKTable
22+data HQuartet w x y z context = HQuartet
23+ { hfst :: w context
24+ , hsnd :: x context
25+ , htrd :: y context
26+ , hfrt :: z context
27+ }
28+ deriving stock Generic
29+ deriving anyclass HTable
src/Rel8/Schema/HTable/Quintet.hsnew file+30
@@ -0,0 +1,30 @@
1+{-# language DataKinds #-}
2+{-# language DeriveAnyClass #-}
3+{-# language DeriveGeneric #-}
4+{-# language DerivingStrategies #-}
5+{-# language StandaloneKindSignatures #-}
6+
7+module Rel8.Schema.HTable.Quintet
8+ ( HQuintet(..)
9+ )
10+where
11+
12+-- base
13+import GHC.Generics ( Generic )
14+import Prelude ()
15+
16+-- rel8
17+import Rel8.Schema.HTable ( HTable )
18+import Rel8.Schema.HTable.Context ( HKTable )
19+
20+
21+type HQuintet :: HKTable -> HKTable -> HKTable -> HKTable -> HKTable -> HKTable
22+data HQuintet v w x y z context = HQuintet
23+ { hfst :: v context
24+ , hsnd :: w context
25+ , htrd :: x context
26+ , hfrt :: y context
27+ , hfft :: z context
28+ }
29+ deriving stock Generic
30+ deriving anyclass HTable
src/Rel8/Schema/HTable/These.hsnew file+34
@@ -0,0 +1,34 @@
1+{-# language DataKinds #-}
2+{-# language DeriveAnyClass #-}
3+{-# language DeriveGeneric #-}
4+{-# language DerivingStrategies #-}
5+{-# language StandaloneKindSignatures #-}
6+
7+module Rel8.Schema.HTable.These
8+ ( HTheseTable(..)
9+ )
10+where
11+
12+-- base
13+import GHC.Generics ( Generic )
14+import Prelude
15+
16+-- rel8
17+import Rel8.Kind.Necessity ( Necessity( Required ) )
18+import Rel8.Schema.HTable ( HTable )
19+import Rel8.Schema.HTable.Context ( HKTable )
20+import Rel8.Schema.HTable.Identity ( HIdentity )
21+import Rel8.Schema.HTable.Nullify ( HNullify )
22+import Rel8.Schema.Spec ( Spec( Spec ) )
23+import Rel8.Type.Tag ( MaybeTag )
24+
25+
26+type HTheseTable :: HKTable -> HKTable -> HKTable
27+data HTheseTable here there context = HTheseTable
28+ { hhereTag :: HIdentity ('Spec '["hasHere"] 'Required MaybeTag (Maybe MaybeTag)) context
29+ , hhere :: HNullify here context
30+ , hthereTag :: HIdentity ('Spec '["hasThere"] 'Required MaybeTag (Maybe MaybeTag)) context
31+ , hthere :: HNullify there context
32+ }
33+ deriving stock Generic
34+ deriving anyclass HTable
src/Rel8/Schema/HTable/Trio.hsnew file+28
@@ -0,0 +1,28 @@
1+{-# language DataKinds #-}
2+{-# language DeriveAnyClass #-}
3+{-# language DeriveGeneric #-}
4+{-# language DerivingStrategies #-}
5+{-# language StandaloneKindSignatures #-}
6+
7+module Rel8.Schema.HTable.Trio
8+ ( HTrio(..)
9+ )
10+where
11+
12+-- base
13+import GHC.Generics ( Generic )
14+import Prelude ()
15+
16+-- rel8
17+import Rel8.Schema.HTable ( HTable )
18+import Rel8.Schema.HTable.Context ( HKTable )
19+
20+
21+type HTrio :: HKTable -> HKTable -> HKTable -> HKTable
22+data HTrio x y z context = HTrio
23+ { hfst :: x context
24+ , hsnd :: y context
25+ , htrd :: z context
26+ }
27+ deriving stock Generic
28+ deriving anyclass HTable
src/Rel8/Schema/HTable/Type.hsnew file+60
@@ -0,0 +1,60 @@
1+{-# language DataKinds #-}
2+{-# language GADTs #-}
3+{-# language StandaloneKindSignatures #-}
4+{-# language TypeFamilies #-}
5+{-# language UndecidableInstances #-}
6+
7+module Rel8.Schema.HTable.Type
8+ ( HType(..)
9+ )
10+where
11+
12+-- base
13+import Data.Kind ( Type )
14+import Data.Proxy ( Proxy( Proxy ) )
15+import Prelude
16+
17+-- rel8
18+import Rel8.Kind.Bool ( KnownBool, boolSing, IsList )
19+import Rel8.Kind.Labels ( SLabels( SLabel ) )
20+import Rel8.Kind.Necessity ( Necessity( Required ), SNecessity( SRequired ) )
21+import Rel8.Schema.Dict ( Dict( Dict ) )
22+import Rel8.Schema.HTable
23+ ( HTable, HConstrainTable, HField
24+ , hfield, htabulate, htraverse, hdicts, hspecs
25+ )
26+import Rel8.Schema.HTable.Context ( H, HKTable )
27+import Rel8.Schema.Nullability ( Unnullify, Nullabilizes, nullabilization )
28+import Rel8.Schema.Spec ( Context, Spec( Spec ), SSpec(..) )
29+import Rel8.Type ( DBType, typeInformation )
30+
31+
32+type HType :: Type -> HKTable
33+data HType a context where
34+ HType ::
35+ { unHType :: context ('Spec '[""] 'Required (Unnullify a) a)
36+ } -> HType a (H context)
37+
38+
39+type HTypeField :: Type -> Context
40+data HTypeField a spec where
41+ HTypeField :: HTypeField a ('Spec '[""] 'Required (Unnullify a) a)
42+
43+
44+instance (DBType db, Nullabilizes db a, KnownBool (IsList db)) =>
45+ HTable (HType a)
46+ where
47+ type HConstrainTable (HType a) c = c ('Spec '[""] 'Required (Unnullify a) a)
48+ type HField (HType a) = HTypeField a
49+
50+ hfield (HType a) HTypeField = a
51+ htabulate f = HType $ f HTypeField
52+ htraverse f (HType a) = HType <$> f a
53+ hdicts = HType Dict
54+ hspecs = HType SSpec
55+ { labels = SLabel Proxy
56+ , necessity = SRequired
57+ , info = typeInformation
58+ , nullability = nullabilization
59+ , isList = boolSing
60+ }
src/Rel8/Schema/HTable/Vectorize.hsnew file+220
@@ -0,0 +1,220 @@
1+{-# language AllowAmbiguousTypes #-}
2+{-# language ConstraintKinds #-}
3+{-# language DataKinds #-}
4+{-# language FlexibleContexts #-}
5+{-# language FlexibleInstances #-}
6+{-# language GADTs #-}
7+{-# language InstanceSigs #-}
8+{-# language MultiParamTypeClasses #-}
9+{-# language NamedFieldPuns #-}
10+{-# language QuantifiedConstraints #-}
11+{-# language RankNTypes #-}
12+{-# language RecordWildCards #-}
13+{-# language ScopedTypeVariables #-}
14+{-# language StandaloneKindSignatures #-}
15+{-# language TypeApplications #-}
16+{-# language TypeFamilies #-}
17+{-# language TypeOperators #-}
18+{-# language UndecidableInstances #-}
19+
20+module Rel8.Schema.HTable.Vectorize
21+ ( HVectorize( HVectorize )
22+ , hvectorize, hunvectorize
23+ , happend, hempty
24+ , hrelabel
25+ )
26+where
27+
28+-- base
29+import Data.Kind ( Constraint, Type )
30+import Data.List.NonEmpty ( NonEmpty )
31+import Data.Type.Equality ( (:~:)( Refl ) )
32+import Prelude
33+
34+-- rel8
35+import Rel8.Kind.Bool ( IsList, SBool( STrue ) )
36+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
37+import Rel8.Schema.Dict ( Dict( Dict ) )
38+import Rel8.Schema.HTable
39+ ( HTable, HConstrainTable, HField
40+ , hfield, htabulate, htabulateA, htraverse, hdicts, hspecs
41+ )
42+import Rel8.Schema.HTable.Context ( H, HKTable )
43+import Rel8.Schema.Nullability ( IsMaybe, Nullability( NonNullable ) )
44+import Rel8.Schema.Spec ( Context, Spec( Spec ), SSpec(..) )
45+import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
46+import Rel8.Type.Information ( TypeInformation )
47+
48+-- semialign
49+import Data.Zip ( Unzip, Repeat, Zippy(..) )
50+
51+
52+class Vector list where
53+ listIsList :: proxy a -> IsList (list a) :~: 'True
54+ listIsn'tMaybe :: proxy a -> IsMaybe (list a) :~: 'False
55+ vectorTypeInformation :: ()
56+ => Nullability a ma
57+ -> TypeInformation a
58+ -> TypeInformation (list ma)
59+
60+
61+instance Vector [] where
62+ listIsList _ = Refl
63+ listIsn'tMaybe _ = Refl
64+ vectorTypeInformation = listTypeInformation
65+
66+
67+instance Vector NonEmpty where
68+ listIsList _ = Refl
69+ listIsn'tMaybe _ = Refl
70+ vectorTypeInformation = nonEmptyTypeInformation
71+
72+
73+type HVectorize :: (Type -> Type) -> HKTable -> HKTable
74+data HVectorize list table context where
75+ HVectorize :: table (H (VectorizeSpec list context)) -> HVectorize list table (H context)
76+
77+
78+type HVectorizeField :: (Type -> Type) -> HKTable -> Context
79+data HVectorizeField list table spec where
80+ HVectorizeField
81+ :: HField table ('Spec labels necessity db a)
82+ -> HVectorizeField list table
83+ ('Spec labels necessity (list a) (list a)
84+ )
85+
86+
87+instance (HTable table, Vector list) => HTable (HVectorize list table) where
88+
89+ type HField (HVectorize list table) = HVectorizeField list table
90+ type HConstrainTable (HVectorize list table) c =
91+ HConstrainTable table (VectorizeSpecC list c)
92+
93+ hfield (HVectorize table) (HVectorizeField field) =
94+ getVectorizeSpec (hfield table field)
95+
96+ htabulate f = HVectorize $ htabulate $ \field -> case hfield hspecs field of
97+ SSpec {} -> VectorizeSpec (f (HVectorizeField field))
98+ htraverse f (HVectorize t) = HVectorize <$> htraverse (traverseVectorizeSpec f) t
99+
100+ hdicts :: forall c. HConstrainTable table (VectorizeSpecC list c) =>
101+ HVectorize list table (H (Dict c))
102+ hdicts = HVectorize $ htabulate $ \field -> case hfield hspecs field of
103+ SSpec {} -> case hfield (hdicts @_ @(VectorizeSpecC list c)) field of
104+ Dict -> VectorizeSpec Dict
105+
106+ hspecs = HVectorize $ htabulate $ \field -> case hfield hspecs field of
107+ SSpec {..} -> case listIsList @list nullability of
108+ Refl -> case listIsn'tMaybe @list nullability of
109+ Refl -> VectorizeSpec SSpec
110+ { nullability = NonNullable
111+ , info = vectorTypeInformation nullability info
112+ , isList = STrue
113+ , ..
114+ }
115+
116+ {-# INLINABLE hfield #-}
117+ {-# INLINABLE htabulate #-}
118+ {-# INLINABLE htraverse #-}
119+ {-# INLINABLE hdicts #-}
120+ {-# INLINABLE hspecs #-}
121+
122+
123+type VectorizingSpec :: Type -> Type
124+type VectorizingSpec r = (Type -> Type) -> (Spec -> r) -> Spec -> r
125+
126+
127+type VectorizeSpec :: VectorizingSpec Type
128+data VectorizeSpec list context spec where
129+ VectorizeSpec ::
130+ { getVectorizeSpec :: context ('Spec labels necessity (list a) (list a))
131+ } -> VectorizeSpec list context ('Spec labels necessity db a)
132+
133+
134+instance Labelable context => Labelable (VectorizeSpec list context) where
135+ labeler (VectorizeSpec a) = VectorizeSpec (labeler a)
136+ unlabeler (VectorizeSpec a) = VectorizeSpec (unlabeler a)
137+
138+
139+type VectorizeSpecC :: VectorizingSpec Constraint
140+class
141+ ( forall labels necessity db a.
142+ ( spec ~ 'Spec labels necessity db a
143+ => constraint ('Spec labels necessity (list a) (list a))
144+ )
145+ )
146+ => VectorizeSpecC list constraint spec
147+instance
148+ ( spec ~ 'Spec labels necessity db a
149+ , constraint ('Spec labels necessity (list a) (list a))
150+ )
151+ => VectorizeSpecC list constraint spec
152+
153+
154+traverseVectorizeSpec :: forall context context' list spec m. Functor m
155+ => (forall x. context x -> m (context' x))
156+ -> VectorizeSpec list context spec
157+ -> m (VectorizeSpec list context' spec)
158+traverseVectorizeSpec f (VectorizeSpec a) = VectorizeSpec <$> f a
159+
160+
161+hvectorize :: (HTable t, Unzip f)
162+ => (forall labels necessity db a. ()
163+ => SSpec ('Spec labels necessity db a)
164+ -> f (context ('Spec labels necessity db a))
165+ -> context' ('Spec labels necessity (list a) (list a)))
166+ -> f (t (H context))
167+ -> HVectorize list t (H context')
168+hvectorize vectorizer as = HVectorize $ htabulate $ \field ->
169+ case hfield hspecs field of
170+ spec@SSpec {} -> VectorizeSpec (vectorizer spec (fmap (`hfield` field) as))
171+{-# INLINABLE hvectorize #-}
172+
173+
174+hunvectorize :: (HTable t, Repeat f)
175+ => (forall labels necessity db a. ()
176+ => SSpec ('Spec labels necessity db a)
177+ -> context ('Spec labels necessity (list a) (list a))
178+ -> f (context' ('Spec labels necessity db a)))
179+ -> HVectorize list t (H context)
180+ -> f (t (H context'))
181+hunvectorize unvectorizer (HVectorize table) =
182+ getZippy $ htabulateA $ \field -> case hfield hspecs field of
183+ spec -> case hfield table field of
184+ VectorizeSpec a -> Zippy (unvectorizer spec a)
185+{-# INLINABLE hunvectorize #-}
186+
187+
188+happend :: HTable t =>
189+ ( forall labels necessity db a. ()
190+ => Nullability db a
191+ -> TypeInformation db
192+ -> context ('Spec labels necessity (list a) (list a))
193+ -> context ('Spec labels necessity (list a) (list a))
194+ -> context ('Spec labels necessity (list a) (list a))
195+ )
196+ -> HVectorize list t (H context)
197+ -> HVectorize list t (H context)
198+ -> HVectorize list t (H context)
199+happend append (HVectorize as) (HVectorize bs) = HVectorize $
200+ htabulate $ \field -> case (hfield as field, hfield bs field) of
201+ (VectorizeSpec a, VectorizeSpec b) -> case hfield hspecs field of
202+ SSpec {nullability, info} -> VectorizeSpec $ append nullability info a b
203+
204+
205+hempty :: HTable t =>
206+ ( forall labels necessity db a. ()
207+ => Nullability db a
208+ -> TypeInformation db
209+ -> context ('Spec labels necessity [a] [a])
210+ )
211+ -> HVectorize [] t (H context)
212+hempty empty = HVectorize $ htabulate $ \field -> case hfield hspecs field of
213+ SSpec {nullability, info} -> VectorizeSpec (empty nullability info)
214+
215+
216+hrelabel :: Labelable context
217+ => (forall ctx. Labelable ctx => t (H ctx) -> u (H ctx))
218+ -> HVectorize list t (H context)
219+ -> HVectorize list u (H context)
220+hrelabel f (HVectorize table) = HVectorize (f table)
src/Rel8/Schema/Nullability.hsnew file+86
@@ -0,0 +1,86 @@
1+{-# language ConstraintKinds #-}
2+{-# language DataKinds #-}
3+{-# language FlexibleContexts #-}
4+{-# language FlexibleInstances #-}
5+{-# language FunctionalDependencies #-}
6+{-# language GADTs #-}
7+{-# language MultiParamTypeClasses #-}
8+{-# language QuantifiedConstraints #-}
9+{-# language StandaloneKindSignatures #-}
10+{-# language TypeFamilies #-}
11+{-# language UndecidableInstances #-}
12+
13+module Rel8.Schema.Nullability
14+ ( IsMaybe, Nullify, Unnullify
15+ , Nullability( Nullable, NonNullable )
16+ , Nullabilizes, nullabilization
17+ )
18+where
19+
20+-- base
21+import Data.Kind ( Constraint, Type )
22+import Prelude
23+
24+-- rel8
25+import Rel8.Opaque ( Opaque )
26+
27+
28+type IsMaybe :: Type -> Bool
29+type family IsMaybe a where
30+ IsMaybe (Maybe _) = 'True
31+ IsMaybe _ = 'False
32+
33+
34+type Unnullify' :: Bool -> Type -> Type
35+type family Unnullify' isMaybe ma where
36+ Unnullify' 'False a = a
37+ Unnullify' 'True (Maybe a) = a
38+
39+
40+type Unnullify :: Type -> Type
41+type Unnullify a = Unnullify' (IsMaybe a) a
42+
43+
44+type Nullify' :: Bool -> Type -> Type
45+type family Nullify' isMaybe a where
46+ Nullify' 'False a = a
47+ Nullify' 'True a = Maybe a
48+
49+
50+type Nullify :: Type -> Type
51+type Nullify a = Maybe (Unnullify a)
52+
53+
54+type Nullability :: Type -> Type -> Type
55+data Nullability a ma where
56+ NonNullable :: IsMaybe a ~ 'False => Nullability a a
57+ Nullable :: IsMaybe a ~ 'False => Nullability a (Maybe a)
58+
59+
60+type Nullabilizes' :: Bool -> Type -> Type -> Constraint
61+class
62+ ( IsMaybe ma ~ isMaybe
63+ , IsMaybe a ~ 'False
64+ , Unnullify ma ~ a
65+ , Nullify' isMaybe a ~ ma
66+ ) => Nullabilizes' isMaybe a ma | isMaybe ma -> a, isMaybe a -> ma
67+ where
68+ nullabilization' :: Nullability a ma
69+
70+
71+instance IsMaybe a ~ 'False => Nullabilizes' 'False a a where
72+ nullabilization' = NonNullable
73+
74+
75+instance IsMaybe a ~ 'False => Nullabilizes' 'True a (Maybe a) where
76+ nullabilization' = Nullable
77+
78+
79+type Nullabilizes :: Type -> Type -> Constraint
80+class Nullabilizes' (IsMaybe ma) a ma => Nullabilizes a ma
81+instance Nullabilizes' (IsMaybe ma) a ma => Nullabilizes a ma
82+instance {-# OVERLAPPING #-} Nullabilizes Opaque Opaque
83+
84+
85+nullabilization :: forall a db. Nullabilizes db a => Nullability db a
86+nullabilization = nullabilization'
src/Rel8/Schema/Spec.hsnew file+75
@@ -0,0 +1,75 @@
1+{-# language DataKinds #-}
2+{-# language FlexibleContexts #-}
3+{-# language GADTs #-}
4+{-# language StandaloneKindSignatures #-}
5+{-# language UndecidableInstances #-}
6+
7+module Rel8.Schema.Spec
8+ ( Spec( Spec )
9+ , SSpec( SSpec, labels, necessity, info, nullability, isList )
10+ , KnownSpec( specSing )
11+ , Context, KTable
12+ )
13+where
14+
15+-- base
16+import Data.Kind ( Constraint, Type )
17+import Prelude ()
18+
19+-- rel8
20+import Rel8.Kind.Bool ( SBool, KnownBool, boolSing, IsList )
21+import Rel8.Kind.Labels ( Labels, SLabels, KnownLabels, labelsSing )
22+import Rel8.Kind.Necessity
23+ ( Necessity
24+ , SNecessity
25+ , KnownNecessity, necessitySing
26+ )
27+import Rel8.Schema.Nullability ( Nullability, Nullabilizes, nullabilization )
28+import Rel8.Type ( DBType, typeInformation )
29+import Rel8.Type.Information ( TypeInformation )
30+
31+
32+type Spec :: Type
33+data Spec = Spec Labels Necessity Type Type
34+
35+
36+type SSpec :: Spec -> Type
37+data SSpec spec where
38+ SSpec ::
39+ { labels :: SLabels labels
40+ , necessity :: SNecessity necessity
41+ , info :: TypeInformation db
42+ , nullability :: Nullability db a
43+ , isList :: SBool (IsList db)
44+ }
45+ -> SSpec ('Spec labels necessity db a)
46+
47+
48+type KnownSpec :: Spec -> Constraint
49+class KnownSpec spec where
50+ specSing :: SSpec spec
51+
52+
53+instance
54+ ( KnownLabels labels
55+ , KnownNecessity necessity
56+ , DBType db
57+ , Nullabilizes db a
58+ , KnownBool (IsList db)
59+ ) => KnownSpec ('Spec labels necessity db a)
60+ where
61+ specSing = SSpec
62+ { labels = labelsSing
63+ , necessity = necessitySing
64+ , info = typeInformation
65+ , nullability = nullabilization
66+ , isList = boolSing
67+ }
68+
69+
70+type Context :: Type
71+type Context = Spec -> Type
72+
73+
74+type KTable :: Type
75+type KTable = Context -> Type
src/Rel8/Schema/Spec/ConstrainContext.hsnew file+23
@@ -0,0 +1,23 @@
1+{-# language ConstraintKinds #-}
2+{-# language DataKinds #-}
3+{-# language FlexibleInstances #-}
4+{-# language MultiParamTypeClasses #-}
5+{-# language StandaloneKindSignatures #-}
6+{-# language UndecidableSuperClasses #-}
7+
8+module Rel8.Schema.Spec.ConstrainContext
9+ ( ConstrainContext
10+ )
11+where
12+
13+-- base
14+import Data.Kind ( Constraint, Type )
15+import Prelude ()
16+
17+-- rel8
18+import Rel8.Schema.Spec ( Context, Spec )
19+
20+
21+type ConstrainContext :: (Type -> Constraint) -> Context -> Spec -> Constraint
22+class constraint (context spec) => ConstrainContext constraint context spec
23+instance constraint (context spec) => ConstrainContext constraint context spec
src/Rel8/Schema/Spec/ConstrainDBType.hsnew file+34
@@ -0,0 +1,34 @@
1+{-# language ConstraintKinds #-}
2+{-# language DataKinds #-}
3+{-# language FlexibleInstances #-}
4+{-# language MultiParamTypeClasses #-}
5+{-# language QuantifiedConstraints #-}
6+{-# language StandaloneKindSignatures #-}
7+{-# language TypeFamilies #-}
8+{-# language UndecidableInstances #-}
9+
10+module Rel8.Schema.Spec.ConstrainDBType
11+ ( ConstrainDBType
12+ )
13+where
14+
15+-- base
16+import Data.Kind ( Constraint, Type )
17+import Prelude ()
18+
19+-- rel8
20+import Rel8.Schema.Spec ( Spec( Spec ) )
21+
22+
23+type ConstrainDBType :: (Type -> Constraint) -> Spec -> Constraint
24+class
25+ ( forall labels necessity db a. ()
26+ => (spec ~ 'Spec labels necessity db a)
27+ => constraint db
28+ )
29+ => ConstrainDBType constraint spec
30+instance
31+ ( spec ~ 'Spec labels necessity db a
32+ , constraint db
33+ )
34+ => ConstrainDBType constraint spec
src/Rel8/Schema/Spec/ConstrainType.hsnew file+31
@@ -0,0 +1,31 @@
1+{-# language ConstraintKinds #-}
2+{-# language DataKinds #-}
3+{-# language FlexibleInstances #-}
4+{-# language MultiParamTypeClasses #-}
5+{-# language QuantifiedConstraints #-}
6+{-# language StandaloneKindSignatures #-}
7+{-# language TypeFamilies #-}
8+{-# language UndecidableInstances #-}
9+
10+module Rel8.Schema.Spec.ConstrainType
11+ ( ConstrainType
12+ )
13+where
14+
15+-- base
16+import Data.Kind ( Constraint, Type )
17+import Prelude ()
18+
19+-- rel8
20+import Rel8.Schema.Spec ( Spec( Spec ) )
21+
22+
23+type ConstrainType :: (Type -> Constraint) -> Spec -> Constraint
24+class
25+ ( forall labels necessity db a. ()
26+ => (spec ~ 'Spec labels necessity db a)
27+ => constraint a
28+ ) =>
29+ ConstrainType constraint spec
30+instance (spec ~ 'Spec labels necessity db a, constraint a) =>
31+ ConstrainType constraint spec
src/Rel8/Schema/Structure.hsnew file+53
@@ -0,0 +1,53 @@
1+{-# language DataKinds #-}
2+{-# language StandaloneKindSignatures #-}
3+{-# language PolyKinds #-}
4+{-# language TypeFamilies #-}
5+
6+module Rel8.Schema.Structure
7+ ( Structure
8+ , Shape( Column, Either, List, Maybe, NonEmpty, These )
9+ , Shape1
10+ , Shape2
11+ , IsStructure
12+ )
13+where
14+
15+-- base
16+import Data.Kind ( Type )
17+import Prelude
18+
19+-- rel8
20+import Rel8.Schema.Spec ( Context, Spec )
21+
22+
23+type Structure :: Context
24+data Structure spec
25+
26+
27+type Shape :: Type
28+data Shape
29+ = Column Spec
30+ | Either Type Type
31+ | List Type
32+ | Maybe Type
33+ | NonEmpty Type
34+ | These Type Type
35+
36+
37+type Shape1 :: (a -> Shape) -> a -> Type
38+data Shape1 shape a
39+
40+
41+type Shape2 :: (a -> b -> Shape) -> a -> b -> Type
42+data Shape2 shape a b
43+
44+
45+type IsStructure :: Type -> Bool
46+type family IsStructure a where
47+ IsStructure (Shape1 _ _) = 'True
48+ IsStructure (Shape2 _ _ _) = 'True
49+ IsStructure (_, _) = 'True
50+ IsStructure (_, _, _) = 'True
51+ IsStructure (_, _, _, _) = 'True
52+ IsStructure (_, _, _, _, _) = 'True
53+ IsStructure _ = 'False
src/Rel8/Schema/Table.hsnew file+18
@@ -0,0 +1,18 @@
1+{-# language DeriveFunctor #-}
2+{-# language DerivingStrategies #-}
3+
4+module Rel8.Schema.Table
5+ ( TableSchema(..)
6+ )
7+where
8+
9+-- base
10+import Prelude
11+
12+
13+data TableSchema names = TableSchema
14+ { name :: String
15+ , schema :: Maybe String
16+ , columns :: names
17+ }
18+ deriving stock Functor
src/Rel8/Statement/Delete.hsnew file+87
@@ -0,0 +1,87 @@
1+{-# language GADTs #-}
2+{-# language NamedFieldPuns #-}
3+{-# language ScopedTypeVariables #-}
4+{-# language StandaloneKindSignatures #-}
5+{-# language TypeApplications #-}
6+
7+module Rel8.Statement.Delete
8+ ( Delete(..)
9+ , delete
10+ )
11+where
12+
13+-- base
14+import Control.Exception ( throwIO )
15+import Control.Monad ( (>=>) )
16+import Data.Kind ( Type )
17+import Prelude
18+
19+-- hasql
20+import Hasql.Connection ( Connection )
21+import qualified Hasql.Decoders as Hasql
22+import qualified Hasql.Encoders as Hasql
23+import qualified Hasql.Session as Hasql
24+import qualified Hasql.Statement as Hasql
25+
26+-- opaleye
27+import qualified Opaleye.Internal.Manipulation as Opaleye
28+
29+-- rel8
30+import Rel8.Expr ( Expr )
31+import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )
32+import Rel8.Schema.Table ( TableSchema )
33+import Rel8.Statement.Returning ( Returning( NumberOfRowsAffected, Projection ) )
34+import Rel8.Table ( fromColumns, toColumns )
35+import Rel8.Table.Opaleye ( table, unpackspec )
36+import Rel8.Table.Recontextualize ( Selects )
37+import Rel8.Table.Serialize ( Serializable, parse )
38+
39+-- text
40+import qualified Data.Text as Text
41+import Data.Text.Encoding ( encodeUtf8 )
42+
43+
44+type Delete :: Type -> Type
45+data Delete a where
46+ Delete :: Selects names exprs =>
47+ { from :: TableSchema names
48+ , deleteWhere :: exprs -> Expr Bool
49+ , returning :: Returning names a
50+ }
51+ -> Delete a
52+
53+
54+delete :: Delete a -> Connection -> IO a
55+delete Delete {from, deleteWhere, returning} =
56+ case returning of
57+ NumberOfRowsAffected -> Hasql.run session >=> either throwIO pure
58+ where
59+ session = Hasql.statement () statement
60+ statement = Hasql.Statement bytes params decode prepare
61+ bytes = encodeUtf8 $ Text.pack sql
62+ params = Hasql.noParams
63+ decode = Hasql.rowsAffected
64+ prepare = False
65+ sql = Opaleye.arrangeDeleteSql from' where'
66+ where
67+ from' = table $ toColumns <$> from
68+ where' = toColumn . toPrimExpr . deleteWhere . fromColumns
69+
70+ Projection project -> Hasql.run session >=> either throwIO pure
71+ where
72+ session = Hasql.statement () statement
73+ statement = Hasql.Statement bytes params decode prepare
74+ bytes = encodeUtf8 $ Text.pack sql
75+ params = Hasql.noParams
76+ decode = decoder project
77+ prepare = False
78+ sql =
79+ Opaleye.arrangeDeleteReturningSql unpackspec from' where' project'
80+ where
81+ from' = table $ toColumns <$> from
82+ where' = toColumn . toPrimExpr . deleteWhere . fromColumns
83+ project' = toColumns . project . fromColumns
84+ where
85+ decoder :: forall exprs projection a. Serializable projection a
86+ => (exprs -> projection) -> Hasql.Result [a]
87+ decoder _ = Hasql.rowList (parse @projection @a)
src/Rel8/Statement/Insert.hsnew file+105
@@ -0,0 +1,105 @@
1+{-# language FlexibleContexts #-}
2+{-# language GADTs #-}
3+{-# language NamedFieldPuns #-}
4+{-# language ScopedTypeVariables #-}
5+{-# language StandaloneKindSignatures #-}
6+{-# language TypeApplications #-}
7+
8+module Rel8.Statement.Insert
9+ ( Insert(..)
10+ , OnConflict(..)
11+ , insert
12+ )
13+where
14+
15+-- base
16+import Control.Exception ( throwIO )
17+import Control.Monad ( (>=>) )
18+import Data.Kind ( Type )
19+import Data.List.NonEmpty ( NonEmpty( (:|) ) )
20+import Prelude
21+
22+-- hasql
23+import Hasql.Connection ( Connection )
24+import qualified Hasql.Decoders as Hasql
25+import qualified Hasql.Encoders as Hasql
26+import qualified Hasql.Session as Hasql
27+import qualified Hasql.Statement as Hasql
28+
29+-- rel8
30+import qualified Opaleye.Internal.Manipulation as Opaleye
31+import qualified Opaleye.Manipulation as Opaleye
32+import Rel8.Schema.Table ( TableSchema )
33+import Rel8.Statement.Returning ( Returning( Projection, NumberOfRowsAffected ) )
34+import Rel8.Table ( fromColumns, toColumns )
35+import Rel8.Table.Opaleye ( table, unpackspec )
36+import Rel8.Table.Recontextualize ( Inserts, Selects )
37+import Rel8.Table.Serialize ( Serializable, parse )
38+
39+-- text
40+import qualified Data.Text as Text ( pack )
41+import Data.Text.Encoding ( encodeUtf8 )
42+
43+
44+type Insert :: Type -> Type
45+data Insert a where
46+ Insert :: (Selects names exprs, Inserts exprs inserts) =>
47+ { into :: TableSchema names
48+ , rows :: [inserts]
49+ , onConflict :: OnConflict
50+ , returning :: Returning names a
51+ }
52+ -> Insert a
53+
54+
55+data OnConflict = Abort | DoNothing
56+
57+
58+insert :: Insert a -> Connection -> IO a
59+insert Insert {into, rows, onConflict, returning} =
60+ case (rows, returning) of
61+ ([], NumberOfRowsAffected) -> const $ pure 0
62+ ([], Projection _) -> const $ pure []
63+
64+ (x:xs, NumberOfRowsAffected) -> Hasql.run session >=> either throwIO pure
65+ where
66+ session = Hasql.statement () statement
67+ statement = Hasql.Statement bytes params decode prepare
68+ bytes = encodeUtf8 $ Text.pack sql
69+ params = Hasql.noParams
70+ decode = Hasql.rowsAffected
71+ prepare = False
72+ sql = Opaleye.arrangeInsertManySql into' rows' onConflict'
73+ where
74+ into' = table $ toColumns <$> into
75+ rows' = toColumns <$> x :| xs
76+
77+ (x:xs, Projection project) -> Hasql.run session >=> either throwIO pure
78+ where
79+ session = Hasql.statement () statement
80+ statement = Hasql.Statement bytes params decode prepare
81+ bytes = encodeUtf8 $ Text.pack sql
82+ params = Hasql.noParams
83+ decode = decoder project
84+ prepare = False
85+ sql =
86+ Opaleye.arrangeInsertManyReturningSql
87+ unpackspec
88+ into'
89+ rows'
90+ project'
91+ onConflict'
92+ where
93+ into' = table $ toColumns <$> into
94+ rows' = toColumns <$> x :| xs
95+ project' = toColumns . project . fromColumns
96+
97+ where
98+ onConflict' =
99+ case onConflict of
100+ DoNothing -> Just Opaleye.DoNothing
101+ Abort -> Nothing
102+
103+ decoder :: forall exprs projection a. Serializable projection a
104+ => (exprs -> projection) -> Hasql.Result [a]
105+ decoder _ = Hasql.rowList (parse @projection @a)
src/Rel8/Statement/Returning.hsnew file+24
@@ -0,0 +1,24 @@
1+{-# language GADTs #-}
2+{-# language StandaloneKindSignatures #-}
3+
4+module Rel8.Statement.Returning
5+ ( Returning(..)
6+ )
7+where
8+
9+-- base
10+import Data.Int ( Int64 )
11+import Data.Kind ( Type )
12+import Prelude ()
13+
14+-- rel8
15+import Rel8.Table.Recontextualize ( Selects )
16+import Rel8.Table.Serialize ( Serializable )
17+
18+
19+type Returning :: Type -> Type -> Type
20+data Returning names a where
21+ NumberOfRowsAffected :: Returning names Int64
22+ Projection :: (Selects names exprs, Serializable projection a)
23+ => (exprs -> projection)
24+ -> Returning names [a]
src/Rel8/Statement/Select.hsnew file+61
@@ -0,0 +1,61 @@
1+{-# language ScopedTypeVariables #-}
2+{-# language TypeApplications #-}
3+
4+module Rel8.Statement.Select
5+ ( select
6+ , selectWithNames
7+ )
8+where
9+
10+-- base
11+import Control.Exception ( throwIO )
12+import Control.Monad ( (>=>) )
13+import Prelude
14+
15+-- hasql
16+import Hasql.Connection ( Connection )
17+import qualified Hasql.Decoders as Hasql
18+import qualified Hasql.Encoders as Hasql
19+import qualified Hasql.Session as Hasql
20+import qualified Hasql.Statement as Hasql
21+
22+-- rel8
23+import Rel8.Query ( Query )
24+import Rel8.Query.SQL ( sqlForQuery, sqlForQueryWithNames )
25+import Rel8.Table.Recontextualize ( Selects )
26+import Rel8.Table.Serialize ( Serializable, parse )
27+
28+-- text
29+import qualified Data.Text as Text
30+import Data.Text.Encoding ( encodeUtf8 )
31+
32+
33+select :: forall exprs a. Serializable exprs a
34+ => Query exprs -> Connection -> IO [a]
35+select query = case sqlForQuery query of
36+ Nothing -> const $ pure []
37+ Just sql -> Hasql.run session >=> either throwIO pure
38+ where
39+ session = Hasql.statement () statement
40+ statement = Hasql.Statement bytes params decode prepare
41+ bytes = encodeUtf8 (Text.pack sql)
42+ params = Hasql.noParams
43+ decode = Hasql.rowList (parse @exprs @a)
44+ prepare = False
45+
46+
47+selectWithNames :: forall exprs a names.
48+ ( Selects names exprs
49+ , Serializable exprs a
50+ )
51+ => names -> Query exprs -> Connection -> IO [a]
52+selectWithNames names query = case sqlForQueryWithNames names query of
53+ Nothing -> const $ pure []
54+ Just sql -> Hasql.run session >=> either throwIO pure
55+ where
56+ session = Hasql.statement () statement
57+ statement = Hasql.Statement bytes params decode prepare
58+ bytes = encodeUtf8 (Text.pack sql)
59+ params = Hasql.noParams
60+ decode = Hasql.rowList (parse @exprs @a)
61+ prepare = False
src/Rel8/Statement/Update.hsnew file+100
@@ -0,0 +1,100 @@
1+{-# language GADTs #-}
2+{-# language NamedFieldPuns #-}
3+{-# language ScopedTypeVariables #-}
4+{-# language StandaloneKindSignatures #-}
5+{-# language TypeApplications #-}
6+
7+module Rel8.Statement.Update
8+ ( Update(..)
9+ , update
10+ )
11+where
12+
13+-- base
14+import Control.Exception ( throwIO )
15+import Control.Monad ( (>=>) )
16+import Data.Kind ( Type )
17+import Prelude
18+
19+-- hasql
20+import Hasql.Connection ( Connection )
21+import qualified Hasql.Decoders as Hasql
22+import qualified Hasql.Encoders as Hasql
23+import qualified Hasql.Session as Hasql
24+import qualified Hasql.Statement as Hasql
25+
26+-- opaleye
27+import qualified Opaleye.Internal.Manipulation as Opaleye
28+
29+-- profunctors
30+import Data.Profunctor ( lmap )
31+
32+-- rel8
33+import Rel8.Expr ( Expr )
34+import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )
35+import Rel8.Schema.Table ( TableSchema )
36+import Rel8.Statement.Returning ( Returning( Projection, NumberOfRowsAffected ) )
37+import Rel8.Table ( fromColumns, toColumns )
38+import Rel8.Table.Insert ( toInsert )
39+import Rel8.Table.Opaleye ( table, unpackspec )
40+import Rel8.Table.Recontextualize ( Selects )
41+import Rel8.Table.Serialize ( Serializable, parse )
42+
43+-- text
44+import qualified Data.Text as Text
45+import Data.Text.Encoding ( encodeUtf8 )
46+
47+
48+type Update :: Type -> Type
49+data Update a where
50+ Update :: Selects names exprs =>
51+ { target :: TableSchema names
52+ , set :: exprs -> exprs
53+ , updateWhere :: exprs -> Expr Bool
54+ , returning :: Returning names a
55+ }
56+ -> Update a
57+
58+
59+update :: Update a -> Connection -> IO a
60+update Update {target, set, updateWhere, returning} =
61+ case returning of
62+ NumberOfRowsAffected -> Hasql.run session >=> either throwIO pure
63+ where
64+ session = Hasql.statement () statement
65+ statement = Hasql.Statement bytes params decode prepare
66+ bytes = encodeUtf8 $ Text.pack sql
67+ params = Hasql.noParams
68+ decode = Hasql.rowsAffected
69+ prepare = False
70+ sql = Opaleye.arrangeUpdateSql target' set' where'
71+ where
72+ target' = lmap toInsert $ table $ toColumns <$> target
73+ set' = toColumns . set . fromColumns
74+ where' = toColumn . toPrimExpr . updateWhere . fromColumns
75+
76+ Projection project -> Hasql.run session >=> either throwIO pure
77+ where
78+ session = Hasql.statement () statement
79+ statement = Hasql.Statement bytes params decode prepare
80+ bytes = encodeUtf8 $ Text.pack sql
81+ params = Hasql.noParams
82+ decode = decoder project
83+ prepare = False
84+ sql =
85+ Opaleye.arrangeUpdateReturningSql
86+ unpackspec
87+ target'
88+ set'
89+ where'
90+ project'
91+ where
92+ target' = lmap toInsert $ table $ toColumns <$> target
93+ set' = toColumns . set . fromColumns
94+ where' = toColumn . toPrimExpr . updateWhere . fromColumns
95+ project' = toColumns . project . fromColumns
96+
97+ where
98+ decoder :: forall exprs projection a. Serializable projection a
99+ => (exprs -> projection) -> Hasql.Result [a]
100+ decoder _ = Hasql.rowList (parse @projection @a)
src/Rel8/Statement/View.hsnew file+59
@@ -0,0 +1,59 @@
1+{-# language FlexibleContexts #-}
2+
3+module Rel8.Statement.View
4+ ( createView
5+ )
6+where
7+
8+-- base
9+import Control.Exception ( throwIO )
10+import Control.Monad ( (>=>) )
11+import Data.Foldable ( fold )
12+import Data.Maybe ( fromMaybe )
13+import Prelude
14+
15+-- hasql
16+import Hasql.Connection ( Connection )
17+import qualified Hasql.Decoders as Hasql
18+import qualified Hasql.Encoders as Hasql
19+import qualified Hasql.Session as Hasql
20+import qualified Hasql.Statement as Hasql
21+
22+-- rel8
23+import Rel8.Query ( Query )
24+import Rel8.Query.SQL ( sqlForQueryWithNames )
25+import Rel8.Schema.Table ( TableSchema( TableSchema ) )
26+import Rel8.Table.Alternative ( emptyTable )
27+import Rel8.Table.Recontextualize ( Selects )
28+
29+-- text
30+import qualified Data.Text as Text
31+import Data.Text.Encoding ( encodeUtf8 )
32+
33+
34+createView :: Selects names exprs
35+ => TableSchema names -> Query exprs -> Connection -> IO ()
36+createView (TableSchema name mschema names) query =
37+ Hasql.run session >=> either throwIO pure
38+ where
39+ session = Hasql.statement () statement
40+ statement = Hasql.Statement bytes params decode prepare
41+ bytes = encodeUtf8 (Text.pack sql)
42+ params = Hasql.noParams
43+ decode = Hasql.noResult
44+ prepare = False
45+ sql = "CREATE VIEW " <> title <> " WITH " <> select
46+ where
47+ title = case mschema of
48+ Nothing -> quote name
49+ Just schema -> quote schema <> "." <> quote name
50+ select = fromMaybe fallback $ sqlForQueryWithNames names query
51+ where
52+ fallback = fold $ sqlForQueryWithNames names emptyTable
53+
54+
55+quote :: String -> String
56+quote string = "\"" <> concatMap go string <> "\""
57+ where
58+ go '"' = "\"\""
59+ go c = [c]
src/Rel8/Table.hsnew file+236
@@ -0,0 +1,236 @@
1+{-# language DataKinds #-}
2+{-# language DisambiguateRecordFields #-}
3+{-# language FlexibleContexts #-}
4+{-# language FlexibleInstances #-}
5+{-# language FunctionalDependencies #-}
6+{-# language StandaloneKindSignatures #-}
7+{-# language TypeFamilies #-}
8+{-# language UndecidableInstances #-}
9+
10+module Rel8.Table
11+ ( Table (Columns, Context)
12+ , toColumns, fromColumns
13+ , Congruent
14+ )
15+where
16+
17+-- base
18+import Data.Functor.Identity ( Identity( Identity ) )
19+import Data.Kind ( Constraint, Type )
20+import Prelude
21+
22+-- rel8
23+import Rel8.Aggregate ( Aggregate )
24+import Rel8.Expr ( Expr )
25+import Rel8.Kind.Bool ( KnownBool, IsList )
26+import Rel8.Opaque ( Opaque, Opaque1 )
27+import Rel8.Schema.Context
28+ ( Aggregation( Aggregation )
29+ , DB( DB ), unDB
30+ , Result( Result )
31+ )
32+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
33+import Rel8.Schema.HTable ( HTable, hfield, hspecs, htabulate, htabulateA )
34+import Rel8.Schema.HTable.Context ( H, HKTable )
35+import Rel8.Schema.HTable.Identity ( HIdentity(..) )
36+import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
37+import Rel8.Schema.HTable.Pair ( HPair(..) )
38+import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
39+import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
40+import Rel8.Schema.HTable.Trio ( HTrio(..) )
41+import Rel8.Schema.HTable.Type ( HType( HType ) )
42+import Rel8.Schema.Nullability ( Nullabilizes )
43+import Rel8.Schema.Spec ( SSpec( SSpec ), KnownSpec )
44+import qualified Rel8.Schema.Spec as Kind ( Context )
45+import Rel8.Type ( DBType )
46+
47+
48+type Table :: Kind.Context -> Type -> Constraint
49+class (HTable (Columns a), context ~ Context a) => Table context a | a -> context where
50+ type Columns a :: HKTable
51+ type Context a :: Kind.Context
52+
53+ toColumns :: a -> Columns a (H (Context a))
54+ fromColumns :: Columns a (H (Context a)) -> a
55+
56+
57+-- | Any 'HTable' is also a 'Table'.
58+instance HTable t => Table context (t (H context)) where
59+ type Columns (t (H context)) = t
60+ type Context (t (H context)) = context
61+
62+ toColumns = id
63+ fromColumns = id
64+
65+
66+-- | Any context is trivially a table.
67+instance KnownSpec spec => Table context (context spec) where
68+ type Columns (context spec) = HIdentity spec
69+ type Context (context spec) = context
70+
71+ toColumns = HIdentity
72+ fromColumns = unHIdentity
73+
74+
75+instance Table DB a => Table Aggregation (Aggregate a) where
76+ type Columns (Aggregate a) = Columns a
77+ type Context (Aggregate a) = Aggregation
78+
79+ toColumns a = htabulate $ \field -> case hfield hspecs field of
80+ SSpec {} -> Aggregation $ unDB . (`hfield` field) . toColumns <$> a
81+ fromColumns as = fmap fromColumns $ htabulateA $ \field ->
82+ case hfield as field of
83+ Aggregation a -> DB <$> a
84+
85+
86+instance
87+ ( DBType db
88+ , Nullabilizes db a
89+ , KnownBool (IsList db)
90+ )
91+ => Table DB (Expr a)
92+ where
93+ type Columns (Expr a) = HType a
94+ type Context (Expr a) = DB
95+
96+ toColumns a = HType (DB a)
97+ fromColumns (HType (DB a)) = a
98+
99+
100+instance
101+ ( DBType db
102+ , Nullabilizes db a
103+ , KnownBool (IsList db)
104+ )
105+ => Table Result (Identity a)
106+ where
107+ type Columns (Identity a) = HType a
108+ type Context (Identity a) = Result
109+
110+ toColumns (Identity a) = HType (Result a)
111+ fromColumns (HType (Result a)) = Identity a
112+
113+
114+instance
115+ ( Table context a, Table context b
116+ , Labelable context
117+ ) =>
118+ Table context (a, b)
119+ where
120+ type Columns (a, b) =
121+ HPair
122+ (HLabel "fst" (Columns a))
123+ (HLabel "snd" (Columns b))
124+ type Context (a, b) = Context a
125+
126+ toColumns (a, b) = HPair
127+ { hfst = hlabel labeler $ toColumns a
128+ , hsnd = hlabel labeler $ toColumns b
129+ }
130+ fromColumns (HPair a b) =
131+ ( fromColumns $ hunlabel unlabeler a
132+ , fromColumns $ hunlabel unlabeler b
133+ )
134+
135+
136+instance
137+ ( Table context a, Table context b, Table context c
138+ , Labelable context
139+ ) => Table context (a, b, c)
140+ where
141+ type Columns (a, b, c) =
142+ HTrio
143+ (HLabel "fst" (Columns a))
144+ (HLabel "snd" (Columns b))
145+ (HLabel "trd" (Columns c))
146+ type Context (a, b, c) = Context a
147+
148+ toColumns (a, b, c) = HTrio
149+ { hfst = hlabel labeler $ toColumns a
150+ , hsnd = hlabel labeler $ toColumns b
151+ , htrd = hlabel labeler $ toColumns c
152+ }
153+ fromColumns (HTrio a b c) =
154+ ( fromColumns $ hunlabel unlabeler a
155+ , fromColumns $ hunlabel unlabeler b
156+ , fromColumns $ hunlabel unlabeler c
157+ )
158+
159+
160+instance
161+ ( Table context a, Table context b, Table context c, Table context d
162+ , Labelable context
163+ ) => Table context (a, b, c, d)
164+ where
165+ type Columns (a, b, c, d) =
166+ HQuartet
167+ (HLabel "fst" (Columns a))
168+ (HLabel "snd" (Columns b))
169+ (HLabel "trd" (Columns c))
170+ (HLabel "frt" (Columns d))
171+ type Context (a, b, c, d) = Context a
172+
173+ toColumns (a, b, c, d) = HQuartet
174+ { hfst = hlabel labeler $ toColumns a
175+ , hsnd = hlabel labeler $ toColumns b
176+ , htrd = hlabel labeler $ toColumns c
177+ , hfrt = hlabel labeler $ toColumns d
178+ }
179+ fromColumns (HQuartet a b c d) =
180+ ( fromColumns $ hunlabel unlabeler a
181+ , fromColumns $ hunlabel unlabeler b
182+ , fromColumns $ hunlabel unlabeler c
183+ , fromColumns $ hunlabel unlabeler d
184+ )
185+
186+
187+instance
188+ ( Table context a, Table context b, Table context c, Table context d
189+ , Table context e
190+ , Labelable context
191+ ) => Table context (a, b, c, d, e)
192+ where
193+ type Columns (a, b, c, d, e) =
194+ HQuintet
195+ (HLabel "fst" (Columns a))
196+ (HLabel "snd" (Columns b))
197+ (HLabel "trd" (Columns c))
198+ (HLabel "frt" (Columns d))
199+ (HLabel "fft" (Columns e))
200+ type Context (a, b, c, d, e) = Context a
201+
202+ toColumns (a, b, c, d, e) = HQuintet
203+ { hfst = hlabel labeler $ toColumns a
204+ , hsnd = hlabel labeler $ toColumns b
205+ , htrd = hlabel labeler $ toColumns c
206+ , hfrt = hlabel labeler $ toColumns d
207+ , hfft = hlabel labeler $ toColumns e
208+ }
209+ fromColumns (HQuintet a b c d e) =
210+ ( fromColumns $ hunlabel unlabeler a
211+ , fromColumns $ hunlabel unlabeler b
212+ , fromColumns $ hunlabel unlabeler c
213+ , fromColumns $ hunlabel unlabeler d
214+ , fromColumns $ hunlabel unlabeler e
215+ )
216+
217+
218+instance Table DB Opaque where
219+ type Columns Opaque = HType Opaque
220+ type Context Opaque = DB
221+
222+ fromColumns = error "opaque"
223+ toColumns = error "opaque"
224+
225+
226+instance Table context (Opaque1 context a) where
227+ type Columns (Opaque1 context a) = HType Opaque
228+ type Context (Opaque1 context a) = context
229+
230+ fromColumns = error "opaque"
231+ toColumns = error "opaque"
232+
233+
234+type Congruent :: Type -> Type -> Constraint
235+class Columns a ~ Columns b => Congruent a b
236+instance Columns a ~ Columns b => Congruent a b
src/Rel8/Table/Aggregate.hsnew file+62
@@ -0,0 +1,62 @@
1+{-# language FlexibleContexts #-}
2+{-# language NamedFieldPuns #-}
3+{-# language ScopedTypeVariables #-}
4+{-# language TypeApplications #-}
5+{-# language TypeFamilies #-}
6+{-# language ViewPatterns #-}
7+
8+module Rel8.Table.Aggregate
9+ ( groupBy
10+ , listAgg
11+ , nonEmptyAgg
12+ , runAggregation
13+ )
14+where
15+
16+-- base
17+import Data.Functor.Identity ( Identity( Identity ) )
18+import Prelude
19+
20+-- rel8
21+import Rel8.Aggregate ( Aggregate )
22+import Rel8.Expr.Aggregate ( listAggExpr, nonEmptyAggExpr, sgroupByExpr )
23+import Rel8.Schema.Context ( Aggregation( Aggregation ), DB( DB ) )
24+import Rel8.Schema.Dict ( Dict( Dict ) )
25+import Rel8.Schema.HTable ( htabulate, hfield, hdicts, hspecs )
26+import Rel8.Schema.HTable.Vectorize ( hvectorize )
27+import Rel8.Schema.Spec ( SSpec(..) )
28+import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
29+import Rel8.Table ( Table, Columns, toColumns, fromColumns )
30+import Rel8.Table.Eq ( EqTable )
31+import Rel8.Table.List ( ListTable )
32+import Rel8.Table.NonEmpty ( NonEmptyTable )
33+import Rel8.Table.Recontextualize ( Aggregates )
34+import Rel8.Type.Eq ( DBEq )
35+
36+
37+groupBy :: forall exprs. EqTable exprs => exprs -> Aggregate exprs
38+groupBy (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
39+ case hfield dicts field of
40+ Dict -> case hfield hspecs field of
41+ SSpec {nullability} -> case hfield exprs field of
42+ DB expr -> Aggregation $ sgroupByExpr nullability expr
43+ where
44+ dicts = hdicts @(Columns exprs) @(ConstrainDBType DBEq)
45+
46+
47+listAgg :: Table DB exprs => exprs -> Aggregate (ListTable exprs)
48+listAgg (toColumns -> exprs) = fromColumns $
49+ hvectorize
50+ (\_ (Identity (DB a)) -> Aggregation $ listAggExpr a)
51+ (pure exprs)
52+
53+
54+nonEmptyAgg :: Table DB exprs => exprs -> Aggregate (NonEmptyTable exprs)
55+nonEmptyAgg (toColumns -> exprs) = fromColumns $
56+ hvectorize
57+ (\_ (Identity (DB a)) -> Aggregation $ nonEmptyAggExpr a)
58+ (pure exprs)
59+
60+
61+runAggregation :: Aggregates aggregates exprs => aggregates -> Aggregate exprs
62+runAggregation = fromColumns . toColumns
src/Rel8/Table/Alternative.hsnew file+28
@@ -0,0 +1,28 @@
1+{-# language FlexibleContexts #-}
2+{-# language StandaloneKindSignatures #-}
3+{-# language TypeFamilies #-}
4+
5+module Rel8.Table.Alternative
6+ ( AltTable ( (<|>:) )
7+ , AlternativeTable ( emptyTable )
8+ )
9+where
10+
11+-- base
12+import Data.Kind ( Constraint, Type )
13+import Prelude ()
14+
15+-- rel8
16+import Rel8.Schema.Context ( DB )
17+import Rel8.Table ( Table )
18+
19+
20+type AltTable :: (Type -> Type) -> Constraint
21+class AltTable f where
22+ (<|>:) :: Table DB a => f a -> f a -> f a
23+ infixl 3 <|>:
24+
25+
26+type AlternativeTable :: (Type -> Type) -> Constraint
27+class AltTable f => AlternativeTable f where
28+ emptyTable :: Table DB a => f a
src/Rel8/Table/Bool.hsnew file+35
@@ -0,0 +1,35 @@
1+{-# language FlexibleContexts #-}
2+{-# language TypeFamilies #-}
3+{-# language ViewPatterns #-}
4+
5+module Rel8.Table.Bool
6+ ( bool
7+ , case_
8+ )
9+where
10+
11+-- base
12+import Prelude
13+
14+-- rel8
15+import Rel8.Expr ( Expr )
16+import Rel8.Expr.Bool ( boolExpr, caseExpr )
17+import Rel8.Schema.Context ( DB( DB ), unDB )
18+import Rel8.Schema.HTable ( htabulate, hfield )
19+import Rel8.Table ( Table, fromColumns, toColumns )
20+
21+
22+bool :: Table DB a => a -> a -> Expr Bool -> a
23+bool (toColumns -> false) (toColumns -> true) condition =
24+ fromColumns $ htabulate $ \field ->
25+ case (hfield false field, hfield true field) of
26+ (DB falseExpr, DB trueExpr) ->
27+ DB (boolExpr falseExpr trueExpr condition)
28+
29+
30+case_ :: Table DB a => [(Expr Bool, a)] -> a -> a
31+case_ (map (fmap toColumns) -> branches) (toColumns -> fallback) =
32+ fromColumns $ htabulate $ \field -> case hfield fallback field of
33+ DB fallbackExpr ->
34+ case map (fmap (unDB . (`hfield` field))) branches of
35+ branchExprs -> DB (caseExpr branchExprs fallbackExpr)
src/Rel8/Table/Either.hsnew file+174
@@ -0,0 +1,174 @@
1+{-# language DataKinds #-}
2+{-# language DeriveFunctor #-}
3+{-# language DerivingStrategies #-}
4+{-# language FlexibleContexts #-}
5+{-# language FlexibleInstances #-}
6+{-# language MultiParamTypeClasses #-}
7+{-# language NamedFieldPuns #-}
8+{-# language StandaloneKindSignatures #-}
9+{-# language TypeFamilies #-}
10+{-# language UndecidableInstances #-}
11+
12+module Rel8.Table.Either
13+ ( EitherTable(..)
14+ , eitherTable, leftTable, rightTable
15+ , isLeftTable, isRightTable
16+ )
17+where
18+
19+-- base
20+import Data.Bifunctor ( Bifunctor, bimap )
21+import Data.Functor.Identity ( runIdentity )
22+import Data.Kind ( Type )
23+import Prelude hiding ( undefined )
24+
25+-- rel8
26+import Rel8.Expr ( Expr )
27+import Rel8.Expr.Serialize ( litExpr )
28+import Rel8.Schema.Context ( DB )
29+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
30+import Rel8.Schema.Context.Nullify
31+ ( Nullifiable, NullifiableEq
32+ , encodeTag, decodeTag
33+ , nullifier, unnullifier
34+ )
35+import Rel8.Schema.HTable.Either ( HEitherTable(..) )
36+import Rel8.Schema.HTable.Identity ( HIdentity(..) )
37+import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
38+import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
39+import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
40+import Rel8.Table.Bool ( bool )
41+import Rel8.Table.Lifted
42+ ( Table1, Columns1, ConstrainContext1, fromColumns1, toColumns1
43+ , Table2, Columns2, ConstrainContext2, fromColumns2, toColumns2
44+ )
45+import Rel8.Table.Recontextualize ( Recontextualize )
46+import Rel8.Table.Undefined ( undefined )
47+import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )
48+
49+-- semigroupoids
50+import Data.Functor.Apply ( Apply, (<.>) )
51+import Data.Functor.Bind ( Bind, (>>-) )
52+
53+
54+type EitherTable :: Type -> Type -> Type
55+data EitherTable a b = EitherTable
56+ { tag :: Expr EitherTag
57+ , left :: a
58+ , right :: b
59+ }
60+ deriving stock (Show, Functor)
61+
62+
63+instance Bifunctor EitherTable where
64+ bimap f g (EitherTable tag a b) = EitherTable tag (f a) (g b)
65+
66+
67+instance Table DB a => Apply (EitherTable a) where
68+ EitherTable tag l1 f <.> EitherTable tag' l2 a =
69+ EitherTable (tag <> tag') (bool l1 l2 (isLeft tag)) (f a)
70+
71+
72+instance Table DB a => Applicative (EitherTable a) where
73+ pure = rightTable
74+ (<*>) = (<.>)
75+
76+
77+instance Table DB a => Bind (EitherTable a) where
78+ EitherTable tag l1 a >>- f = case f a of
79+ EitherTable tag' l2 b ->
80+ EitherTable (tag <> tag') (bool l1 l2 (isRight tag)) b
81+
82+
83+instance Table DB a => Monad (EitherTable a) where
84+ (>>=) = (>>-)
85+
86+
87+instance (Table DB a, Table DB b) => Semigroup (EitherTable a b) where
88+ a <> b = bool a b (isRightTable a)
89+
90+
91+instance Table2 EitherTable where
92+ type Columns2 EitherTable = HEitherTable
93+ type ConstrainContext2 EitherTable = Nullifiable
94+
95+ toColumns2 f g EitherTable {tag, left, right} = HEitherTable
96+ { htag
97+ , hleft = hnullify (nullifier (isLeft tag)) $ f left
98+ , hright = hnullify (nullifier (isRight tag)) $ g right
99+ }
100+ where
101+ htag = HIdentity (encodeTag tag)
102+
103+ fromColumns2 f g HEitherTable {htag = htag, hleft, hright} =
104+ EitherTable
105+ { tag
106+ , left = f $ runIdentity $
107+ hunnullify (\a -> pure . unnullifier (isLeft tag) a) hleft
108+ , right = g $ runIdentity $
109+ hunnullify (\a -> pure . unnullifier (isRight tag) a) hright
110+ }
111+ where
112+ tag = decodeTag $ unHIdentity htag
113+
114+ {-# INLINABLE fromColumns2 #-}
115+ {-# INLINABLE toColumns2 #-}
116+
117+
118+instance Table context a => Table1 (EitherTable a) where
119+ type Columns1 (EitherTable a) = HEitherTable (Columns a)
120+ type ConstrainContext1 (EitherTable a) = NullifiableEq (Context a)
121+
122+ toColumns1 = toColumns2 toColumns
123+ fromColumns1 = fromColumns2 fromColumns
124+
125+
126+instance
127+ ( Table context a, Table context b
128+ , Labelable context, Nullifiable context
129+ ) =>
130+ Table context (EitherTable a b)
131+ where
132+ type Columns (EitherTable a b) =
133+ HEitherTable (HLabel "Left" (Columns a)) (HLabel "Right" (Columns b))
134+ type Context (EitherTable a b) = Context a
135+
136+ toColumns =
137+ toColumns2
138+ (hlabel labeler . toColumns)
139+ (hlabel labeler . toColumns)
140+ fromColumns =
141+ fromColumns2
142+ (fromColumns . hunlabel unlabeler)
143+ (fromColumns . hunlabel unlabeler)
144+
145+
146+instance
147+ ( Nullifiable from, Labelable from
148+ , Nullifiable to, Labelable to
149+ , Recontextualize from to a1 b1
150+ , Recontextualize from to a2 b2
151+ ) =>
152+ Recontextualize from to (EitherTable a1 a2) (EitherTable b1 b2)
153+
154+
155+isLeftTable :: EitherTable a b -> Expr Bool
156+isLeftTable = isLeft . tag
157+
158+
159+isRightTable :: EitherTable a b -> Expr Bool
160+isRightTable = isRight . tag
161+
162+
163+eitherTable :: Table DB c
164+ => (a -> c) -> (b -> c) -> EitherTable a b -> c
165+eitherTable f g EitherTable {tag, left, right} =
166+ bool (f left) (g right) (isRight tag)
167+
168+
169+leftTable :: Table DB b => a -> EitherTable a b
170+leftTable a = EitherTable (litExpr IsLeft) a undefined
171+
172+
173+rightTable :: Table DB a => b -> EitherTable a b
174+rightTable = EitherTable (litExpr IsRight) undefined
src/Rel8/Table/Eq.hsnew file+82
@@ -0,0 +1,82 @@
1+{-# language DataKinds #-}
2+{-# language FlexibleContexts #-}
3+{-# language FlexibleInstances #-}
4+{-# language NamedFieldPuns #-}
5+{-# language ScopedTypeVariables #-}
6+{-# language StandaloneKindSignatures #-}
7+{-# language TypeApplications #-}
8+{-# language TypeFamilies #-}
9+{-# language UndecidableInstances #-}
10+{-# language UndecidableSuperClasses #-}
11+{-# language ViewPatterns #-}
12+
13+module Rel8.Table.Eq
14+ ( EqTable, (==:), (/=:)
15+ )
16+where
17+
18+-- base
19+import Data.Foldable ( foldl' )
20+import Data.Functor.Const ( Const( Const ), getConst )
21+import Data.Kind ( Constraint, Type )
22+import Data.List.NonEmpty ( NonEmpty( (:|) ) )
23+import Prelude hiding ( seq )
24+
25+-- rel8
26+import Rel8.Expr ( Expr )
27+import Rel8.Expr.Bool ( (||.), (&&.) )
28+import Rel8.Expr.Eq ( seq, sne )
29+import Rel8.Opaque ( Opaque )
30+import Rel8.Schema.Context ( DB( DB ) )
31+import Rel8.Schema.Dict ( Dict( Dict ) )
32+import Rel8.Schema.HTable
33+ ( HConstrainTable
34+ , htabulateA, hfield
35+ , hdicts, hspecs
36+ )
37+import Rel8.Schema.Spec ( SSpec(..) )
38+import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
39+import Rel8.Table ( Table, Columns, toColumns )
40+import Rel8.Type.Eq ( DBEq )
41+
42+
43+type EqTable :: Type -> Constraint
44+class
45+ ( Table DB a
46+ , HConstrainTable (Columns a) (ConstrainDBType DBEq)
47+ ) => EqTable a
48+instance
49+ ( Table DB a
50+ , HConstrainTable (Columns a) (ConstrainDBType DBEq)
51+ ) => EqTable a
52+instance {-# OVERLAPPING #-} EqTable Opaque
53+
54+
55+(==:) :: forall a. EqTable a => a -> a -> Expr Bool
56+(toColumns -> as) ==: (toColumns -> bs) =
57+ foldl1' (&&.) $ getConst $ htabulateA $ \field ->
58+ case (hfield as field, hfield bs field) of
59+ (DB a, DB b) -> case hfield dicts field of
60+ Dict -> case hfield specs field of
61+ SSpec {nullability} -> Const (pure (seq nullability a b))
62+ where
63+ dicts = hdicts @(Columns a) @(ConstrainDBType DBEq)
64+ specs = hspecs @(Columns a)
65+infix 4 ==:
66+
67+
68+(/=:) :: forall a. EqTable a => a -> a -> Expr Bool
69+(toColumns -> as) /=: (toColumns -> bs) =
70+ foldl1' (||.) $ getConst $ htabulateA $ \field ->
71+ case (hfield as field, hfield bs field) of
72+ (DB a, DB b) -> case hfield dicts field of
73+ Dict -> case hfield specs field of
74+ SSpec {nullability} -> Const (pure (sne nullability a b))
75+ where
76+ dicts = hdicts @(Columns a) @(ConstrainDBType DBEq)
77+ specs = hspecs @(Columns a)
78+infix 4 /=:
79+
80+
81+foldl1' :: (a -> a -> a) -> NonEmpty a -> a
82+foldl1' f (a :| as) = foldl' f a as
src/Rel8/Table/Insert.hsnew file+39
@@ -0,0 +1,39 @@
1+{-# language FlexibleContexts #-}
2+{-# language NamedFieldPuns #-}
3+{-# language TypeFamilies #-}
4+{-# language ViewPatterns #-}
5+
6+module Rel8.Table.Insert
7+ ( toInsert
8+ , toInsertDefaults
9+ )
10+where
11+
12+-- base
13+import Prelude
14+
15+-- rel8
16+import Rel8.Kind.Necessity ( SNecessity( SOptional, SRequired ) )
17+import Rel8.Schema.Context ( DB(..), Insertion(..) )
18+import Rel8.Schema.HTable ( hfield, htabulate, hspecs )
19+import Rel8.Schema.Spec ( SSpec(..) )
20+import Rel8.Table ( fromColumns, toColumns )
21+import Rel8.Table.Recontextualize ( Inserts )
22+
23+
24+toInsert :: Inserts exprs inserts => exprs -> inserts
25+toInsert (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
26+ case hfield hspecs field of
27+ SSpec {necessity} -> case hfield exprs field of
28+ DB expr -> case necessity of
29+ SRequired -> RequiredInsert expr
30+ SOptional -> OptionalInsert (Just expr)
31+
32+
33+toInsertDefaults :: Inserts exprs inserts => exprs -> inserts
34+toInsertDefaults (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
35+ case hfield hspecs field of
36+ SSpec {necessity} -> case hfield exprs field of
37+ DB expr -> case necessity of
38+ SRequired -> RequiredInsert expr
39+ SOptional -> OptionalInsert Nothing
src/Rel8/Table/Lifted.hsnew file+62
@@ -0,0 +1,62 @@
1+{-# language ConstrainedClassMethods #-}
2+{-# language DataKinds #-}
3+{-# language FlexibleContexts #-}
4+{-# language FlexibleInstances #-}
5+{-# language StandaloneKindSignatures #-}
6+{-# language TypeFamilies #-}
7+
8+module Rel8.Table.Lifted
9+ ( Table1( Columns1, ConstrainContext1, toColumns1, fromColumns1 )
10+ , Table2( Columns2, ConstrainContext2, toColumns2, fromColumns2 )
11+ )
12+where
13+
14+-- base
15+import Data.Kind ( Constraint, Type )
16+import Prelude ()
17+
18+-- rel8
19+import Rel8.Schema.HTable ( HTable )
20+import Rel8.Schema.HTable.Context ( H, HKTable )
21+import Rel8.Schema.Spec ( Context )
22+
23+
24+type Table1 :: (Type -> Type) -> Constraint
25+class Table1 f where
26+ type Columns1 f :: HKTable -> HKTable
27+ type ConstrainContext1 f :: Context -> Constraint
28+ type ConstrainContext1 _ = DefaultConstrainContext
29+
30+ toColumns1 :: (ConstrainContext1 f context, HTable t)
31+ => (a -> t (H context))
32+ -> f a
33+ -> Columns1 f t (H context)
34+
35+ fromColumns1 :: (ConstrainContext1 f context, HTable t)
36+ => (t (H context) -> a)
37+ -> Columns1 f t (H context)
38+ -> f a
39+
40+
41+type Table2 :: (Type -> Type -> Type) -> Constraint
42+class Table2 p where
43+ type Columns2 p :: HKTable -> HKTable -> HKTable
44+ type ConstrainContext2 p :: Context -> Constraint
45+ type ConstrainContext2 _ = DefaultConstrainContext
46+
47+ toColumns2 :: (ConstrainContext2 p context, HTable t, HTable u)
48+ => (a -> t (H context))
49+ -> (b -> u (H context))
50+ -> p a b
51+ -> Columns2 p t u (H context)
52+
53+ fromColumns2 :: (ConstrainContext2 p context, HTable t, HTable u)
54+ => (t (H context) -> a)
55+ -> (u (H context) -> b)
56+ -> Columns2 p t u (H context)
57+ -> p a b
58+
59+
60+type DefaultConstrainContext :: Context -> Constraint
61+class DefaultConstrainContext context
62+instance DefaultConstrainContext context
src/Rel8/Table/List.hsnew file+62
@@ -0,0 +1,62 @@
1+{-# language FlexibleContexts #-}
2+{-# language FlexibleInstances #-}
3+{-# language MultiParamTypeClasses #-}
4+{-# language StandaloneKindSignatures #-}
5+{-# language TypeFamilies #-}
6+{-# language UndecidableInstances #-}
7+
8+module Rel8.Table.List
9+ ( ListTable(..)
10+ )
11+where
12+
13+-- base
14+import Data.Kind ( Type )
15+import Prelude
16+
17+-- rel8
18+import Rel8.Expr.Array ( sappend, sempty )
19+import Rel8.Schema.Context ( DB( DB ) )
20+import Rel8.Schema.HTable.Context ( H )
21+import Rel8.Schema.HTable.List ( HListTable )
22+import Rel8.Schema.HTable.Vectorize ( happend, hempty )
23+import Rel8.Table ( Table, Context, Columns, fromColumns, toColumns )
24+import Rel8.Table.Alternative
25+ ( AltTable, (<|>:)
26+ , AlternativeTable, emptyTable
27+ )
28+import Rel8.Table.Recontextualize ( Recontextualize )
29+
30+
31+type ListTable :: Type -> Type
32+newtype ListTable a = ListTable (HListTable (Columns a) (H (Context a)))
33+
34+
35+instance Table context a => Table context (ListTable a) where
36+ type Columns (ListTable a) = HListTable (Columns a)
37+ type Context (ListTable a) = Context a
38+
39+ fromColumns = ListTable
40+ toColumns (ListTable a) = a
41+
42+
43+instance Recontextualize from to a b =>
44+ Recontextualize from to (ListTable a) (ListTable b)
45+
46+
47+instance AltTable ListTable where
48+ (<|>:) = (<>)
49+
50+
51+instance AlternativeTable ListTable where
52+ emptyTable = mempty
53+
54+
55+instance Table DB a => Semigroup (ListTable a) where
56+ ListTable as <> ListTable bs = ListTable $
57+ happend (\_ _ (DB a) (DB b) -> DB (sappend a b)) as bs
58+
59+
60+instance Table DB a => Monoid (ListTable a) where
61+ mempty = ListTable $ hempty $ \nullability info ->
62+ DB (sempty nullability info)
src/Rel8/Table/Maybe.hsnew file+180
@@ -0,0 +1,180 @@
1+{-# language DataKinds #-}
2+{-# language DeriveFunctor #-}
3+{-# language DerivingStrategies #-}
4+{-# language FlexibleContexts #-}
5+{-# language FlexibleInstances #-}
6+{-# language MultiParamTypeClasses #-}
7+{-# language NamedFieldPuns #-}
8+{-# language ScopedTypeVariables #-}
9+{-# language StandaloneKindSignatures #-}
10+{-# language TypeApplications #-}
11+{-# language TypeFamilies #-}
12+{-# language UndecidableInstances #-}
13+
14+module Rel8.Table.Maybe
15+ ( MaybeTable(..)
16+ , maybeTable, nothingTable, justTable
17+ , isNothingTable, isJustTable
18+ , ($?)
19+ )
20+where
21+
22+-- base
23+import Data.Functor.Identity ( runIdentity )
24+import Data.Kind ( Type )
25+import Prelude hiding ( null, repeat, undefined, zipWith )
26+
27+-- rel8
28+import Rel8.Expr ( Expr )
29+import Rel8.Expr.Bool ( boolExpr )
30+import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )
31+import Rel8.Expr.Serialize ( litExpr )
32+import Rel8.Schema.Context ( DB )
33+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
34+import Rel8.Schema.Context.Nullify
35+ ( Nullifiable
36+ , encodeTag, decodeTag
37+ , nullifier, unnullifier
38+ )
39+import Rel8.Schema.HTable.Identity ( HIdentity(..) )
40+import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
41+import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
42+import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
43+import Rel8.Schema.Nullability
44+ ( Nullability( Nullable, NonNullable )
45+ , Nullabilizes, nullabilization
46+ )
47+import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
48+import Rel8.Table.Alternative
49+ ( AltTable, (<|>:)
50+ , AlternativeTable, emptyTable
51+ )
52+import Rel8.Table.Bool ( bool )
53+import Rel8.Table.Lifted
54+ ( Table1, Columns1, ConstrainContext1, fromColumns1, toColumns1
55+ )
56+import Rel8.Table.Recontextualize ( Recontextualize )
57+import Rel8.Table.Undefined ( undefined )
58+import Rel8.Type ( DBType )
59+import Rel8.Type.Tag ( MaybeTag( IsJust ) )
60+
61+-- semigroupoids
62+import Data.Functor.Apply ( Apply, (<.>) )
63+import Data.Functor.Bind ( Bind, (>>-) )
64+
65+
66+type MaybeTable :: Type -> Type
67+data MaybeTable a = MaybeTable
68+ { tag :: Expr (Maybe MaybeTag)
69+ , just :: a
70+ }
71+ deriving stock (Show, Functor)
72+
73+
74+instance Apply MaybeTable where
75+ MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f a)
76+
77+
78+instance Applicative MaybeTable where
79+ (<*>) = (<.>)
80+ pure = justTable
81+
82+
83+instance Bind MaybeTable where
84+ MaybeTable tag a >>- f = case f a of
85+ MaybeTable tag' b -> MaybeTable (tag <> tag') b
86+
87+
88+instance Monad MaybeTable where
89+ (>>=) = (>>-)
90+
91+
92+instance AltTable MaybeTable where
93+ ma@(MaybeTable tag a) <|>: MaybeTable tag' b = MaybeTable
94+ { tag = boolExpr tag tag' condition
95+ , just = bool a b condition
96+ }
97+ where
98+ condition = isNothingTable ma
99+
100+
101+instance AlternativeTable MaybeTable where
102+ emptyTable = nothingTable
103+
104+
105+instance (Table DB a, Semigroup a) => Semigroup (MaybeTable a) where
106+ ma <> mb = maybeTable mb (\a -> maybeTable ma (justTable . (a <>)) mb) ma
107+
108+
109+instance (Table DB a, Semigroup a) => Monoid (MaybeTable a) where
110+ mempty = nothingTable
111+
112+
113+instance Table1 MaybeTable where
114+ type Columns1 MaybeTable = HMaybeTable
115+ type ConstrainContext1 MaybeTable = Nullifiable
116+
117+ toColumns1 f MaybeTable {tag, just} = HMaybeTable
118+ { htag
119+ , hjust = hnullify (nullifier (isNonNull tag)) $ f just
120+ }
121+ where
122+ htag = HIdentity (encodeTag tag)
123+
124+ fromColumns1 f HMaybeTable {htag = HIdentity htag, hjust} = MaybeTable
125+ { tag
126+ , just = f $ runIdentity $
127+ hunnullify (\a -> pure . unnullifier (isNonNull tag) a) hjust
128+ }
129+ where
130+ tag = decodeTag htag
131+
132+ {-# INLINABLE fromColumns1 #-}
133+ {-# INLINABLE toColumns1 #-}
134+
135+
136+instance
137+ ( Table context a
138+ , Labelable context, Nullifiable context
139+ ) => Table context (MaybeTable a)
140+ where
141+ type Columns (MaybeTable a) = HMaybeTable (HLabel "Just" (Columns a))
142+ type Context (MaybeTable a) = Context a
143+
144+ toColumns = toColumns1 (hlabel labeler . toColumns)
145+ fromColumns = fromColumns1 (fromColumns . hunlabel unlabeler)
146+
147+
148+instance
149+ ( Labelable from, Nullifiable from
150+ , Labelable to, Nullifiable to
151+ , Recontextualize from to a b
152+ ) => Recontextualize from to (MaybeTable a) (MaybeTable b)
153+
154+
155+isNothingTable :: MaybeTable a -> Expr Bool
156+isNothingTable (MaybeTable tag _) = isNull tag
157+
158+
159+isJustTable :: MaybeTable a -> Expr Bool
160+isJustTable (MaybeTable tag _) = isNonNull tag
161+
162+
163+maybeTable :: Table DB b => b -> (a -> b) -> MaybeTable a -> b
164+maybeTable b f ma@(MaybeTable _ a) = bool (f a) b (isNothingTable ma)
165+
166+
167+nothingTable :: Table DB a => MaybeTable a
168+nothingTable = MaybeTable null undefined
169+
170+
171+justTable :: a -> MaybeTable a
172+justTable = MaybeTable (nullify (litExpr IsJust))
173+
174+
175+($?) :: forall a b db. (DBType db, Nullabilizes db b)
176+ => (a -> Expr b) -> MaybeTable a -> Expr (Maybe db)
177+f $? ma@(MaybeTable _ a) = case nullabilization @b of
178+ Nullable -> boolExpr (f a) null (isNothingTable ma)
179+ NonNullable -> boolExpr (nullify (f a)) null (isNothingTable ma)
180+infixl 4 $?
src/Rel8/Table/Name.hsnew file+55
@@ -0,0 +1,55 @@
1+{-# language FlexibleContexts #-}
2+{-# language NamedFieldPuns #-}
3+{-# language ScopedTypeVariables #-}
4+{-# language TypeApplications #-}
5+{-# language TypeFamilies #-}
6+{-# language ViewPatterns #-}
7+
8+module Rel8.Table.Name
9+ ( namesFromLabels
10+ , namesFromLabelsWith
11+ , showLabels
12+ , showNames
13+ )
14+where
15+
16+-- base
17+import Data.Foldable ( fold )
18+import Data.Functor.Const ( Const( Const ), getConst )
19+import Data.List.NonEmpty ( NonEmpty, intersperse )
20+import Prelude
21+
22+-- casing
23+import Text.Casing ( quietSnake )
24+
25+-- rel8
26+import Rel8.Kind.Labels ( renderLabels )
27+import Rel8.Schema.Context ( Name( Name ) )
28+import Rel8.Schema.HTable ( htabulate, htabulateA, hfield, hspecs )
29+import Rel8.Schema.Spec ( SSpec(..) )
30+import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
31+
32+
33+namesFromLabels :: Table Name a => a
34+namesFromLabels = namesFromLabelsWith go
35+ where
36+ go = fold . intersperse "/" . fmap quietSnake
37+
38+
39+namesFromLabelsWith :: Table Name a
40+ => (NonEmpty String -> String) -> a
41+namesFromLabelsWith f = fromColumns $ htabulate $ \field ->
42+ case hfield hspecs field of
43+ SSpec {labels} -> Name (f (renderLabels labels))
44+
45+
46+showLabels :: forall a. Table (Context a) a => a -> [NonEmpty String]
47+showLabels _ = getConst $
48+ htabulateA @(Columns a) $ \field -> case hfield hspecs field of
49+ SSpec {labels} -> Const [renderLabels labels]
50+
51+
52+showNames :: forall a. Table Name a => a -> [String]
53+showNames (toColumns -> names) = getConst $
54+ htabulateA @(Columns a) $ \field -> case hfield names field of
55+ Name name -> Const [name]
src/Rel8/Table/NonEmpty.hsnew file+51
@@ -0,0 +1,51 @@
1+{-# language FlexibleInstances #-}
2+{-# language MultiParamTypeClasses #-}
3+{-# language StandaloneKindSignatures #-}
4+{-# language TypeFamilies #-}
5+{-# language UndecidableInstances #-}
6+
7+module Rel8.Table.NonEmpty
8+ ( NonEmptyTable(..)
9+ , HNonEmptyTable
10+ )
11+where
12+
13+-- base
14+import Data.Kind ( Type )
15+import Prelude
16+
17+-- rel8
18+import Rel8.Expr.Array ( sappend1 )
19+import Rel8.Schema.Context ( DB( DB ) )
20+import Rel8.Schema.HTable.Context ( H )
21+import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
22+import Rel8.Schema.HTable.Vectorize ( happend )
23+import Rel8.Table ( Table, Context, Columns, fromColumns, toColumns )
24+import Rel8.Table.Alternative ( AltTable, (<|>:) )
25+import Rel8.Table.Recontextualize ( Recontextualize )
26+
27+
28+type NonEmptyTable :: Type -> Type
29+newtype NonEmptyTable a =
30+ NonEmptyTable (HNonEmptyTable (Columns a) (H (Context a)))
31+
32+
33+instance Table context a => Table context (NonEmptyTable a) where
34+ type Columns (NonEmptyTable a) = HNonEmptyTable (Columns a)
35+ type Context (NonEmptyTable a) = Context a
36+
37+ fromColumns = NonEmptyTable
38+ toColumns (NonEmptyTable a) = a
39+
40+
41+instance Recontextualize from to a b =>
42+ Recontextualize from to (NonEmptyTable a) (NonEmptyTable b)
43+
44+
45+instance AltTable NonEmptyTable where
46+ (<|>:) = (<>)
47+
48+
49+instance Table DB a => Semigroup (NonEmptyTable a) where
50+ NonEmptyTable as <> NonEmptyTable bs = NonEmptyTable $
51+ happend (\_ _ (DB a) (DB b) -> DB (sappend1 a b)) as bs
src/Rel8/Table/Opaleye.hsnew file+132
@@ -0,0 +1,132 @@
1+{-# language DisambiguateRecordFields #-}
2+{-# language FlexibleContexts #-}
3+{-# language NamedFieldPuns #-}
4+{-# language TypeFamilies #-}
5+{-# language ViewPatterns #-}
6+
7+module Rel8.Table.Opaleye
8+ ( aggregator
9+ , binaryspec
10+ , distinctspec
11+ , table
12+ , tableFields
13+ , unpackspec
14+ , valuesspec
15+ )
16+where
17+
18+-- base
19+import Prelude hiding ( undefined )
20+
21+-- opaleye
22+import qualified Opaleye.Internal.Aggregate as Opaleye
23+import qualified Opaleye.Internal.Binary as Opaleye
24+import qualified Opaleye.Internal.Distinct as Opaleye
25+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
26+import qualified Opaleye.Internal.PackMap as Opaleye
27+import qualified Opaleye.Internal.Unpackspec as Opaleye
28+import qualified Opaleye.Internal.Values as Opaleye
29+import qualified Opaleye.Internal.Table as Opaleye
30+
31+-- profunctors
32+import Data.Profunctor ( dimap, lmap )
33+
34+-- rel8
35+import Rel8.Aggregate ( Aggregate( Aggregate ) )
36+import Rel8.Expr.Opaleye
37+ ( scastExpr
38+ , unsafeFromPrimExpr, unsafeToPrimExpr
39+ , unsafeTraversePrimExpr
40+ , sfromPrimExpr, stoPrimExpr
41+ , fromColumn, toColumn
42+ )
43+import Rel8.Kind.Necessity ( SNecessity( SRequired, SOptional ) )
44+import Rel8.Schema.Context ( DB(..), Insertion(..), Name(..) )
45+import Rel8.Schema.HTable ( htabulateA, hfield, htraverse, hspecs )
46+import Rel8.Schema.Spec ( SSpec(..) )
47+import Rel8.Schema.Table ( TableSchema(..) )
48+import Rel8.Table ( Table, fromColumns, toColumns )
49+import Rel8.Table.Recontextualize ( Selects, Inserts )
50+import Rel8.Table.Undefined ( undefined )
51+
52+-- semigroupoids
53+import Data.Functor.Apply ( WrappedApplicative(..) )
54+
55+
56+aggregator :: Opaleye.Aggregator (Aggregate exprs) exprs
57+aggregator = Opaleye.Aggregator $ Opaleye.PackMap $
58+ \f (Aggregate (Opaleye.Aggregator (Opaleye.PackMap inner))) -> inner f ()
59+
60+
61+binaryspec :: Table DB a => Opaleye.Binaryspec a a
62+binaryspec = Opaleye.Binaryspec $ Opaleye.PackMap $ \f (as, bs) ->
63+ fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->
64+ WrapApplicative $
65+ case (hfield (toColumns as) field, hfield (toColumns bs) field) of
66+ (DB a, DB b) -> DB . unsafeFromPrimExpr <$>
67+ f (unsafeToPrimExpr a, unsafeToPrimExpr b)
68+
69+
70+distinctspec :: Table DB a => Opaleye.Distinctspec a a
71+distinctspec =
72+ Opaleye.Distinctspec $ Opaleye.Aggregator $ Opaleye.PackMap $ \f ->
73+ fmap fromColumns .
74+ unwrapApplicative .
75+ htraverse (\(DB a) -> WrapApplicative $ DB . unsafeFromPrimExpr <$> f (Nothing, unsafeToPrimExpr a)) .
76+ toColumns
77+
78+
79+table ::(Selects names exprs, Inserts exprs inserts)
80+ => TableSchema names -> Opaleye.Table inserts exprs
81+table (TableSchema name schema columns) =
82+ Opaleye.Table qualified (tableFields columns)
83+ where
84+ qualified = case schema of
85+ Nothing -> name
86+ Just qualifier -> qualifier <> "." <> name
87+
88+
89+tableFields :: (Selects names exprs, Inserts exprs inserts)
90+ => names -> Opaleye.TableFields inserts exprs
91+tableFields (toColumns -> names) = dimap toColumns fromColumns $
92+ unwrapApplicative $ htabulateA $ \field -> WrapApplicative $
93+ case hfield hspecs field of
94+ specs -> case hfield names field of
95+ name -> lmap (`hfield` field) (go specs name)
96+ where
97+ go :: SSpec spec -> Name spec -> Opaleye.TableFields (Insertion spec) (DB spec)
98+ go SSpec {necessity, info, nullability, isList} (Name name) =
99+ case necessity of
100+ SRequired ->
101+ lmap (\(RequiredInsert a) -> toColumn $ toPrimExpr a) $
102+ DB . scastExpr nullability info . fromPrimExpr . fromColumn <$>
103+ Opaleye.requiredTableField name
104+ SOptional ->
105+ lmap (\(OptionalInsert ma) -> toColumn . toPrimExpr <$> ma) $
106+ DB . scastExpr nullability info . fromPrimExpr . fromColumn <$>
107+ Opaleye.optionalTableField name
108+ where
109+ fromPrimExpr = sfromPrimExpr nullability isList
110+ toPrimExpr = stoPrimExpr nullability isList
111+
112+
113+unpackspec :: Table DB a => Opaleye.Unpackspec a a
114+unpackspec = Opaleye.Unpackspec $ Opaleye.PackMap $ \f ->
115+ fmap fromColumns .
116+ unwrapApplicative .
117+ htraverse (\(DB a) -> WrapApplicative $ DB <$> unsafeTraversePrimExpr f a) .
118+ toColumns
119+{-# INLINABLE unpackspec #-}
120+
121+
122+valuesspec :: Table DB a => Opaleye.ValuesspecSafe a a
123+valuesspec = Opaleye.ValuesspecSafe (toPackMap undefined) unpackspec
124+
125+
126+toPackMap :: Table DB a
127+ => a -> Opaleye.PackMap Opaleye.PrimExpr Opaleye.PrimExpr () a
128+toPackMap as = Opaleye.PackMap $ \f () ->
129+ fmap fromColumns $
130+ unwrapApplicative .
131+ htraverse (\(DB a) -> WrapApplicative $ DB <$> unsafeTraversePrimExpr f a) $
132+ toColumns as
src/Rel8/Table/Ord.hsnew file+120
@@ -0,0 +1,120 @@
1+{-# language DataKinds #-}
2+{-# language FlexibleInstances #-}
3+{-# language NamedFieldPuns #-}
4+{-# language ScopedTypeVariables #-}
5+{-# language StandaloneKindSignatures #-}
6+{-# language TypeApplications #-}
7+{-# language TypeFamilies #-}
8+{-# language UndecidableInstances #-}
9+{-# language UndecidableSuperClasses #-}
10+{-# language ViewPatterns #-}
11+
12+module Rel8.Table.Ord
13+ ( OrdTable, (<:), (<=:), (>:), (>=:), least, greatest
14+ )
15+where
16+
17+-- base
18+import Data.Functor.Const ( Const( Const ), getConst )
19+import Data.Kind ( Constraint, Type )
20+import Prelude hiding ( seq )
21+
22+-- rel8
23+import Rel8.Expr ( Expr )
24+import Rel8.Expr.Bool ( (||.), (&&.), false, true )
25+import Rel8.Expr.Eq ( seq )
26+import Rel8.Expr.Ord ( slt, sgt)
27+import Rel8.Opaque ( Opaque )
28+import Rel8.Schema.Context ( DB( DB ) )
29+import Rel8.Schema.Dict ( Dict( Dict ) )
30+import Rel8.Schema.HTable
31+ ( HConstrainTable
32+ , htabulateA, hfield
33+ , hdicts, hspecs
34+ )
35+import Rel8.Schema.Spec ( SSpec(..) )
36+import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
37+import Rel8.Table ( Columns, toColumns )
38+import Rel8.Table.Bool ( bool )
39+import Rel8.Table.Eq ( EqTable )
40+import Rel8.Type.Ord ( DBOrd )
41+
42+
43+type OrdTable :: Type -> Constraint
44+class
45+ ( EqTable a
46+ , HConstrainTable (Columns a) (ConstrainDBType DBOrd)
47+ ) => OrdTable a
48+instance
49+ ( EqTable a
50+ , HConstrainTable (Columns a) (ConstrainDBType DBOrd)
51+ ) => OrdTable a
52+instance {-# OVERLAPPING #-} OrdTable Opaque
53+
54+
55+(<:) :: forall a. OrdTable a => a -> a -> Expr Bool
56+(toColumns -> as) <: (toColumns -> bs) =
57+ foldr @[] go false $ getConst $ htabulateA $ \field ->
58+ case (hfield as field, hfield bs field) of
59+ (DB a, DB b) -> case hfield dicts field of
60+ Dict -> case hfield specs field of
61+ SSpec {nullability} ->
62+ Const [(slt nullability a b, seq nullability a b)]
63+ where
64+ dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
65+ specs = hspecs @(Columns a)
66+ go (lt, eq) a = lt ||. (eq &&. a)
67+infix 4 <:
68+
69+
70+(<=:) :: forall a. OrdTable a => a -> a -> Expr Bool
71+(toColumns -> as) <=: (toColumns -> bs) =
72+ foldr @[] go true $ getConst $ htabulateA $ \field ->
73+ case (hfield as field, hfield bs field) of
74+ (DB a, DB b) -> case hfield dicts field of
75+ Dict -> case hfield specs field of
76+ SSpec {nullability} ->
77+ Const [(slt nullability a b, seq nullability a b)]
78+ where
79+ dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
80+ specs = hspecs @(Columns a)
81+ go (lt, eq) a = lt ||. (eq &&. a)
82+infix 4 <=:
83+
84+
85+(>:) :: forall a. OrdTable a => a -> a -> Expr Bool
86+(toColumns -> as) >: (toColumns -> bs) =
87+ foldr @[] go false $ getConst $ htabulateA $ \field ->
88+ case (hfield as field, hfield bs field) of
89+ (DB a, DB b) -> case hfield dicts field of
90+ Dict -> case hfield specs field of
91+ SSpec {nullability} ->
92+ Const [(slt nullability a b, seq nullability a b)]
93+ where
94+ dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
95+ specs = hspecs @(Columns a)
96+ go (gt, eq) a = gt ||. (eq &&. a)
97+infix 4 >:
98+
99+
100+(>=:) :: forall a. OrdTable a => a -> a -> Expr Bool
101+(toColumns -> as) >=: (toColumns -> bs) =
102+ foldr @[] go true $ getConst $ htabulateA $ \field ->
103+ case (hfield as field, hfield bs field) of
104+ (DB a, DB b) -> case hfield dicts field of
105+ Dict -> case hfield specs field of
106+ SSpec {nullability} ->
107+ Const [(sgt nullability a b, seq nullability a b)]
108+ where
109+ dicts = hdicts @(Columns a) @(ConstrainDBType DBOrd)
110+ specs = hspecs @(Columns a)
111+ go (gt, eq) a = gt ||. (eq &&. a)
112+infix 4 >=:
113+
114+
115+least :: OrdTable a => a -> a -> a
116+least a b = bool a b (a <: b)
117+
118+
119+greatest :: OrdTable a => a -> a -> a
120+greatest a b = bool a b (a >: b)
src/Rel8/Table/Order.hsnew file+50
@@ -0,0 +1,50 @@
1+{-# language NamedFieldPuns #-}
2+{-# language ScopedTypeVariables #-}
3+{-# language TypeApplications #-}
4+{-# language TypeFamilies #-}
5+
6+module Rel8.Table.Order
7+ ( ascTable
8+ , descTable
9+ )
10+where
11+
12+-- base
13+import Data.Functor.Const ( Const( Const ), getConst )
14+import Data.Functor.Contravariant ( (>$<), contramap )
15+import Prelude
16+
17+-- rel8
18+import Rel8.Expr.Order ( asc, desc, nullsFirst, nullsLast )
19+import Rel8.Order ( Order )
20+import Rel8.Schema.Context ( unDB )
21+import Rel8.Schema.Dict ( Dict( Dict ) )
22+import Rel8.Schema.HTable (htabulateA, hfield, hdicts, hspecs)
23+import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )
24+import Rel8.Schema.Spec ( SSpec(..) )
25+import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
26+import Rel8.Table
27+import Rel8.Table.Ord
28+import Rel8.Type.Ord
29+
30+
31+ascTable :: forall a. OrdTable a => Order a
32+ascTable = contramap toColumns $ getConst $
33+ htabulateA @(Columns a) $ \field -> case hfield hspecs field of
34+ SSpec {nullability} -> case hfield ords field of
35+ Dict -> Const $ unDB . (`hfield` field) >$< case nullability of
36+ Nullable -> nullsFirst asc
37+ NonNullable -> asc
38+ where
39+ ords = hdicts @(Columns a) @(ConstrainDBType DBOrd)
40+
41+
42+descTable :: forall a. OrdTable a => Order a
43+descTable = contramap toColumns $ getConst $
44+ htabulateA @(Columns a) $ \field -> case hfield hspecs field of
45+ SSpec {nullability} -> case hfield ords field of
46+ Dict -> Const $ unDB . (`hfield` field) >$< case nullability of
47+ Nullable -> nullsLast desc
48+ NonNullable -> desc
49+ where
50+ ords = hdicts @(Columns a) @(ConstrainDBType DBOrd)
src/Rel8/Table/Recontextualize.hsnew file+163
@@ -0,0 +1,163 @@
1+{-# language DataKinds #-}
2+{-# language FlexibleContexts #-}
3+{-# language FlexibleInstances #-}
4+{-# language FunctionalDependencies #-}
5+{-# language StandaloneKindSignatures #-}
6+{-# language TypeFamilies #-}
7+{-# language UndecidableInstances #-}
8+{-# language UndecidableSuperClasses #-}
9+
10+module Rel8.Table.Recontextualize
11+ ( Recontextualize
12+ , Aggregates
13+ , Encodes
14+ , Selects
15+ , Inserts
16+ )
17+where
18+
19+-- base
20+import Data.Functor.Identity ( Identity )
21+import Data.Kind ( Constraint, Type )
22+import Prelude ()
23+
24+-- rel8
25+import Rel8.Aggregate ( Aggregate )
26+import Rel8.Expr ( Expr )
27+import Rel8.Kind.Bool ( KnownBool, IsList )
28+import Rel8.Opaque ( Opaque, Opaque1 )
29+import Rel8.Schema.Context ( Aggregation, DB, Insertion, Name, Result )
30+import Rel8.Schema.Context.Label ( Labelable )
31+import Rel8.Schema.HTable ( HTable )
32+import Rel8.Schema.HTable.Context ( H )
33+import Rel8.Schema.Nullability ( Nullabilizes )
34+import Rel8.Schema.Spec ( KnownSpec )
35+import qualified Rel8.Schema.Spec as Kind ( Context )
36+import Rel8.Table ( Table, Congruent )
37+import Rel8.Type ( DBType )
38+
39+
40+type Recontextualize :: Kind.Context -> Kind.Context -> Type -> Type -> Constraint
41+class
42+ ( Table from a
43+ , Table to b
44+ , Congruent a b
45+ , Recontextualize from from a a
46+ , Recontextualize to to b b
47+ , Recontextualize to from b a
48+ ) => Recontextualize from to a b
49+ | a -> from
50+ , b -> to
51+ , a to -> b
52+ , b from -> a
53+
54+
55+instance (DBType db, Nullabilizes db a, KnownBool (IsList db)) =>
56+ Recontextualize Aggregation Aggregation (Aggregate (Expr a)) (Aggregate (Expr a))
57+
58+
59+instance (DBType db, Nullabilizes db a, KnownBool (IsList db)) =>
60+ Recontextualize Aggregation DB (Aggregate (Expr a)) (Expr a)
61+
62+
63+instance (DBType db, Nullabilizes db a, KnownBool (IsList db)) =>
64+ Recontextualize Aggregation Result (Aggregate (Expr a)) (Identity a)
65+
66+
67+instance (DBType db, Nullabilizes db a, KnownBool (IsList db)) =>
68+ Recontextualize DB Aggregation (Expr a) (Aggregate (Expr a))
69+
70+
71+instance (DBType db, Nullabilizes db a, KnownBool (IsList db)) =>
72+ Recontextualize DB DB (Expr a) (Expr a)
73+
74+
75+instance (DBType db, Nullabilizes db a, KnownBool (IsList db)) =>
76+ Recontextualize DB Result (Expr a) (Identity a)
77+
78+
79+instance (DBType db, Nullabilizes db a, KnownBool (IsList db)) =>
80+ Recontextualize Result Aggregation (Identity a) (Aggregate (Expr a))
81+
82+
83+instance (DBType db, Nullabilizes db a, KnownBool (IsList db)) =>
84+ Recontextualize Result DB (Identity a) (Expr a)
85+
86+
87+instance (DBType db, Nullabilizes db a, KnownBool (IsList db)) =>
88+ Recontextualize Result Result (Identity a) (Identity a)
89+
90+
91+instance KnownSpec spec => Recontextualize from to (from spec) (to spec)
92+
93+
94+instance Recontextualize from to (Opaque1 from a) (Opaque1 to a)
95+
96+
97+instance HTable t => Recontextualize from to (t (H from)) (t (H to))
98+
99+
100+instance
101+ ( Table from (t from)
102+ , Table to (t to)
103+ , Congruent (t from) (t to)
104+ ) => Recontextualize from to (t from) (t to)
105+
106+
107+instance
108+ ( Recontextualize from to a1 b1
109+ , Recontextualize from to a2 b2
110+ , Labelable from
111+ , Labelable to
112+ ) => Recontextualize from to (a1, a2) (b1, b2)
113+
114+
115+instance
116+ ( Recontextualize from to a1 b1
117+ , Recontextualize from to a2 b2
118+ , Recontextualize from to a3 b3
119+ , Labelable from, Labelable to
120+ ) => Recontextualize from to (a1, a2, a3) (b1, b2, b3)
121+
122+
123+instance
124+ ( Recontextualize from to a1 b1
125+ , Recontextualize from to a2 b2
126+ , Recontextualize from to a3 b3
127+ , Recontextualize from to a4 b4
128+ , Labelable from, Labelable to
129+ ) => Recontextualize from to (a1, a2, a3, a4) (b1, b2, b3, b4)
130+
131+
132+instance
133+ ( Recontextualize from to a1 b1
134+ , Recontextualize from to a2 b2
135+ , Recontextualize from to a3 b3
136+ , Recontextualize from to a4 b4
137+ , Recontextualize from to a5 b5
138+ , Labelable from, Labelable to
139+ ) => Recontextualize from to (a1, a2, a3, a4, a5) (b1, b2, b3, b4, b5)
140+
141+
142+type Aggregates :: Type -> Type -> Constraint
143+class Recontextualize Aggregation DB aggregates exprs => Aggregates aggregates exprs
144+instance Recontextualize Aggregation DB aggregates exprs => Aggregates aggregates exprs
145+instance {-# OVERLAPPING #-} Aggregates (Opaque1 Aggregation Opaque) (Opaque1 DB Opaque)
146+
147+
148+type Encodes :: Type -> Type -> Constraint
149+class Recontextualize Result DB a exprs => Encodes a exprs
150+instance Recontextualize Result DB a exprs => Encodes a exprs
151+instance {-# OVERLAPPING #-} Encodes (Opaque1 Result Opaque) (Opaque1 DB Opaque)
152+
153+
154+type Inserts :: Type -> Type -> Constraint
155+class Recontextualize DB Insertion exprs inserts => Inserts exprs inserts
156+instance Recontextualize DB Insertion exprs inserts => Inserts exprs inserts
157+instance {-# OVERLAPPING #-} Inserts (Opaque1 DB Opaque) (Opaque1 Insertion Opaque)
158+
159+
160+type Selects :: Type -> Type -> Constraint
161+class Recontextualize Name DB names exprs => Selects names exprs
162+instance Recontextualize Name DB names exprs => Selects names exprs
163+instance {-# OVERLAPPING #-} Selects (Opaque1 Name Opaque) (Opaque1 DB Opaque)
src/Rel8/Table/Serialize.hsnew file+453
@@ -0,0 +1,453 @@
1+{-# language AllowAmbiguousTypes #-}
2+{-# language DataKinds #-}
3+{-# language DisambiguateRecordFields #-}
4+{-# language FlexibleContexts #-}
5+{-# language FlexibleInstances #-}
6+{-# language FunctionalDependencies #-}
7+{-# language NamedFieldPuns #-}
8+{-# language ScopedTypeVariables #-}
9+{-# language StandaloneKindSignatures #-}
10+{-# language TypeApplications #-}
11+{-# language TypeFamilies #-}
12+{-# language ViewPatterns #-}
13+{-# language UndecidableInstances #-}
14+
15+module Rel8.Table.Serialize
16+ ( Serializable, lit, parse
17+ )
18+where
19+
20+-- base
21+import Data.Bifunctor ( bimap )
22+import Data.Kind ( Constraint, Type )
23+import Data.List.NonEmpty ( NonEmpty )
24+import Prelude
25+
26+-- hasql
27+import qualified Hasql.Decoders as Hasql
28+
29+-- rel8
30+import Rel8.Expr ( Expr )
31+import Rel8.Expr.Serialize ( slitExpr, sparseValue )
32+import Rel8.Kind.Bool ( KnownBool, IsList )
33+import Rel8.Opaque ( Opaque )
34+import Rel8.Schema.Context ( DB(..), Result(..) )
35+import Rel8.Schema.Context.Label ( labeler, unlabeler )
36+import Rel8.Schema.Context.Result
37+ ( fromHEitherTable, toHEitherTable
38+ , fromHListTable, toHListTable
39+ , fromHMaybeTable, toHMaybeTable
40+ , fromHNonEmptyTable, toHNonEmptyTable
41+ , fromHTheseTable, toHTheseTable
42+ )
43+import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs )
44+import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
45+import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
46+import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
47+import Rel8.Schema.HTable.Pair ( HPair(..) )
48+import Rel8.Schema.HTable.Trio ( HTrio(..) )
49+import Rel8.Schema.HTable.Type ( HType(..) )
50+import Rel8.Schema.HTable.Context ( H )
51+import Rel8.Schema.Nullability ( IsMaybe, Nullabilizes )
52+import Rel8.Schema.Spec ( SSpec(..), KnownSpec )
53+import Rel8.Table ( Table, Columns, fromColumns, toColumns )
54+import Rel8.Table.Either ( EitherTable )
55+import Rel8.Table.List ( ListTable )
56+import Rel8.Table.Maybe ( MaybeTable )
57+import Rel8.Table.NonEmpty ( NonEmptyTable )
58+import Rel8.Table.Recontextualize ( Encodes )
59+import Rel8.Table.These ( TheseTable )
60+import Rel8.Type ( DBType )
61+
62+-- semigroupoids
63+import Data.Functor.Apply ( WrappedApplicative(..) )
64+
65+-- these
66+import Data.These ( These )
67+
68+
69+type IsPlainColumn :: Type -> Bool
70+type family IsPlainColumn a where
71+ IsPlainColumn (Either _ _) = 'False
72+ IsPlainColumn [_] = 'False
73+ IsPlainColumn (Maybe _) = 'False
74+ IsPlainColumn (NonEmpty _) = 'False
75+ IsPlainColumn (These _ _) = 'False
76+ IsPlainColumn (_, _) = 'False
77+ IsPlainColumn (_, _, _) = 'False
78+ IsPlainColumn (_, _, _, _) = 'False
79+ IsPlainColumn (_, _, _, _, _) = 'False
80+ IsPlainColumn (_ (H Result)) = 'False
81+ IsPlainColumn (_ Result) = 'False
82+ IsPlainColumn (Result _) = 'False
83+ IsPlainColumn _ = 'True
84+
85+
86+type IsTabular :: Type -> Bool
87+type family IsTabular a where
88+ IsTabular (Either _ _) = 'True
89+ IsTabular [a] = IsListTabular a
90+ IsTabular (Maybe a) = IsMaybeTabular a
91+ IsTabular (NonEmpty a) = IsListTabular a
92+ IsTabular (These _ _) = 'True
93+ IsTabular (_, _) = 'True
94+ IsTabular (_, _, _) = 'True
95+ IsTabular (_, _, _, _) = 'True
96+ IsTabular (_, _, _, _, _) = 'True
97+ IsTabular (_ (H Result)) = 'True
98+ IsTabular (_ Result) = 'True
99+ IsTabular (Result _) = 'True
100+ IsTabular _ = 'False
101+
102+
103+type IsTabular' :: Bool -> Type -> Bool
104+type family IsTabular' isTabular exprs where
105+ IsTabular' _ (Expr _) = 'False
106+ IsTabular' 'False _ = 'False
107+ IsTabular' _ _ = 'True
108+
109+
110+type IsMaybeTabular :: Type -> Bool
111+type family IsMaybeTabular a where
112+ IsMaybeTabular (Maybe _) = 'True
113+ IsMaybeTabular a = IsTabular a
114+
115+
116+type IsListTabular :: Type -> Bool
117+type family IsListTabular a where
118+ IsListTabular (Maybe a) = IsMaybeTabular a
119+ IsListTabular a = IsTabular a
120+
121+
122+type ToExprs :: Type -> Type -> Constraint
123+class ExprsFor (IsPlainColumn a) (IsTabular' (IsTabular a) exprs) a exprs => ToExprs a exprs
124+instance ExprsFor (IsPlainColumn a) (IsTabular' (IsTabular a) exprs) a exprs => ToExprs a exprs
125+
126+
127+fromResults' :: forall exprs a. ToExprs a exprs => Columns exprs (H Result) -> a
128+fromResults' = fromResults @(IsPlainColumn a) @_ @_ @exprs
129+
130+
131+toResults' :: forall exprs a. ToExprs a exprs => a -> Columns exprs (H Result)
132+toResults' = toResults @(IsPlainColumn a) @_ @_ @exprs
133+
134+
135+type ExprsFor :: Bool -> Bool -> Type -> Type -> Constraint
136+class (Table DB exprs, isTabular ~ IsTabular a) =>
137+ ExprsFor isPlainColumn isTabular a exprs where
138+ fromResults :: Columns exprs (H Result) -> a
139+ toResults :: a -> Columns exprs (H Result)
140+
141+
142+instance
143+ ( DBType a
144+ , IsList a ~ 'False
145+ , IsMaybe a ~ 'False
146+ , IsTabular a ~ 'False
147+ , x ~ Expr a
148+ )
149+ => ExprsFor 'True 'False a x
150+ where
151+ fromResults (HType (Result a)) = a
152+ toResults = HType . Result
153+
154+
155+instance
156+ ( DBType db
157+ , Nullabilizes db a
158+ , IsListTabular a ~ 'False
159+ , x ~ [a]
160+ ) => ExprsFor 'False 'False [a] (Expr x)
161+ where
162+ fromResults (HType (Result a)) = a
163+ toResults = HType . Result
164+
165+
166+instance
167+ ( DBType a
168+ , Nullabilizes a (Maybe a)
169+ , KnownBool (IsList a)
170+ , isTabular ~ 'False
171+ , IsMaybeTabular a ~ 'False
172+ , x ~ Maybe a
173+ ) => ExprsFor 'False 'False (Maybe a) (Expr x)
174+ where
175+ fromResults (HType (Result a)) = a
176+ toResults = HType . Result
177+
178+
179+instance
180+ ( DBType db
181+ , Nullabilizes db a
182+ , IsListTabular a ~ 'False
183+ , x ~ NonEmpty a
184+ ) => ExprsFor 'False 'False (NonEmpty a) (Expr x)
185+ where
186+ fromResults (HType (Result a)) = a
187+ toResults = HType . Result
188+
189+
190+instance
191+ ( ToExprs a exprs
192+ , IsListTabular a ~ 'False
193+ ) => ExprsFor 'False 'False [a] (ListTable exprs)
194+ where
195+ fromResults = fmap (fromResults' @exprs) . fromHListTable
196+ toResults = toHListTable . fmap (toResults' @exprs)
197+
198+
199+instance
200+ ( ToExprs a exprs
201+ , IsMaybeTabular a ~ 'False
202+ ) => ExprsFor 'False 'False (Maybe a) (MaybeTable exprs)
203+ where
204+ fromResults =
205+ fmap (fromResults' @exprs . hunlabel unlabeler) .
206+ fromHMaybeTable
207+ toResults =
208+ toHMaybeTable .
209+ fmap (hlabel labeler . toResults' @exprs)
210+
211+
212+instance
213+ ( ToExprs a exprs
214+ , IsListTabular a ~ 'False
215+ ) => ExprsFor 'False 'False (NonEmpty a) (NonEmptyTable exprs)
216+ where
217+ fromResults = fmap (fromResults' @exprs) . fromHNonEmptyTable
218+ toResults = toHNonEmptyTable . fmap (toResults' @exprs)
219+
220+
221+instance
222+ ( ToExprs a exprs1
223+ , ToExprs b exprs2
224+ , isTabular ~ 'True
225+ , x ~ EitherTable exprs1 exprs2
226+ ) => ExprsFor 'False isTabular (Either a b) x
227+ where
228+ fromResults =
229+ bimap
230+ (fromResults' @exprs1 . hunlabel unlabeler)
231+ (fromResults' @exprs2 . hunlabel unlabeler) .
232+ fromHEitherTable
233+ toResults =
234+ toHEitherTable .
235+ bimap
236+ (hlabel labeler . toResults' @exprs1)
237+ (hlabel labeler . toResults' @exprs2)
238+
239+
240+instance
241+ ( ToExprs a exprs
242+ , IsListTabular a ~ 'True
243+ , x ~ ListTable exprs
244+ ) => ExprsFor 'False 'True [a] x
245+ where
246+ fromResults = fmap (fromResults' @exprs) . fromHListTable
247+ toResults = toHListTable . fmap (toResults' @exprs)
248+
249+
250+instance
251+ ( ToExprs a exprs
252+ , IsMaybeTabular a ~ 'True
253+ , x ~ MaybeTable exprs
254+ ) => ExprsFor 'False 'True (Maybe a) x
255+ where
256+ fromResults =
257+ fmap (fromResults' @exprs . hunlabel unlabeler) .
258+ fromHMaybeTable
259+ toResults =
260+ toHMaybeTable .
261+ fmap (hlabel labeler . toResults' @exprs)
262+
263+
264+instance
265+ ( ToExprs a exprs
266+ , IsListTabular a ~ 'True
267+ , x ~ NonEmptyTable exprs
268+ ) => ExprsFor 'False 'True (NonEmpty a) x
269+ where
270+ fromResults = fmap (fromResults' @exprs) . fromHNonEmptyTable
271+ toResults = toHNonEmptyTable . fmap (toResults' @exprs)
272+
273+
274+instance
275+ ( ToExprs a exprs1
276+ , ToExprs b exprs2
277+ , isTabular ~ 'True
278+ , x ~ TheseTable exprs1 exprs2
279+ ) => ExprsFor 'False isTabular (These a b) x
280+ where
281+ fromResults =
282+ bimap
283+ (fromResults' @exprs1 . hunlabel unlabeler)
284+ (fromResults' @exprs2 . hunlabel unlabeler) .
285+ fromHTheseTable
286+ toResults =
287+ toHTheseTable .
288+ bimap
289+ (hlabel labeler . toResults' @exprs1)
290+ (hlabel labeler . toResults' @exprs2)
291+
292+
293+instance
294+ ( ToExprs a exprs1
295+ , ToExprs b exprs2
296+ , isTabular ~ 'True
297+ , x ~ (exprs1, exprs2)
298+ ) => ExprsFor 'False isTabular (a, b) x
299+ where
300+ fromResults (HPair a b) =
301+ ( fromResults' @exprs1 $ hunlabel unlabeler a
302+ , fromResults' @exprs2 $ hunlabel unlabeler b
303+ )
304+ toResults (a, b) = HPair
305+ { hfst = hlabel labeler $ toResults' @exprs1 a
306+ , hsnd = hlabel labeler $ toResults' @exprs2 b
307+ }
308+
309+
310+instance
311+ ( ToExprs a exprs1
312+ , ToExprs b exprs2
313+ , ToExprs c exprs3
314+ , isTabular ~ 'True
315+ , x ~ (exprs1, exprs2, exprs3)
316+ ) => ExprsFor 'False isTabular (a, b, c) x
317+ where
318+ fromResults (HTrio a b c) =
319+ ( fromResults' @exprs1 $ hunlabel unlabeler a
320+ , fromResults' @exprs2 $ hunlabel unlabeler b
321+ , fromResults' @exprs3 $ hunlabel unlabeler c
322+ )
323+ toResults (a, b, c) = HTrio
324+ { hfst = hlabel labeler $ toResults' @exprs1 a
325+ , hsnd = hlabel labeler $ toResults' @exprs2 b
326+ , htrd = hlabel labeler $ toResults' @exprs3 c
327+ }
328+
329+
330+instance
331+ ( ToExprs a exprs1
332+ , ToExprs b exprs2
333+ , ToExprs c exprs3
334+ , ToExprs d exprs4
335+ , isTabular ~ 'True
336+ , x ~ (exprs1, exprs2, exprs3, exprs4)
337+ ) => ExprsFor 'False isTabular (a, b, c, d) x
338+ where
339+ fromResults (HQuartet a b c d) =
340+ ( fromResults' @exprs1 $ hunlabel unlabeler a
341+ , fromResults' @exprs2 $ hunlabel unlabeler b
342+ , fromResults' @exprs3 $ hunlabel unlabeler c
343+ , fromResults' @exprs4 $ hunlabel unlabeler d
344+ )
345+ toResults (a, b, c, d) = HQuartet
346+ { hfst = hlabel labeler $ toResults' @exprs1 a
347+ , hsnd = hlabel labeler $ toResults' @exprs2 b
348+ , htrd = hlabel labeler $ toResults' @exprs3 c
349+ , hfrt = hlabel labeler $ toResults' @exprs4 d
350+ }
351+
352+
353+instance
354+ ( ToExprs a exprs1
355+ , ToExprs b exprs2
356+ , ToExprs c exprs3
357+ , ToExprs d exprs4
358+ , ToExprs e exprs5
359+ , isTabular ~ 'True
360+ , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)
361+ ) => ExprsFor 'False isTabular (a, b, c, d, e) x
362+ where
363+ fromResults (HQuintet a b c d e) =
364+ ( fromResults' @exprs1 $ hunlabel unlabeler a
365+ , fromResults' @exprs2 $ hunlabel unlabeler b
366+ , fromResults' @exprs3 $ hunlabel unlabeler c
367+ , fromResults' @exprs4 $ hunlabel unlabeler d
368+ , fromResults' @exprs5 $ hunlabel unlabeler e
369+ )
370+ toResults (a, b, c, d, e) = HQuintet
371+ { hfst = hlabel labeler $ toResults' @exprs1 a
372+ , hsnd = hlabel labeler $ toResults' @exprs2 b
373+ , htrd = hlabel labeler $ toResults' @exprs3 c
374+ , hfrt = hlabel labeler $ toResults' @exprs4 d
375+ , hfft = hlabel labeler $ toResults' @exprs5 e
376+ }
377+
378+
379+instance
380+ ( HTable t
381+ , isTabular ~ 'True
382+ , result ~ H Result
383+ , x ~ t (H DB)
384+ ) => ExprsFor 'False isTabular (t result) x
385+ where
386+ fromResults = id
387+ toResults = id
388+
389+
390+instance
391+ ( Encodes (t Result) (t DB)
392+ , isTabular ~ 'True
393+ , result ~ Result
394+ , x ~ t DB
395+ ) => ExprsFor 'False isTabular (t result) x
396+ where
397+ fromResults = fromColumns
398+ toResults = toColumns
399+
400+
401+instance
402+ ( KnownSpec spec
403+ , isTabular ~ 'True
404+ , x ~ DB spec
405+ ) => ExprsFor 'False isTabular (Result spec) x
406+ where
407+ fromResults = fromColumns
408+ toResults = toColumns
409+
410+
411+type FromExprs :: Type -> Type
412+type family FromExprs a where
413+ FromExprs (Expr a) = a
414+ FromExprs (DB spec) = Result spec
415+ FromExprs (EitherTable a b) = Either (FromExprs a) (FromExprs b)
416+ FromExprs (ListTable a) = [FromExprs a]
417+ FromExprs (MaybeTable a) = Maybe (FromExprs a)
418+ FromExprs (NonEmptyTable a) = NonEmpty (FromExprs a)
419+ FromExprs (TheseTable a b) = These (FromExprs a) (FromExprs b)
420+ FromExprs (a, b) = (FromExprs a, FromExprs b)
421+ FromExprs (a, b, c) = (FromExprs a, FromExprs b, FromExprs c)
422+ FromExprs (a, b, c, d) =
423+ (FromExprs a, FromExprs b, FromExprs c, FromExprs d)
424+ FromExprs (a, b, c, d, e) =
425+ (FromExprs a, FromExprs b, FromExprs c, FromExprs d, FromExprs e)
426+ FromExprs (t DB) = t Result
427+ FromExprs (t (H DB)) = t (H Result)
428+
429+
430+class (ToExprs a exprs, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a
431+instance (ToExprs a exprs, a ~ FromExprs exprs) => Serializable exprs a
432+instance Serializable (Expr Opaque) Opaque
433+
434+
435+lit :: forall exprs a. Serializable exprs a => a -> exprs
436+lit = fromColumns . litTable . toResults' @exprs
437+
438+
439+parse :: forall exprs a. Serializable exprs a => Hasql.Row a
440+parse = fromResults' @exprs <$> parseTable
441+
442+
443+litTable :: Encodes a b => a -> b
444+litTable (toColumns -> as) = fromColumns $ htabulate $ \field ->
445+ case hfield hspecs field of
446+ SSpec {nullability, info} -> case hfield as field of
447+ Result value -> DB (slitExpr nullability info value)
448+
449+
450+parseTable :: Table Result a => Hasql.Row a
451+parseTable = fmap fromColumns $ unwrapApplicative $ htabulateA $ \field ->
452+ WrapApplicative $ case hfield hspecs field of
453+ SSpec {nullability, info} -> Result <$> sparseValue nullability info
src/Rel8/Table/These.hsnew file+233
@@ -0,0 +1,233 @@
1+{-# language DataKinds #-}
2+{-# language DeriveFunctor #-}
3+{-# language DerivingStrategies #-}
4+{-# language FlexibleContexts #-}
5+{-# language FlexibleInstances #-}
6+{-# language MultiParamTypeClasses #-}
7+{-# language NamedFieldPuns #-}
8+{-# language StandaloneKindSignatures #-}
9+{-# language TupleSections #-}
10+{-# language TypeFamilies #-}
11+{-# language UndecidableInstances #-}
12+
13+module Rel8.Table.These
14+ ( TheseTable(..)
15+ , theseTable, thisTable, thatTable, thoseTable
16+ , isThisTable, isThatTable, isThoseTable
17+ , hasHereTable, hasThereTable
18+ , justHereTable, justThereTable
19+ )
20+where
21+
22+-- base
23+import Data.Bifunctor ( Bifunctor, bimap )
24+import Data.Functor.Identity ( runIdentity )
25+import Data.Kind ( Type )
26+import Prelude hiding ( undefined )
27+
28+-- rel8
29+import Rel8.Expr ( Expr )
30+import Rel8.Expr.Bool ( (&&.), not_ )
31+import Rel8.Expr.Null ( isNonNull )
32+import Rel8.Schema.Context ( DB )
33+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
34+import Rel8.Schema.Context.Nullify
35+ ( Nullifiable, NullifiableEq
36+ , encodeTag, decodeTag
37+ , nullifier, unnullifier
38+ )
39+import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
40+import Rel8.Schema.HTable.Identity ( HIdentity(..) )
41+import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
42+import Rel8.Schema.HTable.These ( HTheseTable(..) )
43+import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
44+import Rel8.Table.Lifted
45+ ( Table1, Columns1, ConstrainContext1, fromColumns1, toColumns1
46+ , Table2, Columns2, ConstrainContext2, fromColumns2, toColumns2
47+ )
48+import Rel8.Table.Maybe
49+ ( MaybeTable(..)
50+ , maybeTable, justTable, nothingTable
51+ , isJustTable
52+ )
53+import Rel8.Table.Recontextualize ( Recontextualize )
54+import Rel8.Table.Undefined ( undefined )
55+
56+-- semigroupoids
57+import Data.Functor.Apply ( Apply, (<.>) )
58+import Data.Functor.Bind ( Bind, (>>-) )
59+
60+
61+type TheseTable :: Type -> Type -> Type
62+data TheseTable a b = TheseTable
63+ { here :: MaybeTable a
64+ , there :: MaybeTable b
65+ }
66+ deriving stock (Show, Functor)
67+
68+
69+instance Bifunctor TheseTable where
70+ bimap f g (TheseTable a b) = TheseTable (fmap f a) (fmap g b)
71+
72+
73+instance (Table DB a, Semigroup a) => Apply (TheseTable a) where
74+ fs <.> as = TheseTable
75+ { here = here fs <> here as
76+ , there = there fs <.> there as
77+ }
78+
79+
80+instance (Table DB a, Semigroup a) => Applicative (TheseTable a)
81+ where
82+ pure = thatTable
83+ (<*>) = (<.>)
84+
85+
86+instance (Table DB a, Semigroup a) => Bind (TheseTable a) where
87+ TheseTable here1 ma >>- f = case ma >>- f' of
88+ mtb -> TheseTable
89+ { here = maybeTable here1 ((here1 <>) . fst) mtb
90+ , there = snd <$> mtb
91+ }
92+ where
93+ f' a = case f a of
94+ TheseTable here2 mb -> (here2,) <$> mb
95+
96+
97+instance (Table DB a, Semigroup a) => Monad (TheseTable a) where
98+ (>>=) = (>>-)
99+
100+
101+instance (Table DB a, Table DB b, Semigroup a, Semigroup b) =>
102+ Semigroup (TheseTable a b)
103+ where
104+ a <> b = TheseTable
105+ { here = here a <> here b
106+ , there = there a <> there b
107+ }
108+
109+
110+instance Table2 TheseTable where
111+ type Columns2 TheseTable = HTheseTable
112+ type ConstrainContext2 TheseTable = Nullifiable
113+
114+ toColumns2 f g TheseTable {here, there} = HTheseTable
115+ { hhereTag = HIdentity $ encodeTag (tag here)
116+ , hhere = hnullify (nullifier (isNonNull (tag here))) $ f (just here)
117+ , hthereTag = HIdentity $ encodeTag (tag there)
118+ , hthere = hnullify (nullifier (isNonNull (tag there))) $ g (just there)
119+ }
120+
121+ fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} =
122+ TheseTable
123+ { here =
124+ let
125+ tag = decodeTag $ unHIdentity hhereTag
126+ in
127+ MaybeTable
128+ { tag
129+ , just = f $
130+ runIdentity $
131+ hunnullify (\a -> pure . unnullifier (isNonNull tag) a)
132+ hhere
133+ }
134+ , there =
135+ let
136+ tag = decodeTag $ unHIdentity hthereTag
137+ in
138+ MaybeTable
139+ { tag
140+ , just = g $
141+ runIdentity $
142+ hunnullify (\a -> pure . unnullifier (isNonNull tag) a)
143+ hthere
144+ }
145+ }
146+
147+ {-# INLINABLE fromColumns2 #-}
148+ {-# INLINABLE toColumns2 #-}
149+
150+
151+instance Table context a => Table1 (TheseTable a) where
152+ type Columns1 (TheseTable a) = HTheseTable (Columns a)
153+ type ConstrainContext1 (TheseTable a) = NullifiableEq (Context a)
154+
155+ toColumns1 = toColumns2 toColumns
156+ fromColumns1 = fromColumns2 fromColumns
157+
158+
159+instance
160+ ( Table context a, Table context b
161+ , Labelable context, Nullifiable context
162+ ) => Table context (TheseTable a b)
163+ where
164+ type Columns (TheseTable a b) =
165+ HTheseTable (HLabel "Here" (Columns a)) (HLabel "There" (Columns b))
166+ type Context (TheseTable a b) = Context a
167+
168+ toColumns =
169+ toColumns2
170+ (hlabel labeler . toColumns)
171+ (hlabel labeler . toColumns)
172+ fromColumns =
173+ fromColumns2
174+ (fromColumns . hunlabel unlabeler)
175+ (fromColumns . hunlabel unlabeler)
176+
177+
178+instance
179+ ( Labelable from, Nullifiable from
180+ , Labelable to, Nullifiable to
181+ , Recontextualize from to a1 b1
182+ , Recontextualize from to a2 b2
183+ ) =>
184+ Recontextualize from to (TheseTable a1 a2) (TheseTable b1 b2)
185+
186+
187+isThisTable :: TheseTable a b -> Expr Bool
188+isThisTable a = hasHereTable a &&. not_ (hasThereTable a)
189+
190+
191+isThatTable :: TheseTable a b -> Expr Bool
192+isThatTable a = not_ (hasHereTable a) &&. hasThereTable a
193+
194+
195+isThoseTable :: TheseTable a b -> Expr Bool
196+isThoseTable a = hasHereTable a &&. hasThereTable a
197+
198+
199+hasHereTable :: TheseTable a b -> Expr Bool
200+hasHereTable TheseTable {here} = isJustTable here
201+
202+
203+hasThereTable :: TheseTable a b -> Expr Bool
204+hasThereTable TheseTable {there} = isJustTable there
205+
206+
207+justHereTable :: TheseTable a b -> MaybeTable a
208+justHereTable = here
209+
210+
211+justThereTable :: TheseTable a b -> MaybeTable b
212+justThereTable = there
213+
214+
215+thisTable :: Table DB b => a -> TheseTable a b
216+thisTable a = TheseTable (justTable a) nothingTable
217+
218+
219+thatTable :: Table DB a => b -> TheseTable a b
220+thatTable b = TheseTable nothingTable (justTable b)
221+
222+
223+thoseTable :: a -> b -> TheseTable a b
224+thoseTable a b = TheseTable (justTable a) (justTable b)
225+
226+
227+theseTable :: Table DB c
228+ => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable a b -> c
229+theseTable f g h TheseTable {here, there} =
230+ maybeTable
231+ (maybeTable undefined f here)
232+ (\b -> maybeTable (g b) (`h` b) here)
233+ there
src/Rel8/Table/Undefined.hsnew file+26
@@ -0,0 +1,26 @@
1+{-# language FlexibleContexts #-}
2+{-# language NamedFieldPuns #-}
3+{-# language TypeFamilies #-}
4+
5+module Rel8.Table.Undefined
6+ ( undefined
7+ )
8+where
9+
10+-- base
11+import Prelude hiding ( undefined )
12+
13+-- rel8
14+import Rel8.Expr.Null ( snull, unsafeUnnullify )
15+import Rel8.Schema.Context ( DB( DB ) )
16+import Rel8.Schema.HTable ( htabulate, hfield, hspecs )
17+import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )
18+import Rel8.Schema.Spec ( SSpec(..) )
19+import Rel8.Table ( Table, fromColumns )
20+
21+
22+undefined :: Table DB a => a
23+undefined = fromColumns $ htabulate $ \field -> case hfield hspecs field of
24+ SSpec {nullability, info} -> case nullability of
25+ Nullable -> DB (snull Nullable info)
26+ NonNullable -> DB (unsafeUnnullify (snull Nullable info))
src/Rel8/Tabulate.hsnew file+232
@@ -0,0 +1,232 @@
1+{-# language DeriveFunctor #-}
2+{-# language DerivingStrategies #-}
3+{-# language FlexibleContexts #-}
4+{-# language TupleSections #-}
5+
6+module Rel8.Tabulate
7+ ( Tabulation
8+ , runTabulation
9+ , tabulate
10+ , tabulateA
11+ , fromQuery
12+ , liftQuery
13+ , prebind
14+ , postbind
15+ , indexed
16+ , ifilter
17+ , lookup
18+ , align
19+ , alignWith
20+ , leftAlign
21+ , leftAlignWith
22+ , zip
23+ , zipWith
24+ , similarity
25+ , difference
26+ , aggregateTabulation
27+ , optionalTabulation
28+ )
29+where
30+
31+-- base
32+import Control.Applicative ( liftA2 )
33+import Control.Monad ( join, liftM2 )
34+import Data.Bifunctor ( bimap, first )
35+import Data.Foldable ( traverse_ )
36+import Data.Maybe ( fromMaybe )
37+import Prelude hiding ( filter, lookup, undefined, zip, zipWith )
38+
39+-- rel8
40+import Rel8.Aggregate ( Aggregate )
41+import Rel8.Expr ( Expr )
42+import Rel8.Expr.Bool ( not_, true )
43+import Rel8.Query ( Query )
44+import Rel8.Query.Aggregate ( aggregate )
45+import Rel8.Query.Exists ( withBy, withoutBy )
46+import Rel8.Query.Filter ( filter, where_ )
47+import Rel8.Query.Maybe ( optional )
48+import Rel8.Query.These ( alignBy )
49+import Rel8.Schema.Context ( DB )
50+import Rel8.Table ( Table )
51+import Rel8.Table.Aggregate ( groupBy )
52+import Rel8.Table.Eq ( EqTable, (==:) )
53+import Rel8.Table.Maybe ( MaybeTable )
54+import Rel8.Table.These ( TheseTable, theseTable )
55+import Rel8.Table.Undefined ( undefined )
56+
57+-- semigroupoids
58+import Data.Functor.Apply ( Apply, liftF2 )
59+import Data.Functor.Bind ( Bind )
60+import qualified Data.Functor.Bind
61+import Data.Semigroup.Traversable.Class ( bitraverse1 )
62+
63+
64+newtype Tabulation k a = Tabulation (k -> Query (Maybe k, a))
65+ deriving stock Functor
66+
67+
68+instance EqTable k => Apply (Tabulation k) where
69+ liftF2 = liftA2
70+
71+
72+instance EqTable k => Applicative (Tabulation k) where
73+ pure = liftQuery . pure
74+ liftA2 = liftM2
75+
76+
77+instance EqTable k => Bind (Tabulation k) where
78+ join = join
79+
80+
81+instance EqTable k => Monad (Tabulation k) where
82+ Tabulation as >>= f = Tabulation $ \i -> do
83+ (mk, a) <- as i
84+ case mk of
85+ Nothing -> case f a of
86+ Tabulation bs -> bs i
87+ Just k -> case f a of
88+ Tabulation bs -> do
89+ (mk', b) <- bs k
90+ case mk' of
91+ Nothing -> pure (mk, b)
92+ Just k' -> do
93+ where_ $ k ==: k'
94+ pure (mk', b)
95+
96+
97+runTabulation :: EqTable k => Tabulation k a -> Query (k, a)
98+runTabulation (Tabulation f) = do
99+ (mk, a) <- f i
100+ case mk of
101+ Nothing -> do
102+ -- Opaleye tries to be too clever optimising "WHERE FALSE" and generates
103+ -- invalid SQL, so we use "WHERE NOT TRUE" instead
104+ where_ $ not_ true
105+ pure (i, a)
106+ Just k -> pure (k, a)
107+ where
108+ i = undefined
109+
110+
111+liftQuery :: Query a -> Tabulation k a
112+liftQuery query = Tabulation $ const $ fmap (Nothing,) query
113+
114+
115+tabulate :: (a -> k) -> a -> Tabulation k a
116+tabulate key a = fromQuery $ pure (key a, a)
117+
118+
119+tabulateA :: (a -> Query k) -> a -> Tabulation k a
120+tabulateA key a = fromQuery $ (,a) <$> key a
121+
122+
123+fromQuery :: Query (k, a) -> Tabulation k a
124+fromQuery = Tabulation . const . fmap (first Just)
125+
126+
127+indexed :: Tabulation k a -> Tabulation k (k, a)
128+indexed (Tabulation query) = Tabulation $ \i ->
129+ (\(mk, a) -> (mk, (fromMaybe i mk, a))) <$> query i
130+
131+
132+ifilter :: (k -> a -> Expr Bool) -> Tabulation k a -> Tabulation k a
133+ifilter f tabulation = snd <$> do
134+ filter (uncurry f) `postbind` indexed tabulation
135+
136+
137+prebind :: (a -> Tabulation k b) -> Query a -> Tabulation k b
138+prebind f as = Tabulation $ \k -> do
139+ a <- as
140+ case f a of
141+ Tabulation query -> query k
142+infixr 1 `prebind`
143+
144+
145+postbind :: (a -> Query b) -> Tabulation k a -> Tabulation k b
146+postbind f (Tabulation as) = Tabulation $ \i -> do
147+ (k, a) <- as i
148+ case f a of
149+ bs -> do
150+ b <- bs
151+ pure (k, b)
152+infixr 1 `postbind`
153+
154+
155+lookup :: EqTable k => k -> Tabulation k a -> Query a
156+lookup key (Tabulation query) = do
157+ (mk, a) <- query key
158+ traverse_ (where_ . (key ==:)) mk
159+ pure a
160+
161+
162+align :: (EqTable k, Table DB a, Table DB b)
163+ => Tabulation k a -> Tabulation k b -> Tabulation k (TheseTable a b)
164+align = alignWith id
165+
166+
167+alignWith :: (EqTable k, Table DB a, Table DB b)
168+ => (TheseTable a b -> c)
169+ -> Tabulation k a -> Tabulation k b -> Tabulation k c
170+alignWith f kas kbs = do
171+ as <- toQuery kas
172+ bs <- toQuery kbs
173+ fromQuery $ do
174+ tkab <- alignBy (\(l, _) (m, _) -> l ==: m) as bs
175+ let
176+ k' = theseTable fst fst (const fst) tkab
177+ tab = bimap snd snd tkab
178+ pure (k', f tab)
179+
180+
181+leftAlign :: EqTable k
182+ => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable b)
183+leftAlign = leftAlignWith (,)
184+
185+
186+leftAlignWith :: EqTable k
187+ => (a -> MaybeTable b -> c)
188+ -> Tabulation k a -> Tabulation k b -> Tabulation k c
189+leftAlignWith f left right = liftA2 f left (optionalTabulation right)
190+
191+
192+zip :: EqTable k
193+ => Tabulation k a -> Tabulation k b -> Tabulation k (a, b)
194+zip = zipWith (,)
195+
196+
197+zipWith :: EqTable k
198+ => (a -> b -> c) -> Tabulation k a -> Tabulation k b -> Tabulation k c
199+zipWith = liftA2
200+
201+
202+similarity :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
203+similarity kas kbs = do
204+ as <- toQuery kas
205+ bs <- toQuery kbs
206+ fromQuery $ as >>= withBy (\(k, _) (l, _) -> k ==: l) bs
207+
208+
209+difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
210+difference kas kbs = do
211+ as <- toQuery kas
212+ bs <- toQuery kbs
213+ fromQuery $ as >>= withoutBy (\(k, _) (l, _) -> k ==: l) bs
214+
215+
216+aggregateTabulation :: EqTable k
217+ => Tabulation k (Aggregate a) -> Tabulation k a
218+aggregateTabulation kas = do
219+ as <- toQuery kas
220+ fromQuery $ aggregate $ bitraverse1 groupBy id <$> as
221+
222+
223+optionalTabulation :: EqTable k
224+ => Tabulation k a -> Tabulation k (MaybeTable a)
225+optionalTabulation as = Tabulation $ \k -> do
226+ ma <- optional $ lookup k as
227+ pure (Just k, ma)
228+
229+
230+toQuery :: Tabulation k a -> Tabulation k (Query (k, a))
231+toQuery (Tabulation as) = Tabulation $ \k ->
232+ pure (Nothing, first (fromMaybe k) <$> as k)
src/Rel8/Type.hsnew file+255
@@ -0,0 +1,255 @@
1+{-# language FlexibleInstances #-}
2+{-# language StandaloneKindSignatures #-}
3+{-# language TypeApplications #-}
4+{-# language UndecidableInstances #-}
5+
6+module Rel8.Type
7+ ( DBType (typeInformation)
8+ )
9+where
10+
11+-- aeson
12+import Data.Aeson ( Value )
13+import qualified Data.Aeson as Aeson
14+
15+-- base
16+import Data.Int ( Int16, Int32, Int64 )
17+import Data.List.NonEmpty ( NonEmpty )
18+import Data.Kind ( Constraint, Type )
19+import Prelude
20+
21+-- bytestring
22+import Data.ByteString ( ByteString )
23+import qualified Data.ByteString.Lazy as Lazy ( ByteString )
24+import qualified Data.ByteString.Lazy as ByteString ( fromStrict, toStrict )
25+
26+-- case-insensitive
27+import Data.CaseInsensitive ( CI )
28+import qualified Data.CaseInsensitive as CI
29+
30+-- hasql
31+import qualified Hasql.Decoders as Hasql
32+
33+-- opaleye
34+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
35+import qualified Opaleye.Internal.HaskellDB.Sql.Default as Opaleye ( quote )
36+
37+-- rel8
38+import Rel8.Opaque ( Opaque )
39+import Rel8.Schema.Nullability ( Nullabilizes, nullabilization )
40+import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
41+import Rel8.Type.Information ( TypeInformation(..), mapTypeInformation )
42+
43+-- scientific
44+import Data.Scientific ( Scientific )
45+
46+-- text
47+import Data.Text ( Text )
48+import qualified Data.Text as Text
49+import qualified Data.Text.Lazy as Lazy ( Text, unpack )
50+import qualified Data.Text.Lazy as Text ( fromStrict, toStrict )
51+import qualified Data.Text.Lazy.Encoding as Lazy ( decodeUtf8 )
52+
53+-- time
54+import Data.Time.Calendar ( Day )
55+import Data.Time.Clock ( DiffTime, NominalDiffTime, UTCTime )
56+import Data.Time.LocalTime ( LocalTime, TimeOfDay )
57+import Data.Time.Format ( formatTime, defaultTimeLocale )
58+
59+-- uuid
60+import Data.UUID ( UUID )
61+import qualified Data.UUID as UUID
62+
63+
64+type DBType :: Type -> Constraint
65+class DBType a where
66+ typeInformation :: TypeInformation a
67+
68+
69+instance DBType Bool where
70+ typeInformation = TypeInformation
71+ { encode = Opaleye.ConstExpr . Opaleye.BoolLit
72+ , decode = Hasql.bool
73+ , typeName = "bool"
74+ }
75+
76+
77+instance DBType Char where
78+ typeInformation = TypeInformation
79+ { encode = Opaleye.ConstExpr . Opaleye.StringLit . pure
80+ , decode = Hasql.char
81+ , typeName = "char"
82+ }
83+
84+
85+instance DBType Int16 where
86+ typeInformation = TypeInformation
87+ { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger
88+ , decode = Hasql.int2
89+ , typeName = "int2"
90+ }
91+
92+
93+instance DBType Int32 where
94+ typeInformation = TypeInformation
95+ { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger
96+ , decode = Hasql.int4
97+ , typeName = "int4"
98+ }
99+
100+
101+instance DBType Int64 where
102+ typeInformation = TypeInformation
103+ { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger
104+ , decode = Hasql.int8
105+ , typeName = "int8"
106+ }
107+
108+
109+instance DBType Float where
110+ typeInformation = TypeInformation
111+ { encode = Opaleye.ConstExpr . Opaleye.NumericLit . realToFrac
112+ , decode = Hasql.float4
113+ , typeName = "float4"
114+ }
115+
116+
117+instance DBType Double where
118+ typeInformation = TypeInformation
119+ { encode = Opaleye.ConstExpr . Opaleye.NumericLit . realToFrac
120+ , decode = Hasql.float8
121+ , typeName = "float8"
122+ }
123+
124+
125+instance DBType Scientific where
126+ typeInformation = TypeInformation
127+ { encode = Opaleye.ConstExpr . Opaleye.NumericLit
128+ , decode = Hasql.numeric
129+ , typeName = "numeric"
130+ }
131+
132+
133+instance DBType UTCTime where
134+ typeInformation = TypeInformation
135+ { encode =
136+ Opaleye.ConstExpr . Opaleye.OtherLit .
137+ formatTime defaultTimeLocale "'%FT%T%QZ'"
138+ , decode = Hasql.timestamptz
139+ , typeName = "timestamptz"
140+ }
141+
142+
143+instance DBType Day where
144+ typeInformation = TypeInformation
145+ { encode =
146+ Opaleye.ConstExpr . Opaleye.OtherLit .
147+ formatTime defaultTimeLocale "'%F'"
148+ , decode = Hasql.date
149+ , typeName = "date"
150+ }
151+
152+
153+instance DBType LocalTime where
154+ typeInformation = TypeInformation
155+ { encode =
156+ Opaleye.ConstExpr . Opaleye.OtherLit .
157+ formatTime defaultTimeLocale "'%FT%T%Q'"
158+ , decode = Hasql.timestamp
159+ , typeName = "timestamp"
160+ }
161+
162+
163+instance DBType TimeOfDay where
164+ typeInformation = TypeInformation
165+ { encode =
166+ Opaleye.ConstExpr . Opaleye.OtherLit .
167+ formatTime defaultTimeLocale "'%T%Q'"
168+ , decode = Hasql.time
169+ , typeName = "time"
170+ }
171+
172+
173+instance DBType DiffTime where
174+ typeInformation = TypeInformation
175+ { encode =
176+ Opaleye.ConstExpr . Opaleye.OtherLit .
177+ formatTime defaultTimeLocale "'%-6Es'"
178+ , decode = Hasql.interval
179+ , typeName = "interval"
180+ }
181+
182+
183+instance DBType NominalDiffTime where
184+ typeInformation =
185+ mapTypeInformation @DiffTime realToFrac realToFrac typeInformation
186+
187+
188+instance DBType Text where
189+ typeInformation = TypeInformation
190+ { encode = Opaleye.ConstExpr . Opaleye.StringLit . Text.unpack
191+ , decode = Hasql.text
192+ , typeName = "text"
193+ }
194+
195+
196+instance DBType Lazy.Text where
197+ typeInformation =
198+ mapTypeInformation Text.fromStrict Text.toStrict typeInformation
199+
200+
201+instance DBType (CI Text) where
202+ typeInformation = mapTypeInformation CI.mk CI.original typeInformation
203+ { typeName = "citext"
204+ }
205+
206+
207+instance DBType (CI Lazy.Text) where
208+ typeInformation = mapTypeInformation CI.mk CI.original typeInformation
209+ { typeName = "citext"
210+ }
211+
212+
213+instance DBType ByteString where
214+ typeInformation = TypeInformation
215+ { encode = Opaleye.ConstExpr . Opaleye.ByteStringLit
216+ , decode = Hasql.bytea
217+ , typeName = "bytea"
218+ }
219+
220+
221+instance DBType Lazy.ByteString where
222+ typeInformation =
223+ mapTypeInformation ByteString.fromStrict ByteString.toStrict
224+ typeInformation
225+
226+
227+instance DBType UUID where
228+ typeInformation = TypeInformation
229+ { encode = Opaleye.ConstExpr . Opaleye.StringLit . UUID.toString
230+ , decode = Hasql.uuid
231+ , typeName = "uuid"
232+ }
233+
234+
235+instance DBType Value where
236+ typeInformation = TypeInformation
237+ { encode =
238+ Opaleye.ConstExpr . Opaleye.OtherLit .
239+ Opaleye.quote .
240+ Lazy.unpack . Lazy.decodeUtf8 . Aeson.encode
241+ , decode = Hasql.jsonb
242+ , typeName = "jsonb"
243+ }
244+
245+
246+instance (DBType db, Nullabilizes db a) => DBType [a] where
247+ typeInformation = listTypeInformation nullabilization typeInformation
248+
249+
250+instance (DBType db, Nullabilizes db a) => DBType (NonEmpty a) where
251+ typeInformation = nonEmptyTypeInformation nullabilization typeInformation
252+
253+
254+instance {-# OVERLAPPING #-} DBType Opaque where
255+ typeInformation = error "opaque"
src/Rel8/Type/Array.hsnew file+63
@@ -0,0 +1,63 @@
1+{-# language GADTs #-}
2+{-# language NamedFieldPuns #-}
3+{-# language OverloadedStrings #-}
4+
5+module Rel8.Type.Array
6+ ( array
7+ , listTypeInformation
8+ , nonEmptyTypeInformation
9+ )
10+where
11+
12+-- base
13+import Data.Foldable ( toList )
14+import Data.List.NonEmpty ( NonEmpty, nonEmpty )
15+import Prelude hiding ( null, repeat, zipWith )
16+
17+-- hasql
18+import qualified Hasql.Decoders as Hasql
19+
20+-- opaleye
21+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
22+
23+-- rel8
24+import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )
25+import Rel8.Type.Information ( TypeInformation(..), parseTypeInformation )
26+
27+
28+array :: Foldable f
29+ => TypeInformation a -> f Opaleye.PrimExpr -> Opaleye.PrimExpr
30+array TypeInformation {typeName} =
31+ Opaleye.UnExpr (Opaleye.UnOpOther "ROW") .
32+ Opaleye.CastExpr (typeName <> "[]") .
33+ Opaleye.ArrayExpr . toList
34+
35+
36+listTypeInformation :: ()
37+ => Nullability a ma
38+ -> TypeInformation a
39+ -> TypeInformation [ma]
40+listTypeInformation nullability info = TypeInformation
41+ { decode = row $ case nullability of
42+ Nullable -> Hasql.listArray (Hasql.nullable decode)
43+ NonNullable -> Hasql.listArray (Hasql.nonNullable decode)
44+ , encode = case nullability of
45+ Nullable -> array info . fmap (maybe null encode)
46+ NonNullable -> array info . fmap encode
47+ , typeName = "record"
48+ }
49+ where
50+ TypeInformation {encode, decode} = info
51+ row = Hasql.composite . Hasql.field . Hasql.nonNullable
52+ null = Opaleye.ConstExpr Opaleye.NullLit
53+
54+
55+nonEmptyTypeInformation :: ()
56+ => Nullability a ma
57+ -> TypeInformation a
58+ -> TypeInformation (NonEmpty ma)
59+nonEmptyTypeInformation nullability =
60+ parseTypeInformation parse toList . listTypeInformation nullability
61+ where
62+ parse = maybe (Left message) Right . nonEmpty
63+ message = "failed to decode NonEmptyList: got empty list"
src/Rel8/Type/Eq.hsnew file+76
@@ -0,0 +1,76 @@
1+{-# language FlexibleContexts #-}
2+{-# language FlexibleInstances #-}
3+{-# language StandaloneKindSignatures #-}
4+{-# language UndecidableInstances #-}
5+
6+module Rel8.Type.Eq
7+ ( DBEq
8+ )
9+where
10+
11+-- aeson
12+import Data.Aeson ( Value )
13+
14+-- base
15+import Data.List.NonEmpty ( NonEmpty )
16+import Data.Int ( Int16, Int32, Int64 )
17+import Data.Kind ( Constraint, Type )
18+import Prelude
19+
20+-- bytestring
21+import Data.ByteString ( ByteString )
22+import qualified Data.ByteString.Lazy as Lazy ( ByteString )
23+
24+-- case-insensitive
25+import Data.CaseInsensitive ( CI )
26+
27+-- rel8
28+import Rel8.Opaque ( Opaque )
29+import Rel8.Schema.Nullability ( Nullabilizes )
30+import Rel8.Type ( DBType )
31+
32+-- scientific
33+import Data.Scientific ( Scientific )
34+
35+-- text
36+import Data.Text ( Text )
37+import qualified Data.Text.Lazy as Lazy ( Text )
38+
39+-- time
40+import Data.Time.Calendar ( Day )
41+import Data.Time.Clock ( UTCTime, DiffTime, NominalDiffTime )
42+import Data.Time.LocalTime ( TimeOfDay, LocalTime )
43+
44+-- uuid
45+import Data.UUID ( UUID )
46+
47+
48+type DBEq :: Type -> Constraint
49+class DBType a => DBEq a
50+
51+
52+instance DBEq Bool
53+instance DBEq Char
54+instance DBEq Int16
55+instance DBEq Int32
56+instance DBEq Int64
57+instance DBEq Float
58+instance DBEq Double
59+instance DBEq Scientific
60+instance DBEq UTCTime
61+instance DBEq Day
62+instance DBEq LocalTime
63+instance DBEq TimeOfDay
64+instance DBEq DiffTime
65+instance DBEq NominalDiffTime
66+instance DBEq Text
67+instance DBEq Lazy.Text
68+instance DBEq (CI Text)
69+instance DBEq (CI Lazy.Text)
70+instance DBEq ByteString
71+instance DBEq Lazy.ByteString
72+instance DBEq UUID
73+instance DBEq Value
74+instance (DBEq db, Nullabilizes db a) => DBEq [a]
75+instance (DBEq db, Nullabilizes db a) => DBEq (NonEmpty a)
76+instance DBEq Opaque
src/Rel8/Type/Information.hsnew file+48
@@ -0,0 +1,48 @@
1+{-# language NamedFieldPuns #-}
2+{-# language StandaloneKindSignatures #-}
3+
4+module Rel8.Type.Information
5+ ( TypeInformation(..)
6+ , mapTypeInformation
7+ , parseTypeInformation
8+ )
9+where
10+
11+-- base
12+import Data.Bifunctor ( first )
13+import Data.Kind ( Type )
14+import Prelude
15+
16+-- hasql
17+import qualified Hasql.Decoders as Hasql
18+
19+-- opaleye
20+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
21+
22+-- text
23+import qualified Data.Text as Text
24+
25+
26+type TypeInformation :: Type -> Type
27+data TypeInformation a = TypeInformation
28+ { encode :: a -> Opaleye.PrimExpr
29+ , decode :: Hasql.Value a
30+ , typeName :: String
31+ }
32+
33+
34+mapTypeInformation :: ()
35+ => (a -> b) -> (b -> a)
36+ -> TypeInformation a -> TypeInformation b
37+mapTypeInformation = parseTypeInformation . fmap pure
38+
39+
40+parseTypeInformation :: ()
41+ => (a -> Either String b) -> (b -> a)
42+ -> TypeInformation a -> TypeInformation b
43+parseTypeInformation to from TypeInformation {encode, decode, typeName} =
44+ TypeInformation
45+ { encode = encode . from
46+ , decode = Hasql.refine (first Text.pack . to) decode
47+ , typeName
48+ }
src/Rel8/Type/Monoid.hsnew file+79
@@ -0,0 +1,79 @@
1+{-# language DataKinds #-}
2+{-# language FlexibleContexts #-}
3+{-# language FlexibleInstances #-}
4+{-# language OverloadedStrings #-}
5+{-# language StandaloneKindSignatures #-}
6+{-# language TypeFamilies #-}
7+{-# language UndecidableInstances #-}
8+
9+module Rel8.Type.Monoid
10+ ( DBMonoid( memptyExpr )
11+ )
12+where
13+
14+-- base
15+import Data.Kind ( Constraint, Type )
16+import Prelude hiding ( null )
17+
18+-- bytestring
19+import Data.ByteString ( ByteString )
20+import qualified Data.ByteString.Lazy as Lazy ( ByteString )
21+
22+-- case-insensitive
23+import Data.CaseInsensitive ( CI )
24+
25+-- rel8
26+import {-# SOURCE #-} Rel8.Expr ( Expr )
27+import Rel8.Expr.Array ( sempty )
28+import Rel8.Expr.Serialize ( litExpr )
29+import Rel8.Schema.Nullability ( Nullabilizes, nullabilization )
30+import Rel8.Type ( DBType, typeInformation )
31+import Rel8.Type.Semigroup ( DBSemigroup )
32+
33+-- text
34+import Data.Text ( Text )
35+import qualified Data.Text.Lazy as Lazy ( Text )
36+
37+-- time
38+import Data.Time.Clock ( DiffTime, NominalDiffTime )
39+
40+
41+type DBMonoid :: Type -> Constraint
42+class DBSemigroup a => DBMonoid a where
43+ memptyExpr :: Expr a
44+
45+
46+instance (DBType db, Nullabilizes db a) => DBMonoid [a] where
47+ memptyExpr = sempty nullabilization typeInformation
48+
49+
50+instance DBMonoid DiffTime where
51+ memptyExpr = litExpr 0
52+
53+
54+instance DBMonoid NominalDiffTime where
55+ memptyExpr = litExpr 0
56+
57+
58+instance DBMonoid Text where
59+ memptyExpr = litExpr ""
60+
61+
62+instance DBMonoid Lazy.Text where
63+ memptyExpr = litExpr ""
64+
65+
66+instance DBMonoid (CI Text) where
67+ memptyExpr = litExpr ""
68+
69+
70+instance DBMonoid (CI Lazy.Text) where
71+ memptyExpr = litExpr ""
72+
73+
74+instance DBMonoid ByteString where
75+ memptyExpr = litExpr ""
76+
77+
78+instance DBMonoid Lazy.ByteString where
79+ memptyExpr = litExpr ""
src/Rel8/Type/Num.hsnew file+44
@@ -0,0 +1,44 @@
1+{-# language DataKinds #-}
2+{-# language StandaloneKindSignatures #-}
3+{-# language TypeFamilies #-}
4+
5+module Rel8.Type.Num
6+ ( DBNum, DBIntegral, DBFractional
7+ )
8+where
9+
10+-- base
11+import Data.Int ( Int16, Int32, Int64 )
12+import Data.Kind ( Constraint, Type )
13+import Prelude
14+
15+-- rel8
16+import Rel8.Kind.Bool ( IsList )
17+import Rel8.Type ( DBType )
18+
19+-- scientific
20+import Data.Scientific ( Scientific )
21+
22+
23+type DBNum :: Type -> Constraint
24+class (DBType a, IsList a ~ 'False) => DBNum a
25+instance DBNum Int16
26+instance DBNum Int32
27+instance DBNum Int64
28+instance DBNum Float
29+instance DBNum Double
30+instance DBNum Scientific
31+
32+
33+type DBIntegral :: Type -> Constraint
34+class DBNum a => DBIntegral a
35+instance DBIntegral Int16
36+instance DBIntegral Int32
37+instance DBIntegral Int64
38+
39+
40+type DBFractional :: Type -> Constraint
41+class DBNum a => DBFractional a
42+instance DBFractional Float
43+instance DBFractional Double
44+instance DBFractional Scientific
src/Rel8/Type/Ord.hsnew file+123
@@ -0,0 +1,123 @@
1+{-# language FlexibleContexts #-}
2+{-# language FlexibleInstances #-}
3+{-# language StandaloneKindSignatures #-}
4+{-# language UndecidableInstances #-}
5+
6+module Rel8.Type.Ord
7+ ( DBOrd
8+ , DBMax, DBMin
9+ )
10+where
11+
12+-- base
13+import Data.Int ( Int16, Int32, Int64 )
14+import Data.Kind ( Constraint, Type )
15+import Data.List.NonEmpty ( NonEmpty )
16+import Prelude
17+
18+-- bytestring
19+import Data.ByteString ( ByteString )
20+import qualified Data.ByteString.Lazy as Lazy ( ByteString )
21+
22+-- case-insensitive
23+import Data.CaseInsensitive ( CI )
24+
25+-- rel8
26+import Rel8.Opaque ( Opaque )
27+import Rel8.Schema.Nullability ( Nullabilizes )
28+import Rel8.Type.Eq ( DBEq )
29+
30+-- scientific
31+import Data.Scientific ( Scientific )
32+
33+-- text
34+import Data.Text ( Text )
35+import qualified Data.Text.Lazy as Lazy ( Text )
36+
37+-- time
38+import Data.Time.Calendar ( Day )
39+import Data.Time.Clock ( DiffTime, NominalDiffTime, UTCTime )
40+import Data.Time.LocalTime ( TimeOfDay, LocalTime )
41+
42+-- uuid
43+import Data.UUID ( UUID )
44+
45+
46+type DBOrd :: Type -> Constraint
47+class DBEq a => DBOrd a
48+instance DBOrd Bool
49+instance DBOrd Char
50+instance DBOrd Int16
51+instance DBOrd Int32
52+instance DBOrd Int64
53+instance DBOrd Float
54+instance DBOrd Double
55+instance DBOrd Scientific
56+instance DBOrd UTCTime
57+instance DBOrd Day
58+instance DBOrd LocalTime
59+instance DBOrd TimeOfDay
60+instance DBOrd DiffTime
61+instance DBOrd NominalDiffTime
62+instance DBOrd Text
63+instance DBOrd Lazy.Text
64+instance DBOrd (CI Text)
65+instance DBOrd (CI Lazy.Text)
66+instance DBOrd ByteString
67+instance DBOrd Lazy.ByteString
68+instance DBOrd UUID
69+instance (DBOrd db, Nullabilizes db a) => DBOrd [a]
70+instance (DBOrd db, Nullabilizes db a) => DBOrd (NonEmpty a)
71+instance {-# OVERLAPPING #-} DBOrd Opaque
72+
73+
74+type DBMax :: Type -> Constraint
75+class DBOrd a => DBMax a
76+instance DBMax Bool
77+instance DBMax Char
78+instance DBMax Int16
79+instance DBMax Int32
80+instance DBMax Int64
81+instance DBMax Float
82+instance DBMax Double
83+instance DBMax Scientific
84+instance DBMax UTCTime
85+instance DBMax Day
86+instance DBMax LocalTime
87+instance DBMax TimeOfDay
88+instance DBMax DiffTime
89+instance DBMax NominalDiffTime
90+instance DBMax Text
91+instance DBMax Lazy.Text
92+instance DBMax (CI Text)
93+instance DBMax (CI Lazy.Text)
94+instance DBMax ByteString
95+instance DBMax Lazy.ByteString
96+instance (DBMax db, Nullabilizes db a) => DBMax [a]
97+instance (DBMax db, Nullabilizes db a) => DBMax (NonEmpty a)
98+
99+
100+type DBMin :: Type -> Constraint
101+class DBOrd a => DBMin a
102+instance DBMin Bool
103+instance DBMin Char
104+instance DBMin Int16
105+instance DBMin Int32
106+instance DBMin Int64
107+instance DBMin Float
108+instance DBMin Double
109+instance DBMin Scientific
110+instance DBMin UTCTime
111+instance DBMin Day
112+instance DBMin LocalTime
113+instance DBMin TimeOfDay
114+instance DBMin DiffTime
115+instance DBMin NominalDiffTime
116+instance DBMin Text
117+instance DBMin Lazy.Text
118+instance DBMin (CI Text)
119+instance DBMin (CI Lazy.Text)
120+instance DBMin ByteString
121+instance DBMin Lazy.ByteString
122+instance (DBMin db, Nullabilizes db a) => DBMin [a]
123+instance (DBMin db, Nullabilizes db a) => DBMin (NonEmpty a)
src/Rel8/Type/Semigroup.hsnew file+87
@@ -0,0 +1,87 @@
1+{-# language DataKinds #-}
2+{-# language FlexibleContexts #-}
3+{-# language FlexibleInstances #-}
4+{-# language ScopedTypeVariables #-}
5+{-# language StandaloneKindSignatures #-}
6+{-# language TypeApplications #-}
7+{-# language TypeFamilies #-}
8+{-# language UndecidableInstances #-}
9+
10+module Rel8.Type.Semigroup
11+ ( DBSemigroup( (<>.))
12+ )
13+where
14+
15+-- base
16+import Data.Kind ( Constraint, Type )
17+import Data.List.NonEmpty ( NonEmpty )
18+import Prelude ()
19+
20+-- bytestring
21+import Data.ByteString ( ByteString )
22+import qualified Data.ByteString.Lazy as Lazy ( ByteString )
23+
24+-- case-insensitive
25+import Data.CaseInsensitive ( CI )
26+
27+-- opaleye
28+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
29+
30+-- rel8
31+import {-# SOURCE #-} Rel8.Expr ( Expr )
32+import Rel8.Expr.Opaleye ( zipPrimExprsWith )
33+import Rel8.Schema.Nullability ( Nullabilizes )
34+import Rel8.Type ( DBType )
35+
36+-- text
37+import Data.Text ( Text )
38+import qualified Data.Text.Lazy as Lazy ( Text )
39+
40+-- time
41+import Data.Time.Clock ( DiffTime, NominalDiffTime )
42+
43+
44+type DBSemigroup :: Type -> Constraint
45+class DBType a => DBSemigroup a where
46+ (<>.) :: Expr a -> Expr a -> Expr a
47+ infixr 6 <>.
48+
49+
50+instance (DBType db, Nullabilizes db a) => DBSemigroup [a] where
51+ (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
52+
53+
54+instance (DBType db, Nullabilizes db a) => DBSemigroup (NonEmpty a) where
55+ (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
56+
57+
58+instance DBSemigroup DiffTime where
59+ (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:+))
60+
61+
62+instance DBSemigroup NominalDiffTime where
63+ (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:+))
64+
65+
66+instance DBSemigroup Text where
67+ (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
68+
69+
70+instance DBSemigroup Lazy.Text where
71+ (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
72+
73+
74+instance DBSemigroup (CI Text) where
75+ (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
76+
77+
78+instance DBSemigroup (CI Lazy.Text) where
79+ (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
80+
81+
82+instance DBSemigroup ByteString where
83+ (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
84+
85+
86+instance DBSemigroup Lazy.ByteString where
87+ (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
src/Rel8/Type/String.hsnew file+35
@@ -0,0 +1,35 @@
1+{-# language FlexibleInstances #-}
2+{-# language StandaloneKindSignatures #-}
3+
4+module Rel8.Type.String
5+ ( DBString
6+ )
7+where
8+
9+-- base
10+import Data.Kind ( Constraint, Type )
11+import Prelude ()
12+
13+-- bytestring
14+import Data.ByteString ( ByteString )
15+import qualified Data.ByteString.Lazy as Lazy ( ByteString )
16+
17+-- case-insensitive
18+import Data.CaseInsensitive ( CI )
19+
20+-- rel8
21+import Rel8.Type ( DBType )
22+
23+-- text
24+import Data.Text ( Text )
25+import qualified Data.Text.Lazy as Lazy ( Text )
26+
27+
28+type DBString :: Type -> Constraint
29+class DBType a => DBString a
30+instance DBString Text
31+instance DBString Lazy.Text
32+instance DBString (CI Text)
33+instance DBString (CI Lazy.Text)
34+instance DBString ByteString
35+instance DBString Lazy.ByteString
src/Rel8/Type/Sum.hsnew file+35
@@ -0,0 +1,35 @@
1+{-# language DataKinds #-}
2+{-# language TypeFamilies #-}
3+{-# language StandaloneKindSignatures #-}
4+
5+module Rel8.Type.Sum
6+ ( DBSum
7+ )
8+where
9+
10+-- base
11+import Data.Int ( Int16, Int32, Int64 )
12+import Data.Kind ( Constraint, Type )
13+import Prelude
14+
15+-- rel8
16+import Rel8.Kind.Bool ( IsList )
17+import Rel8.Type ( DBType )
18+
19+-- scientific
20+import Data.Scientific ( Scientific )
21+
22+-- time
23+import Data.Time.Clock ( DiffTime, NominalDiffTime )
24+
25+
26+type DBSum :: Type -> Constraint
27+class (DBType a, IsList a ~ 'False) => DBSum a
28+instance DBSum Int16
29+instance DBSum Int32
30+instance DBSum Int64
31+instance DBSum Float
32+instance DBSum Double
33+instance DBSum Scientific
34+instance DBSum DiffTime
35+instance DBSum NominalDiffTime
src/Rel8/Type/Tag.hsnew file+85
@@ -0,0 +1,85 @@
1+{-# language DataKinds #-}
2+{-# language DeriveAnyClass #-}
3+{-# language DerivingVia #-}
4+{-# language StandaloneKindSignatures #-}
5+
6+module Rel8.Type.Tag
7+ ( EitherTag( IsLeft, IsRight ), isLeft, isRight
8+ , MaybeTag( IsJust )
9+ )
10+where
11+
12+-- base
13+import Data.Bool ( bool )
14+import Data.Kind ( Type )
15+import Data.Semigroup ( Min( Min ) )
16+import Prelude
17+
18+-- opaleye
19+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
20+
21+-- rel8
22+import Rel8.Expr ( Expr )
23+import Rel8.Expr.Eq ( (==.) )
24+import Rel8.Expr.Opaleye ( zipPrimExprsWith )
25+import Rel8.Expr.Serialize ( litExpr )
26+import Rel8.Type.Eq ( DBEq )
27+import Rel8.Type ( DBType, typeInformation )
28+import Rel8.Type.Information ( mapTypeInformation, parseTypeInformation )
29+import Rel8.Type.Monoid ( DBMonoid, memptyExpr )
30+import Rel8.Type.Ord ( DBOrd )
31+import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )
32+
33+
34+type EitherTag :: Type
35+data EitherTag = IsLeft | IsRight
36+ deriving stock (Eq, Ord, Read, Show, Enum, Bounded)
37+ deriving (Semigroup, Monoid) via (Min EitherTag)
38+ deriving anyclass (DBEq, DBOrd)
39+
40+
41+instance DBType EitherTag where
42+ typeInformation = mapTypeInformation to from typeInformation
43+ where
44+ to = bool IsLeft IsRight
45+ from IsLeft = False
46+ from IsRight = True
47+
48+
49+instance DBSemigroup EitherTag where
50+ (<>.) = zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpAnd)
51+
52+
53+instance DBMonoid EitherTag where
54+ memptyExpr = litExpr mempty
55+
56+
57+isLeft :: Expr EitherTag -> Expr Bool
58+isLeft = (litExpr IsLeft ==.)
59+
60+
61+isRight :: Expr EitherTag -> Expr Bool
62+isRight = (litExpr IsLeft ==.)
63+
64+
65+type MaybeTag :: Type
66+data MaybeTag = IsJust
67+ deriving stock (Eq, Ord, Read, Show, Enum, Bounded)
68+ deriving (Semigroup, Monoid) via (Min MaybeTag)
69+ deriving anyclass (DBEq, DBOrd)
70+
71+
72+instance DBType MaybeTag where
73+ typeInformation = parseTypeInformation to from typeInformation
74+ where
75+ to False = Left "MaybeTag can't be false"
76+ to True = Right IsJust
77+ from _ = True
78+
79+
80+instance DBSemigroup MaybeTag where
81+ (<>.) = zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpAnd)
82+
83+
84+instance DBMonoid MaybeTag where
85+ memptyExpr = litExpr mempty
tests/Main.hsnew file+786
@@ -0,0 +1,786 @@
1+{-# language BlockArguments #-}
2+{-# language BlockArguments #-}
3+{-# language DataKinds #-}
4+{-# language DeriveAnyClass #-}
5+{-# language DeriveGeneric #-}
6+{-# language DerivingStrategies #-}
7+{-# language DisambiguateRecordFields #-}
8+{-# language FlexibleContexts #-}
9+{-# language FlexibleInstances #-}
10+{-# language GADTs #-}
11+{-# language NamedFieldPuns #-}
12+{-# language OverloadedStrings #-}
13+{-# language RecordWildCards #-}
14+{-# language ScopedTypeVariables #-}
15+{-# language StandaloneDeriving #-}
16+{-# language TypeApplications #-}
17+
18+{-# options_ghc -fno-warn-redundant-constraints #-}
19+
20+module Main
21+ ( main
22+ )
23+where
24+
25+-- base
26+import Control.Applicative ( liftA2, liftA3 )
27+import Control.Monad (void)
28+import Control.Monad.IO.Class ( MonadIO, liftIO )
29+import Data.Bifunctor ( bimap )
30+import Data.Foldable ( for_ )
31+import Data.Int ( Int32, Int64 )
32+import Data.List ( nub, sort )
33+import Data.Maybe ( catMaybes )
34+import Data.String ( fromString )
35+import Data.Word (Word32)
36+import GHC.Generics ( Generic )
37+
38+-- bytestring
39+import qualified Data.ByteString.Lazy
40+
41+-- case-insensitive
42+import Data.CaseInsensitive (mk)
43+
44+-- containers
45+import qualified Data.Map.Strict as Map
46+
47+-- hasql
48+import Hasql.Connection ( Connection, acquire, release )
49+import Hasql.Session ( sql, run )
50+
51+-- hedgehog
52+import Hedgehog ( property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen )
53+import qualified Hedgehog.Gen as Gen
54+import qualified Hedgehog.Range as Range
55+
56+-- lifted-base
57+import Control.Exception.Lifted ( bracket, throwIO, bracket_ )
58+
59+-- monad-control
60+import Control.Monad.Trans.Control ( MonadBaseControl )
61+
62+-- rel8
63+import qualified Rel8.Expr as Rel8
64+import qualified Rel8.Expr.Bool as Rel8
65+import qualified Rel8.Expr.Eq as Rel8
66+import qualified Rel8.Kind.Nullability as Rel8
67+import qualified Rel8.Query.Aggregate as Rel8
68+import qualified Rel8.Query.Distinct as Rel8
69+import qualified Rel8.Query.Each as Rel8
70+import qualified Rel8.Query.Exists as Rel8
71+import qualified Rel8.Query.Filter as Rel8
72+import qualified Rel8.Query.Limit as Rel8
73+import qualified Rel8.Query.Maybe as Rel8
74+import qualified Rel8.Query.Null as Rel8
75+import qualified Rel8.Query.Set as Rel8
76+import qualified Rel8.Query.Values as Rel8
77+import qualified Rel8.Schema.Column as Rel8
78+import qualified Rel8.Schema.Context as Rel8
79+import qualified Rel8.Schema.Generic as Rel8
80+import qualified Rel8.Schema.Table as Rel8
81+import qualified Rel8.Schema.Value as Rel8
82+import qualified Rel8.Statement.Delete as Rel8
83+import qualified Rel8.Statement.Insert as Rel8
84+import qualified Rel8.Statement.Returning as Rel8
85+import qualified Rel8.Statement.Select as Rel8
86+import qualified Rel8.Statement.Update as Rel8
87+import qualified Rel8.Table.Aggregate as Rel8
88+import qualified Rel8.Table.Bool as Rel8
89+import qualified Rel8.Table.Eq as Rel8
90+import qualified Rel8.Table.Insert as Rel8
91+import qualified Rel8.Table.Maybe as Rel8
92+import qualified Rel8.Table.Serialize as Rel8
93+import qualified Rel8.Type.Eq as Rel8
94+
95+-- scientific
96+import Data.Scientific ( Scientific )
97+
98+-- tasty
99+import Test.Tasty
100+
101+-- tasty-hedgehog
102+import Test.Tasty.Hedgehog ( testProperty )
103+
104+-- text
105+import Data.Text (Text, pack)
106+import qualified Data.Text.Lazy
107+
108+-- time
109+import Data.Time
110+
111+-- tmp-postgres
112+import qualified Database.Postgres.Temp as TmpPostgres
113+
114+-- uuid
115+import qualified Data.UUID
116+
117+
118+main :: IO ()
119+main = defaultMain tests
120+
121+
122+tests :: TestTree
123+tests =
124+ withResource startTestDatabase stopTestDatabase \getTestDatabase ->
125+ testGroup "rel8"
126+ [ testSelectTestTable getTestDatabase
127+ , testWhere_ getTestDatabase
128+ , testFilter getTestDatabase
129+ , testLimit getTestDatabase
130+ , testUnion getTestDatabase
131+ , testDistinct getTestDatabase
132+ , testExists getTestDatabase
133+ , testOptional getTestDatabase
134+ , testAnd getTestDatabase
135+ , testOr getTestDatabase
136+ , testNot getTestDatabase
137+ , testBool getTestDatabase
138+ , testAp getTestDatabase
139+ , testDBType getTestDatabase
140+ , testDBEq getTestDatabase
141+ , testTableEquality getTestDatabase
142+ , testFromString getTestDatabase
143+ , testCatMaybeTable getTestDatabase
144+ , testCatMaybe getTestDatabase
145+ , testMaybeTable getTestDatabase
146+ , testNestedTables getTestDatabase
147+ , testMaybeTableApplicative getTestDatabase
148+ , testLogicalFixities getTestDatabase
149+ , testUpdate getTestDatabase
150+ , testDelete getTestDatabase
151+ , testSelectNestedPairs getTestDatabase
152+ , testSelectArray getTestDatabase
153+ , testNestedMaybeTable getTestDatabase
154+ ]
155+
156+ where
157+
158+ startTestDatabase = do
159+ db <- TmpPostgres.start >>= either throwIO return
160+
161+ bracket (either (error . show) return =<< acquire (TmpPostgres.toConnectionString db)) release \conn -> void do
162+ flip run conn do
163+ sql "CREATE EXTENSION citext"
164+ sql "CREATE TABLE test_table ( column1 text not null, column2 bool not null )"
165+
166+ return db
167+
168+ stopTestDatabase = TmpPostgres.stop
169+
170+
171+databasePropertyTest
172+ :: TestName
173+ -> (((Connection -> TestT IO ()) -> PropertyT IO ()) -> PropertyT IO ())
174+ -> IO TmpPostgres.DB -> TestTree
175+databasePropertyTest testName f getTestDatabase =
176+ withResource connect release $ \c ->
177+ testProperty testName $ property do
178+ connection <- liftIO c
179+ f \g -> test $ rollingBack connection $ g connection
180+
181+ where
182+
183+ connect = either (error . show) return =<< acquire . TmpPostgres.toConnectionString =<< getTestDatabase
184+
185+
186+data TestTable f = TestTable
187+ { testTableColumn1 :: Rel8.Column f Text
188+ , testTableColumn2 :: Rel8.Column f Bool
189+ }
190+ deriving stock Generic
191+ deriving anyclass Rel8.Rel8able
192+
193+
194+deriving stock instance Eq (TestTable Rel8.Result)
195+deriving stock instance Ord (TestTable Rel8.Result)
196+deriving stock instance Show (TestTable Rel8.Result)
197+
198+
199+testTableSchema :: Rel8.TableSchema (TestTable Rel8.Name)
200+testTableSchema =
201+ Rel8.TableSchema
202+ { name = "test_table"
203+ , schema = Nothing
204+ , columns = TestTable
205+ { testTableColumn1 = "column1"
206+ , testTableColumn2 = "column2"
207+ }
208+ }
209+
210+
211+testSelectTestTable :: IO TmpPostgres.DB -> TestTree
212+testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction -> do
213+ rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
214+
215+ transaction \connection -> do
216+ void do
217+ testing Rel8.insert connection
218+ Rel8.Insert
219+ { into = testTableSchema
220+ , rows = map (Rel8.toInsert . Rel8.lit) rows
221+ , onConflict = Rel8.DoNothing
222+ , returning = Rel8.NumberOfRowsAffected
223+ }
224+
225+ selected <- testing Rel8.select connection do
226+ Rel8.each testTableSchema
227+
228+ sort selected === sort rows
229+
230+ cover 1 "Empty" $ null rows
231+ cover 1 "Singleton" $ null $ drop 1 rows
232+ cover 1 ">1 row" $ not $ null $ drop 1 rows
233+
234+
235+testWhere_ :: IO TmpPostgres.DB -> TestTree
236+testWhere_ = databasePropertyTest "WHERE (Rel8.where_)" \transaction -> do
237+ rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable
238+
239+ magicBool <- forAll Gen.bool
240+
241+ let expected = filter (\t -> testTableColumn2 t == magicBool) rows
242+
243+ transaction \connection -> do
244+ selected <- testing Rel8.select connection do
245+ t <- Rel8.values $ Rel8.lit <$> rows
246+ Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool
247+ return t
248+
249+ sort selected === sort expected
250+
251+ cover 1 "No results" $ null expected
252+ cover 1 "Some results" $ not $ null expected
253+ cover 1 "All results" $ expected == rows
254+
255+
256+testFilter :: IO TmpPostgres.DB -> TestTree
257+testFilter = databasePropertyTest "filter" \transaction -> do
258+ rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable
259+
260+ transaction \connection -> do
261+ let expected = filter testTableColumn2 rows
262+
263+ selected <- testing Rel8.select connection
264+ $ Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)
265+
266+ sort selected === sort expected
267+
268+ cover 1 "No results" $ null expected
269+ cover 1 "Some results" $ not $ null expected
270+ cover 1 "All results" $ expected == rows
271+
272+
273+testLimit :: IO TmpPostgres.DB -> TestTree
274+testLimit = databasePropertyTest "LIMIT (Rel8.limit)" \transaction -> do
275+ rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable
276+
277+ n <- forAll $ Gen.integral (Range.linear 0 10)
278+
279+ transaction \connection -> do
280+ selected <- testing Rel8.select connection do
281+ Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)
282+
283+ diff (length selected) (<=) (fromIntegral n)
284+
285+ for_ selected \row ->
286+ diff row elem rows
287+
288+ cover 1 "n == 0" $ n == 0
289+ cover 1 "n < length rows" $ fromIntegral n < length rows
290+ cover 1 "n == length rows" $ fromIntegral n == length rows
291+ cover 1 "n >= length rows" $ fromIntegral n >= length rows
292+
293+
294+testUnion :: IO TmpPostgres.DB -> TestTree
295+testUnion = databasePropertyTest "UNION (Rel8.union)" \transaction -> evalM do
296+ left <- forAll $ Gen.list (Range.linear 0 10) genTestTable
297+ right <- forAll $ Gen.list (Range.linear 0 10) genTestTable
298+
299+ transaction \connection -> do
300+ selected <- testing Rel8.select connection do
301+ Rel8.values (Rel8.lit <$> nub left) `Rel8.union` Rel8.values (Rel8.lit <$> nub right)
302+
303+ sort selected === sort (nub (left ++ right))
304+
305+
306+testDistinct :: IO TmpPostgres.DB -> TestTree
307+testDistinct = databasePropertyTest "DISTINCT (Rel8.distinct)" \transaction -> do
308+ rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
309+
310+ transaction \connection -> do
311+ selected <- testing Rel8.select connection $ Rel8.distinct do
312+ Rel8.values (Rel8.lit <$> rows)
313+
314+ sort selected === nub (sort rows)
315+
316+ cover 1 "Empty" $ null rows
317+ cover 1 "Duplicates" $ not (null rows) && rows /= nub rows
318+ cover 1 "No duplicates" $ not (null rows) && rows == nub rows
319+
320+
321+testExists :: IO TmpPostgres.DB -> TestTree
322+testExists = databasePropertyTest "EXISTS (Rel8.exists)" \transaction -> do
323+ rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
324+
325+ transaction \connection -> do
326+ exists <- testing Rel8.select connection $ Rel8.exists $ Rel8.values $ Rel8.lit <$> rows
327+
328+ case rows of
329+ [] -> exists === [False]
330+ _ -> exists === [True]
331+
332+
333+testOptional :: IO TmpPostgres.DB -> TestTree
334+testOptional = databasePropertyTest "Rel8.optional" \transaction -> do
335+ rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
336+
337+ transaction \connection -> do
338+ selected <- testing Rel8.select connection do
339+ Rel8.optional $ Rel8.values (Rel8.lit <$> rows)
340+
341+ case rows of
342+ [] -> selected === [Nothing]
343+ _ -> sort selected === fmap Just (sort rows)
344+
345+
346+testAnd :: IO TmpPostgres.DB -> TestTree
347+testAnd = databasePropertyTest "AND (&&.)" \transaction -> do
348+ (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool
349+
350+ transaction \connection -> do
351+ [result] <- testing Rel8.select connection $ pure $
352+ Rel8.lit x Rel8.&&. Rel8.lit y
353+
354+ result === (x && y)
355+
356+
357+testOr :: IO TmpPostgres.DB -> TestTree
358+testOr = databasePropertyTest "OR (||.)" \transaction -> do
359+ (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool
360+
361+ transaction \connection -> do
362+ [result] <- testing Rel8.select connection $ pure $
363+ Rel8.lit x Rel8.||. Rel8.lit y
364+
365+ result === (x || y)
366+
367+
368+testLogicalFixities :: IO TmpPostgres.DB -> TestTree
369+testLogicalFixities = databasePropertyTest "Logical operator fixities" \transaction -> do
370+ (u, v, w, x) <- forAll $ (,,,) <$> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool
371+
372+ transaction \connection -> do
373+ [result] <- testing Rel8.select connection $ pure $
374+ Rel8.lit u Rel8.||. Rel8.lit v Rel8.&&. Rel8.lit w Rel8.==. Rel8.lit x
375+
376+ result === (u || v && w == x)
377+
378+
379+testNot :: IO TmpPostgres.DB -> TestTree
380+testNot = databasePropertyTest "NOT (not_)" \transaction -> do
381+ x <- forAll Gen.bool
382+
383+ transaction \connection -> do
384+ [result] <- testing Rel8.select connection $ pure $
385+ Rel8.not_ $ Rel8.lit x
386+
387+ result === not x
388+
389+
390+testBool :: IO TmpPostgres.DB -> TestTree
391+testBool = databasePropertyTest "ifThenElse_" \transaction -> do
392+ (x, y, z) <- forAll $ liftA3 (,,) Gen.bool Gen.bool Gen.bool
393+
394+ transaction \connection -> do
395+ [result] <- testing Rel8.select connection $ pure $
396+ Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x)
397+
398+ result === if x then y else z
399+
400+
401+testAp :: IO TmpPostgres.DB -> TestTree
402+testAp = databasePropertyTest "Cartesian product (<*>)" \transaction -> do
403+ (rows1, rows2) <- forAll $
404+ liftA2 (,)
405+ (Gen.list (Range.linear 1 10) genTestTable)
406+ (Gen.list (Range.linear 1 10) genTestTable)
407+
408+ transaction \connection -> do
409+ result <- testing Rel8.select connection $ do
410+ liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))
411+
412+ sort result === sort (liftA2 (,) rows1 rows2)
413+
414+
415+testDBType :: IO TmpPostgres.DB -> TestTree
416+testDBType getTestDatabase = testGroup "DBType instances"
417+ [ dbTypeTest "Bool" Gen.bool
418+ , dbTypeTest "ByteString" $ Gen.bytes (Range.linear 0 128)
419+ , dbTypeTest "CI Lazy Text" $ mk . Data.Text.Lazy.fromStrict <$> Gen.text (Range.linear 0 10) Gen.unicode
420+ , dbTypeTest "CI Text" $ mk <$> Gen.text (Range.linear 0 10) Gen.unicode
421+ , dbTypeTest "Day" genDay
422+ , dbTypeTest "Double" $ (/10) . fromIntegral @Int @Double <$> Gen.integral (Range.linear (-100) 100)
423+ , dbTypeTest "Float" $ (/10) . fromIntegral @Int @Float <$> Gen.integral (Range.linear (-100) 100)
424+ , dbTypeTest "Int32" $ Gen.integral @_ @Int32 Range.linearBounded
425+ , dbTypeTest "Int64" $ Gen.integral @_ @Int64 Range.linearBounded
426+ , dbTypeTest "Lazy ByteString" $ Data.ByteString.Lazy.fromStrict <$> Gen.bytes (Range.linear 0 128)
427+ , dbTypeTest "Lazy Text" $ Data.Text.Lazy.fromStrict <$> Gen.text (Range.linear 0 10) Gen.unicode
428+ , dbTypeTest "LocalTime" genLocalTime
429+ , dbTypeTest "Scientific" $ (/10) . fromIntegral @Int @Scientific <$> Gen.integral (Range.linear (-100) 100)
430+ , dbTypeTest "Text" $ Gen.text (Range.linear 0 10) Gen.unicode
431+ , dbTypeTest "TimeOfDay" genTimeOfDay
432+ , dbTypeTest "UTCTime" $ UTCTime <$> genDay <*> genDiffTime
433+ , dbTypeTest "UUID" $ Data.UUID.fromWords <$> genWord32 <*> genWord32 <*> genWord32 <*> genWord32
434+ ]
435+
436+ where
437+ dbTypeTest ::
438+ ( Eq a, Show a
439+ , ' ('Rel8.NonNullable, a) ~ Rel8.ToValue a
440+ , Rel8.Serializable (Rel8.Expr 'Rel8.NonNullable a) a
441+ , Rel8.Serializable (Rel8.Expr 'Rel8.Nullable a) (Maybe a)
442+ )
443+ => TestName
444+ -> Gen a
445+ -> TestTree
446+ dbTypeTest name generator = testGroup name
447+ [ databasePropertyTest name (t (==) generator) getTestDatabase
448+ , databasePropertyTest ("Maybe " <> name) (t (==) (Gen.maybe generator)) getTestDatabase
449+ ]
450+
451+ t :: forall a b nullability value.
452+ ( Show a
453+ , '(nullability, value) ~ Rel8.ToValue a
454+ , Rel8.Serializable (Rel8.Expr nullability value) a
455+ )
456+ => (a -> a -> Bool)
457+ -> Gen a
458+ -> ((Connection -> TestT IO ()) -> PropertyT IO b)
459+ -> PropertyT IO b
460+ t eq generator transaction = do
461+ x <- forAll generator
462+
463+ transaction \connection -> do
464+ [res] <- testing Rel8.select connection $ pure (Rel8.lit x :: Rel8.Expr nullability value)
465+ diff res eq x
466+
467+ genDay :: Gen Day
468+ genDay = do
469+ year <- Gen.integral (Range.linear 1970 3000)
470+ month <- Gen.integral (Range.linear 1 12)
471+ day <- Gen.integral (Range.linear 1 31)
472+ Gen.just $ pure $ fromGregorianValid year month day
473+
474+ genDiffTime :: Gen DiffTime
475+ genDiffTime = secondsToDiffTime <$> Gen.integral (Range.linear 0 86401)
476+
477+ genTimeOfDay :: Gen TimeOfDay
478+ genTimeOfDay = do
479+ hour <- Gen.integral (Range.linear 0 23)
480+ minute <- Gen.integral (Range.linear 0 59)
481+ sec <- fromIntegral @Int <$> Gen.integral (Range.linear 0 59)
482+ Gen.just $ pure $ makeTimeOfDayValid hour minute sec
483+
484+ genLocalTime = LocalTime <$> genDay <*> genTimeOfDay
485+
486+ genWord32 :: Gen Word32
487+ genWord32 = Gen.integral Range.linearBounded
488+
489+
490+testDBEq :: IO TmpPostgres.DB -> TestTree
491+testDBEq getTestDatabase = testGroup "DBEq instances"
492+ [ dbEqTest "Bool" Gen.bool
493+ , dbEqTest "Int32" $ Gen.integral @_ @Int32 Range.linearBounded
494+ , dbEqTest "Int64" $ Gen.integral @_ @Int64 Range.linearBounded
495+ , dbEqTest "Text" $ Gen.text (Range.linear 0 10) Gen.unicode
496+ ]
497+
498+ where
499+ dbEqTest ::
500+ ( Eq a, Show a, Rel8.DBEq a
501+ , ' ('Rel8.NonNullable, a) ~ Rel8.ToValue a
502+ , Rel8.Serializable (Rel8.Expr 'Rel8.NonNullable a) a
503+ , Rel8.Serializable (Rel8.Expr 'Rel8.Nullable a) (Maybe a)
504+ )
505+ => TestName
506+ -> Gen a
507+ -> TestTree
508+ dbEqTest name generator = testGroup name
509+ [ databasePropertyTest name (t generator) getTestDatabase
510+ , databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase
511+ ]
512+
513+ t :: forall a nullability value.
514+ ( Eq a
515+ , Show a
516+ , '(nullability, value) ~ Rel8.ToValue a
517+ , Rel8.Serializable (Rel8.Expr nullability value) a
518+ , Rel8.KnownNullability nullability
519+ , Rel8.DBEq value
520+ )
521+ => Gen a
522+ -> ((Connection -> TestT IO ()) -> PropertyT IO ())
523+ -> PropertyT IO ()
524+ t generator transaction = do
525+ (x, y) <- forAll (liftA2 (,) generator generator)
526+
527+ transaction \connection -> do
528+ [res] <- testing Rel8.select connection $ pure $ Rel8.lit @(Rel8.Expr nullability value) x Rel8.==. Rel8.lit y
529+ res === (x == y)
530+
531+ cover 1 "Equal" $ x == y
532+ cover 1 "Not Equal" $ x /= y
533+
534+
535+testTableEquality :: IO TmpPostgres.DB -> TestTree
536+testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do
537+ (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable
538+
539+ transaction \connection -> do
540+ [eq] <- testing Rel8.select connection do
541+ pure $ Rel8.lit x Rel8.==: Rel8.lit y
542+
543+ eq === (x == y)
544+
545+ cover 1 "Equal" $ x == y
546+ cover 1 "Not Equal" $ x /= y
547+
548+
549+testFromString :: IO TmpPostgres.DB -> TestTree
550+testFromString = databasePropertyTest "FromString" \transaction -> do
551+ str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode
552+
553+ transaction \connection -> do
554+ [result] <- testing Rel8.select connection $ pure $ fromString str
555+ result === pack str
556+
557+
558+testCatMaybeTable :: IO TmpPostgres.DB -> TestTree
559+testCatMaybeTable = databasePropertyTest "catMaybeTable" \transaction -> do
560+ rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
561+
562+ transaction \connection -> do
563+ selected <- testing Rel8.select connection do
564+ testTable <- Rel8.values $ Rel8.lit <$> rows
565+ Rel8.catMaybeTable $ Rel8.bool Rel8.nothingTable (pure testTable) (testTableColumn2 testTable)
566+
567+ sort selected === sort (filter testTableColumn2 rows)
568+
569+
570+testCatMaybe :: IO TmpPostgres.DB -> TestTree
571+testCatMaybe = databasePropertyTest "catMaybe" \transaction -> evalM do
572+ rows <- forAll $ Gen.list (Range.linear 0 10) $ Gen.maybe Gen.bool
573+
574+ transaction \connection -> do
575+ selected <- evalM $ testing Rel8.select connection do
576+ Rel8.catNullable =<< Rel8.values (map Rel8.lit rows)
577+
578+ sort selected === sort (catMaybes rows)
579+
580+
581+testMaybeTable :: IO TmpPostgres.DB -> TestTree
582+testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do
583+ (rows, def) <- forAll $ liftA2 (,) (Gen.list (Range.linear 0 10) genTestTable) genTestTable
584+
585+ transaction \connection -> do
586+ selected <- testing Rel8.select connection $
587+ Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))
588+
589+ case rows of
590+ [] -> selected === [def]
591+ _ -> sort selected === sort rows
592+
593+
594+data TwoTestTables f =
595+ TwoTestTables
596+ { testTable1 :: TestTable f
597+ , testTable2 :: TestTable f
598+ }
599+ deriving stock Generic
600+ deriving anyclass Rel8.Rel8able
601+
602+
603+deriving stock instance Eq (TwoTestTables Rel8.Result)
604+deriving stock instance Ord (TwoTestTables Rel8.Result)
605+deriving stock instance Show (TwoTestTables Rel8.Result)
606+
607+
608+testNestedTables :: IO TmpPostgres.DB -> TestTree
609+testNestedTables = databasePropertyTest "Nested TestTables" \transaction -> evalM do
610+ rows <- forAll do
611+ Gen.list (Range.linear 0 10) $
612+ liftA2 TwoTestTables genTestTable genTestTable
613+
614+ transaction \connection -> do
615+ selected <- testing Rel8.select connection do
616+ Rel8.values (Rel8.lit <$> rows)
617+
618+ sort selected === sort rows
619+
620+
621+testMaybeTableApplicative :: IO TmpPostgres.DB -> TestTree
622+testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction -> evalM do
623+ rows1 <- genRows
624+ rows2 <- genRows
625+
626+ transaction \connection -> do
627+ selected <- testing Rel8.select connection do
628+ as <- Rel8.optional (Rel8.values (Rel8.lit <$> rows1))
629+ bs <- Rel8.optional (Rel8.values (Rel8.lit <$> rows2))
630+ pure $ liftA2 (,) as bs
631+
632+ case (rows1, rows2) of
633+ ([], []) -> selected === [Nothing]
634+ ([], bs) -> selected === (Nothing <$ bs)
635+ (as, []) -> selected === (Nothing <$ as)
636+ (as, bs) -> sort selected === sort (Just <$> liftA2 (,) as bs)
637+ where
638+ genRows :: PropertyT IO [TestTable Rel8.Result]
639+ genRows = forAll do
640+ Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)
641+
642+rollingBack
643+ :: (MonadBaseControl IO m, MonadIO m)
644+ => Connection -> m a -> m a
645+rollingBack connection =
646+ bracket_
647+ (liftIO (run (sql "BEGIN") connection))
648+ (liftIO (run (sql "ROLLBACK") connection))
649+
650+
651+genTestTable :: Gen (TestTable Rel8.Result)
652+genTestTable = do
653+ testTableColumn1 <- Gen.text (Range.linear 0 5) Gen.alphaNum
654+ testTableColumn2 <- Gen.bool
655+ return TestTable{..}
656+
657+
658+testUpdate :: IO TmpPostgres.DB -> TestTree
659+testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do
660+ rows <- forAll $ Gen.map (Range.linear 0 5) $ liftA2 (,) genTestTable genTestTable
661+
662+ transaction \connection -> do
663+ void $ testing Rel8.insert connection
664+ Rel8.Insert
665+ { into = testTableSchema
666+ , rows = map (Rel8.toInsert . Rel8.lit) $ Map.keys rows
667+ , onConflict = Rel8.DoNothing
668+ , returning = Rel8.NumberOfRowsAffected
669+ }
670+
671+ void $ testing Rel8.update connection
672+ Rel8.Update
673+ { target = testTableSchema
674+ , set = \r ->
675+ let updates = map (bimap Rel8.lit Rel8.lit) $ Map.toList rows
676+ in
677+ foldl
678+ ( \e (x, y) ->
679+ Rel8.bool
680+ e
681+ y
682+ ( testTableColumn1 r Rel8.==. testTableColumn1 x Rel8.&&.
683+ testTableColumn2 r Rel8.==. testTableColumn2 x
684+ )
685+ )
686+ r
687+ updates
688+ , updateWhere = \_ -> Rel8.lit True
689+ , returning = Rel8.NumberOfRowsAffected
690+ }
691+
692+ selected <- testing Rel8.select connection do
693+ Rel8.each testTableSchema
694+
695+ sort selected === sort (Map.elems rows)
696+
697+ cover 1 "Empty" $ null rows
698+ cover 1 "Singleton" $ null $ drop 1 $ Map.keys rows
699+ cover 1 ">1 row" $ not $ null $ drop 1 $ Map.keys rows
700+
701+
702+testDelete :: IO TmpPostgres.DB -> TestTree
703+testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do
704+ rows <- forAll $ Gen.list (Range.linear 0 5) genTestTable
705+
706+ transaction \connection -> do
707+ void $ testing Rel8.insert connection
708+ Rel8.Insert
709+ { into = testTableSchema
710+ , rows = map (Rel8.toInsert . Rel8.lit) rows
711+ , onConflict = Rel8.DoNothing
712+ , returning = Rel8.NumberOfRowsAffected
713+ }
714+
715+ deleted <-
716+ testing Rel8.delete connection
717+ Rel8.Delete
718+ { from = testTableSchema
719+ , deleteWhere = testTableColumn2
720+ , returning = Rel8.Projection id
721+ }
722+
723+ selected <- testing Rel8.select connection do
724+ Rel8.each testTableSchema
725+
726+ sort (deleted <> selected) === sort rows
727+
728+
729+newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }
730+ deriving stock Generic
731+ deriving anyclass Rel8.Rel8able
732+
733+deriving stock instance Eq (HKNestedPair Rel8.Result)
734+deriving stock instance Ord (HKNestedPair Rel8.Result)
735+deriving stock instance Show (HKNestedPair Rel8.Result)
736+
737+
738+testSelectNestedPairs :: IO TmpPostgres.DB -> TestTree
739+testSelectNestedPairs = databasePropertyTest "Can SELECT nested pairs" \transaction -> do
740+ rows <- forAll $ Gen.list (Range.linear 0 10) $ HKNestedPair <$> liftA2 (,) genTestTable genTestTable
741+
742+ transaction \connection -> do
743+ selected <- testing Rel8.select connection do
744+ Rel8.values $ map Rel8.lit rows
745+
746+ sort selected === sort rows
747+
748+
749+testSelectArray :: IO TmpPostgres.DB -> TestTree
750+testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \transaction -> do
751+ rows <- forAll $ Gen.list (Range.linear 1 10) Gen.bool
752+
753+ transaction \connection -> do
754+ selected <- testing Rel8.select connection $ Rel8.aggregate do
755+ Rel8.listAgg <$> Rel8.values (map Rel8.lit rows)
756+
757+ selected === [foldMap pure rows]
758+
759+
760+data NestedMaybeTable f = NestedMaybeTable
761+ { nmt1 :: Rel8.Column f Bool
762+ , nmt2 :: Rel8.HMaybe f (TestTable f)
763+ }
764+ deriving stock Generic
765+ deriving anyclass Rel8.Rel8able
766+
767+
768+deriving stock instance Eq (NestedMaybeTable Rel8.Result)
769+deriving stock instance Ord (NestedMaybeTable Rel8.Result)
770+deriving stock instance Show (NestedMaybeTable Rel8.Result)
771+
772+
773+testNestedMaybeTable :: IO TmpPostgres.DB -> TestTree
774+testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other tables" \transaction -> do
775+ let example = NestedMaybeTable { nmt1 = True, nmt2 = Just (TestTable "Hi" True) }
776+
777+ transaction \connection -> do
778+ selected <- testing Rel8.select connection do
779+ x <- Rel8.values [Rel8.lit example]
780+ pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)
781+
782+ selected === [True]
783+
784+
785+testing :: MonadIO m => (a -> Connection -> IO b) -> Connection -> a -> m b
786+testing f connection a = liftIO $ f a connection