The beginning of rel8 1.0

Co-authored-by: Ollie Charles <ollie@ocharles.org.uk>

.gitignore

@@ -0,0 +1 @@
+/dist-newstyle

Doctest.hs

@@ -0,0 +1,33 @@
+{-# language BlockArguments #-}
+{-# language OverloadedStrings #-}
+
+module Main where
+
+import Build_doctests ( flags, pkgs, module_sources )
+import Control.Exception ( bracket, throwIO )
+import Data.ByteString.Char8 ( unpack )
+import Data.Foldable ( traverse_ )
+import Database.PostgreSQL.Simple ( connectPostgreSQL, close, execute_ )
+import Database.Postgres.Temp ( toConnectionString, with, withConfig, verboseConfig )
+import System.Environment ( setEnv )
+import System.Environment.Compat ( unsetEnv )
+import Test.DocTest ( doctest )
+
+main :: IO ()
+main = do
+  unsetEnv "GHC_ENVIRONMENT" -- see 'Notes'; you may not need this
+  either throwIO return =<< with \db -> do
+    setEnv "TEST_DATABASE_URL" (unpack (toConnectionString db))
+    bracket (connectPostgreSQL (toConnectionString db)) close \conn -> do
+      execute_ conn "create table author ( author_id serial primary key, name text not null, url text )"
+      execute_ conn "create table project ( author_id int not null references author (author_id), name text not null )"
+
+      execute_ conn "insert into author ( name, url ) values ( 'Ollie', 'https://ocharles.org.uk' )"
+      execute_ conn "insert into author ( name, url ) values ( 'Bryan O''Sullivan', null )"
+      execute_ conn "insert into project ( author_id, name ) values ( 1, 'rel8' )"
+      execute_ conn "insert into project ( author_id, name ) values ( 2, 'aeson' )"
+
+    doctest args
+  
+  where
+    args = flags ++ pkgs ++ module_sources

LICENSE

@@ -0,0 +1,26 @@
+Copyright 2020 Oliver Charles
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+
+1. Redistributions of source code must retain the above copyright
+   notice, this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright
+   notice, this list of conditions and the following disclaimer in the
+   documentation and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.

Setup.hs

@@ -0,0 +1,6 @@
+module Main where
+
+import Distribution.Extra.Doctest (defaultMainWithDoctests)
+
+main :: IO ()
+main = defaultMainWithDoctests "doctests"

cabal.project

@@ -0,0 +1 @@
+packages: .

default.nix

@@ -0,0 +1,29 @@
+let 
+  haskellNix = import (import ./nix/sources.nix)."haskell.nix" {};
+
+  nixpkgsSrc = haskellNix.sources.nixpkgs-2009;
+
+  nixpkgsArgs = haskellNix.nixpkgsArgs;
+
+  compiler-nix-name = "ghc8103";
+
+  pkgs = import nixpkgsSrc nixpkgsArgs;
+
+in 
+pkgs.haskell-nix.project {
+  inherit compiler-nix-name;
+
+  src = pkgs.haskell-nix.haskellLib.cleanGit {
+    name = "rel8";
+    src = ./.;
+  };
+
+  modules = [ 
+    { packages.rel8 = {
+        preCheck = ''
+          export PATH="${pkgs.postgresql}/bin:${"$PATH"}"
+        '';
+      };
+    }
+  ];
+}

jobs.nix

@@ -0,0 +1,5 @@
+let rel8 = (import ./.).hsPkgs.rel8;
+in { 
+  rel8 = rel8.components.library; 
+  tests = rel8.checks.tests; 
+}

nix/sources.json

@@ -0,0 +1,38 @@
+{
+  "haskell.nix": {
+    "branch": "circuithub",
+    "description": "Alternative Haskell Infrastructure for Nixpkgs",
+    "homepage": "https://input-output-hk.github.io/haskell.nix",
+    "owner": "circuithub",
+    "repo": "haskell.nix",
+    "rev": "2902f9b49484a87afb0e1a33b1d88a2c7b8ca0a0",
+    "sha256": "0a01g5b46z5yaf2mnl415hc4lciwiyqhj22qhgwgwd261w4068iy",
+    "type": "tarball",
+    "url": "https://github.com/circuithub/haskell.nix/archive/2902f9b49484a87afb0e1a33b1d88a2c7b8ca0a0.tar.gz",
+    "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
+  },
+  "niv": {
+    "branch": "master",
+    "description": "Easy dependency management for Nix projects",
+    "homepage": "https://github.com/nmattia/niv",
+    "owner": "nmattia",
+    "repo": "niv",
+    "rev": "ba57d5a29b4e0f2085917010380ef3ddc3cf380f",
+    "sha256": "1kpsvc53x821cmjg1khvp1nz7906gczq8mp83664cr15h94sh8i4",
+    "type": "tarball",
+    "url": "https://github.com/nmattia/niv/archive/ba57d5a29b4e0f2085917010380ef3ddc3cf380f.tar.gz",
+    "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
+  },
+  "nixpkgs": {
+    "branch": "nixos-20.09",
+    "description": "Nix Packages collection",
+    "homepage": null,
+    "owner": "nixos",
+    "repo": "nixpkgs",
+    "rev": "6e7f25001fe6874f7ae271891f709bbf50a22c45",
+    "sha256": "1x04j4351pqiqbpkq6g308mxcvb5aqnwv8l2vmlxkgvq5phzky7z",
+    "type": "tarball",
+    "url": "https://github.com/nixos/nixpkgs/archive/6e7f25001fe6874f7ae271891f709bbf50a22c45.tar.gz",
+    "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
+  }
+}

nix/sources.nix

@@ -0,0 +1,148 @@
+# This file has been generated by Niv.
+
+let
+
+  #
+  # The fetchers. fetch_<type> fetches specs of type <type>.
+  #
+
+  fetch_file = pkgs: spec:
+    if spec.builtin or true then
+      builtins_fetchurl { inherit (spec) url sha256; }
+    else
+      pkgs.fetchurl { inherit (spec) url sha256; };
+
+  fetch_tarball = pkgs: name: spec:
+    let
+      ok = str: ! builtins.isNull (builtins.match "[a-zA-Z0-9+-._?=]" str);
+      # sanitize the name, though nix will still fail if name starts with period
+      name' = stringAsChars (x: if ! ok x then "-" else x) "${name}-src";
+    in
+      if spec.builtin or true then
+        builtins_fetchTarball { name = name'; inherit (spec) url sha256; }
+      else
+        pkgs.fetchzip { name = name'; inherit (spec) url sha256; };
+
+  fetch_git = spec:
+    builtins.fetchGit { url = spec.repo; inherit (spec) rev ref; };
+
+  fetch_local = spec: spec.path;
+
+  fetch_builtin-tarball = name: throw
+    ''[${name}] The niv type "builtin-tarball" is deprecated. You should instead use `builtin = true`.
+        $ niv modify ${name} -a type=tarball -a builtin=true'';
+
+  fetch_builtin-url = name: throw
+    ''[${name}] The niv type "builtin-url" will soon be deprecated. You should instead use `builtin = true`.
+        $ niv modify ${name} -a type=file -a builtin=true'';
+
+  #
+  # Various helpers
+  #
+
+  # The set of packages used when specs are fetched using non-builtins.
+  mkPkgs = sources:
+    let
+      sourcesNixpkgs =
+        import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) {};
+      hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath;
+      hasThisAsNixpkgsPath = <nixpkgs> == ./.;
+    in
+      if builtins.hasAttr "nixpkgs" sources
+      then sourcesNixpkgs
+      else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then
+        import <nixpkgs> {}
+      else
+        abort
+          ''
+            Please specify either <nixpkgs> (through -I or NIX_PATH=nixpkgs=...) or
+            add a package called "nixpkgs" to your sources.json.
+          '';
+
+  # The actual fetching function.
+  fetch = pkgs: name: spec:
+
+    if ! builtins.hasAttr "type" spec then
+      abort "ERROR: niv spec ${name} does not have a 'type' attribute"
+    else if spec.type == "file" then fetch_file pkgs spec
+    else if spec.type == "tarball" then fetch_tarball pkgs name spec
+    else if spec.type == "git" then fetch_git spec
+    else if spec.type == "local" then fetch_local spec
+    else if spec.type == "builtin-tarball" then fetch_builtin-tarball name
+    else if spec.type == "builtin-url" then fetch_builtin-url name
+    else
+      abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}";
+
+  # If the environment variable NIV_OVERRIDE_${name} is set, then use
+  # the path directly as opposed to the fetched source.
+  replace = name: drv:
+    let
+      saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name;
+      ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}";
+    in
+      if ersatz == "" then drv else ersatz;
+
+  # Ports of functions for older nix versions
+
+  # a Nix version of mapAttrs if the built-in doesn't exist
+  mapAttrs = builtins.mapAttrs or (
+    f: set: with builtins;
+    listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set))
+  );
+
+  # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/lists.nix#L295
+  range = first: last: if first > last then [] else builtins.genList (n: first + n) (last - first + 1);
+
+  # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L257
+  stringToCharacters = s: map (p: builtins.substring p 1 s) (range 0 (builtins.stringLength s - 1));
+
+  # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269
+  stringAsChars = f: s: concatStrings (map f (stringToCharacters s));
+  concatStrings = builtins.concatStringsSep "";
+
+  # fetchTarball version that is compatible between all the versions of Nix
+  builtins_fetchTarball = { url, name, sha256 }@attrs:
+    let
+      inherit (builtins) lessThan nixVersion fetchTarball;
+    in
+      if lessThan nixVersion "1.12" then
+        fetchTarball { inherit name url; }
+      else
+        fetchTarball attrs;
+
+  # fetchurl version that is compatible between all the versions of Nix
+  builtins_fetchurl = { url, sha256 }@attrs:
+    let
+      inherit (builtins) lessThan nixVersion fetchurl;
+    in
+      if lessThan nixVersion "1.12" then
+        fetchurl { inherit url; }
+      else
+        fetchurl attrs;
+
+  # Create the final "sources" from the config
+  mkSources = config:
+    mapAttrs (
+      name: spec:
+        if builtins.hasAttr "outPath" spec
+        then abort
+          "The values in sources.json should not have an 'outPath' attribute"
+        else
+          spec // { outPath = replace name (fetch config.pkgs name spec); }
+    ) config.sources;
+
+  # The "config" used by the fetchers
+  mkConfig =
+    { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null
+    , sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile)
+    , pkgs ? mkPkgs sources
+    }: rec {
+      # The sources, i.e. the attribute set of spec name to spec
+      inherit sources;
+
+      # The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers
+      inherit pkgs;
+    };
+
+in
+mkSources (mkConfig {}) // { __functor = _: settings: mkSources (mkConfig settings); }

rel8.cabal

@@ -0,0 +1,204 @@
+cabal-version:       2.0
+name:                rel8
+version:             0.1.0.0
+synopsis:            Hey! Hey! Can u rel8?
+license:             BSD3
+license-file:        LICENSE
+author:              Oliver Charles
+maintainer:          ollie@ocharles.org.uk
+build-type:          Custom
+
+custom-setup
+ setup-depends:
+   base >= 4 && <5,
+   Cabal,
+   cabal-doctest >= 1 && <1.1
+
+library
+  build-depends:
+      aeson
+    , base ^>=4.12 || ^>= 4.13 || ^>= 4.14
+    , bytestring
+    , case-insensitive
+    , casing
+    , contravariant
+    , hasql
+    , opaleye ^>= 0.7.1.0
+    , profunctors
+    , scientific
+    , semialign
+    , semigroupoids
+    , text
+    , these
+    , time
+    , uuid
+  default-language:
+    Haskell2010
+  ghc-options:
+    -Weverything -Wno-unsafe -Wno-safe -Wno-missing-safe-haskell-mode
+    -Wno-missing-import-lists -Wno-prepositive-qualified-module
+    -Wno-monomorphism-restriction
+    -Wno-missing-local-signatures 
+  hs-source-dirs:
+    src
+  exposed-modules:
+    Rel8.Aggregate
+
+    Rel8.Expr
+    Rel8.Expr.Aggregate
+    Rel8.Expr.Array
+    Rel8.Expr.Bool
+    Rel8.Expr.Eq
+    Rel8.Expr.Function
+    Rel8.Expr.Null
+    Rel8.Expr.Num
+    Rel8.Expr.Opaleye
+    Rel8.Expr.Ord
+    Rel8.Expr.Order
+    Rel8.Expr.Serialize
+    Rel8.Expr.Text
+    Rel8.Expr.Time
+
+    Rel8.Kind.Bool
+    Rel8.Kind.Labels
+    Rel8.Kind.Necessity
+
+    Rel8.Order
+
+    Rel8.Query
+    Rel8.Query.Aggregate
+    Rel8.Query.Distinct
+    Rel8.Query.Each
+    Rel8.Query.Either
+    Rel8.Query.Exists
+    Rel8.Query.Filter
+    Rel8.Query.Limit
+    Rel8.Query.List
+    Rel8.Query.Maybe
+    Rel8.Query.Null
+    Rel8.Query.Opaleye
+    Rel8.Query.Optimize
+    Rel8.Query.Order
+    Rel8.Query.Set
+    Rel8.Query.SQL
+    Rel8.Query.These
+    Rel8.Query.Values
+
+    Rel8.Schema.Column
+    Rel8.Schema.Context
+    Rel8.Schema.Context.Label
+    Rel8.Schema.Context.Nullify
+    Rel8.Schema.Context.Result
+    Rel8.Schema.Dict
+    Rel8.Schema.Field
+    Rel8.Schema.Generic
+    Rel8.Schema.Generic.Test
+    Rel8.Schema.HTable
+    Rel8.Schema.HTable.Context
+    Rel8.Schema.HTable.Either
+    Rel8.Schema.HTable.Identity
+    Rel8.Schema.HTable.Label
+    Rel8.Schema.HTable.List
+    Rel8.Schema.HTable.Maybe
+    Rel8.Schema.HTable.NonEmpty
+    Rel8.Schema.HTable.Nullify
+    Rel8.Schema.HTable.Pair
+    Rel8.Schema.HTable.Quartet
+    Rel8.Schema.HTable.Quintet
+    Rel8.Schema.HTable.These
+    Rel8.Schema.HTable.Trio
+    Rel8.Schema.HTable.Type
+    Rel8.Schema.HTable.Vectorize
+    Rel8.Schema.Nullability
+    Rel8.Schema.Spec
+    Rel8.Schema.Spec.ConstrainContext
+    Rel8.Schema.Spec.ConstrainDBType
+    Rel8.Schema.Spec.ConstrainType
+    Rel8.Schema.Table
+
+    Rel8.Statement.Delete
+    Rel8.Statement.Insert
+    Rel8.Statement.Returning
+    Rel8.Statement.Select
+    Rel8.Statement.Update
+    Rel8.Statement.View
+
+    Rel8.Table
+    Rel8.Table.Aggregate
+    Rel8.Table.Alternative
+    Rel8.Table.Bool
+    Rel8.Table.Either
+    Rel8.Table.Eq
+    Rel8.Table.Insert
+    Rel8.Table.Lifted
+    Rel8.Table.List
+    Rel8.Table.Maybe
+    Rel8.Table.Name
+    Rel8.Table.NonEmpty
+    Rel8.Table.Opaleye
+    Rel8.Table.Ord
+    Rel8.Table.Order
+    Rel8.Table.Recontextualize
+    Rel8.Table.Serialize
+    Rel8.Table.These
+    Rel8.Table.Undefined
+
+    Rel8.Tabulate
+
+    Rel8.Type
+    Rel8.Type.Array
+    Rel8.Type.Eq
+    Rel8.Type.Information
+    Rel8.Type.Monoid
+    Rel8.Type.Num
+    Rel8.Type.Ord
+    Rel8.Type.Semigroup
+    Rel8.Type.String
+    Rel8.Type.Sum
+    Rel8.Type.Tag
+
+  other-modules:
+    Rel8.Opaque
+    Rel8.Schema.Structure
+
+test-suite tests
+  type:             exitcode-stdio-1.0
+  build-depends:
+      base
+    , bytestring
+    , case-insensitive
+    , containers
+    , hasql
+    , hedgehog          ^>=1.0.2
+    , lifted-base       ^>=0.2.3.12
+    , monad-control     ^>=1.0.2.3
+    , rel8
+    , scientific
+    , tasty
+    , tasty-hedgehog
+    , text
+    , time
+    , tmp-postgres      ^>=1.34.1.0
+    , uuid
+
+  main-is:          Main.hs
+  hs-source-dirs:   tests
+  default-language: Haskell2010
+  ghc-options:
+    -Weverything -Wno-unsafe -Wno-safe -Wno-missing-safe-haskell-mode
+    -Wno-missing-import-lists -Wno-prepositive-qualified-module
+    -Wno-deprecations -Wno-monomorphism-restriction
+    -Wno-missing-local-signatures -Wno-implicit-prelude
+
+test-suite doctests
+  type:             exitcode-stdio-1.0
+  build-depends:
+      base
+    , base-compat
+    , bytestring
+    , doctest
+    , hasql
+    , tmp-postgres
+
+  main-is:          Doctest.hs
+  default-language: Haskell2010

shell.nix

@@ -0,0 +1,11 @@
+let
+  sources = import ./nix/sources.nix;
+  pkgs = import sources.nixpkgs {};
+  hsPkgs = import ./default.nix;
+in
+  hsPkgs.shellFor {
+    withHoogle = true;
+    tools = { cabal = "3.2.0.0"; haskell-language-server = "latest"; };
+    exactDeps = false;
+    buildInputs = [ pkgs.postgresql ];
+  }

src/Rel8/Aggregate.hs

@@ -0,0 +1,68 @@
+{-# language DerivingVia #-}
+{-# language GeneralizedNewtypeDeriving #-}
+{-# language NamedFieldPuns #-}
+{-# language StandaloneKindSignatures #-}
+
+module Rel8.Aggregate
+  ( Aggregate(..), foldInputs, mapInputs
+  , Aggregator(..), unsafeMakeAggregate
+  )
+where
+
+-- base
+import Data.Functor.Const ( Const( Const ), getConst )
+import Data.Kind ( Type )
+import Prelude
+
+-- opaleye
+import qualified Opaleye.Internal.Aggregate as Opaleye
+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
+import qualified Opaleye.Internal.PackMap as Opaleye
+
+-- semigroupoids
+import Data.Functor.Apply ( Apply, WrappedApplicative(..) )
+
+
+type Aggregate :: Type -> Type
+newtype Aggregate a = Aggregate (Opaleye.Aggregator () a)
+  deriving newtype Functor
+  deriving Apply via (WrappedApplicative (Opaleye.Aggregator ()))
+
+
+foldInputs :: Monoid b
+  => (Maybe Aggregator -> Opaleye.PrimExpr -> b) -> Aggregate a -> b
+foldInputs f (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =
+  getConst $ flip agg () $ \(aggregator, a) ->
+    Const $ f (detuplize <$> aggregator) a
+  where
+    detuplize (operation, ordering, distinction) =
+      Aggregator {operation, ordering, distinction}
+
+
+mapInputs :: ()
+  => (Opaleye.PrimExpr -> Opaleye.PrimExpr) -> Aggregate a -> Aggregate a
+mapInputs transform (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =
+  Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ agg . \f input ->
+    f (fmap transform input)
+
+
+type Aggregator :: Type
+data Aggregator = Aggregator
+  { operation :: Opaleye.AggrOp
+  , ordering :: [Opaleye.OrderExpr]
+  , distinction :: Opaleye.AggrDistinct
+  }
+
+
+unsafeMakeAggregate :: ()
+  => (input -> Opaleye.PrimExpr)
+  -> (Opaleye.PrimExpr -> output)
+  -> Maybe Aggregator
+  -> input
+  -> Aggregate output
+unsafeMakeAggregate input output aggregator expr =
+  Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ \f _ ->
+    output <$> f (tuplize <$> aggregator, input expr)
+  where
+    tuplize Aggregator {operation, ordering, distinction} =
+      (operation, ordering, distinction)

src/Rel8/Expr.hs

@@ -0,0 +1,84 @@
+{-# language DataKinds #-}
+{-# language DerivingStrategies #-}
+{-# language FlexibleContexts #-}
+{-# language GADTs #-}
+{-# language RoleAnnotations #-}
+{-# language ScopedTypeVariables #-}
+{-# language StandaloneKindSignatures #-}
+{-# language TypeApplications #-}
+{-# language UndecidableInstances #-}
+
+module Rel8.Expr
+  ( Expr(..)
+  )
+where
+
+-- base
+import Data.Kind ( Type )
+import Data.String ( IsString, fromString )
+import Prelude hiding ( null )
+
+-- opaleye
+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
+
+-- rel8
+import Rel8.Expr.Null ( liftOpNullable, nullify )
+import Rel8.Expr.Opaleye
+  ( castExpr
+  , unsafeFromPrimExpr
+  , mapPrimExpr
+  , zipPrimExprsWith
+  )
+import Rel8.Expr.Serialize ( litExpr )
+import Rel8.Schema.Nullability
+  ( Nullability( Nullable, NonNullable )
+  , Nullabilizes, nullabilization
+  )
+import Rel8.Type ( DBType )
+import Rel8.Type.Monoid ( DBMonoid, memptyExpr )
+import Rel8.Type.Num ( DBFractional, DBNum )
+import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )
+
+
+type role Expr representational
+type Expr :: Type -> Type
+newtype Expr a = Expr Opaleye.PrimExpr
+  deriving stock Show
+
+
+instance (DBSemigroup db, Nullabilizes db a) => Semigroup (Expr a) where
+  (<>) = case nullabilization @a of
+    Nullable -> liftOpNullable (<>.)
+    NonNullable -> (<>.)
+
+
+instance (DBMonoid db, Nullabilizes db a) => Monoid (Expr a) where
+  mempty = case nullabilization @a of
+    Nullable -> nullify memptyExpr
+    NonNullable -> memptyExpr
+
+
+instance (IsString db, DBType db, Nullabilizes db a) => IsString (Expr a) where
+  fromString = litExpr . case nullabilization @a of
+    Nullable -> Just . fromString
+    NonNullable -> fromString
+
+
+instance (DBNum db, Nullabilizes db a) => Num (Expr a) where
+  (+) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:+))
+  (*) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:*))
+  (-) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:-))
+
+  abs = mapPrimExpr (Opaleye.UnExpr Opaleye.OpAbs)
+  negate = mapPrimExpr (Opaleye.UnExpr Opaleye.OpNegate)
+
+  signum = castExpr . mapPrimExpr (Opaleye.UnExpr (Opaleye.UnOpOther "SIGN"))
+
+  fromInteger = castExpr . unsafeFromPrimExpr . Opaleye.ConstExpr . Opaleye.IntegerLit
+
+
+instance (DBFractional db, Nullabilizes db a) => Fractional (Expr a) where
+  (/) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:/))
+
+  fromRational =
+    castExpr . Expr . Opaleye.ConstExpr . Opaleye.NumericLit . realToFrac

src/Rel8/Expr.hs-boot

@@ -0,0 +1,19 @@
+{-# language RoleAnnotations #-}
+{-# language StandaloneKindSignatures #-}
+
+module Rel8.Expr
+  ( Expr(..)
+  )
+where
+
+-- base
+import Data.Kind ( Type )
+import Prelude ()
+
+-- opaleye
+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
+
+
+type role Expr representational
+type Expr :: Type -> Type
+newtype Expr a = Expr Opaleye.PrimExpr

src/Rel8/Expr/Aggregate.hs

@@ -0,0 +1,158 @@
+{-# language DataKinds #-}
+{-# language ScopedTypeVariables #-}
+{-# language TypeApplications #-}
+{-# language TypeFamilies #-}
+
+{-# options_ghc -fno-warn-redundant-constraints #-}
+
+module Rel8.Expr.Aggregate
+  ( count, countDistinct, countStar, countWhere
+  , and, or
+  , min, max
+  , sum, sumWhere
+  , stringAgg
+  , groupByExpr
+  , listAggExpr, nonEmptyAggExpr
+  , sgroupByExpr
+  )
+where
+
+-- base
+import Data.Int ( Int64 )
+import Data.List.NonEmpty ( NonEmpty )
+import Prelude hiding ( and, max, min, null, or, sum )
+
+-- opaleye
+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
+
+-- rel8
+import Rel8.Aggregate ( Aggregate, Aggregator(..), unsafeMakeAggregate )
+import Rel8.Expr ( Expr )
+import Rel8.Expr.Bool ( caseExpr )
+import Rel8.Expr.Opaleye
+  ( castExpr
+  , fromPrimExpr
+  , unsafeFromPrimExpr
+  , unsafeToPrimExpr
+  )
+import Rel8.Expr.Null ( null )
+import Rel8.Expr.Serialize ( litExpr )
+import Rel8.Schema.Nullability ( Nullability, Nullabilizes, nullabilization )
+import Rel8.Type.Eq ( DBEq )
+import Rel8.Type.Num ( DBNum )
+import Rel8.Type.Ord ( DBMax, DBMin )
+import Rel8.Type.String ( DBString )
+import Rel8.Type.Sum ( DBSum )
+
+
+count :: Expr a -> Aggregate (Expr Int64)
+count = unsafeMakeAggregate unsafeToPrimExpr unsafeFromPrimExpr $
+  Just Aggregator
+    { operation = Opaleye.AggrCount
+    , ordering = []
+    , distinction = Opaleye.AggrAll
+    }
+
+
+countDistinct :: DBEq a => Expr a -> Aggregate (Expr Int64)
+countDistinct = unsafeMakeAggregate unsafeToPrimExpr unsafeFromPrimExpr $
+  Just Aggregator
+    { operation = Opaleye.AggrCount
+    , ordering = []
+    , distinction = Opaleye.AggrDistinct
+    }
+
+
+countStar :: Aggregate (Expr Int64)
+countStar = count (litExpr True)
+
+
+countWhere :: Expr Bool -> Aggregate (Expr Int64)
+countWhere condition = count (caseExpr [(condition, litExpr (Just True))] null)
+
+
+and :: Expr Bool -> Aggregate (Expr Bool)
+and = unsafeMakeAggregate unsafeToPrimExpr unsafeFromPrimExpr $
+  Just Aggregator
+    { operation = Opaleye.AggrBoolAnd
+    , ordering = []
+    , distinction = Opaleye.AggrAll
+    }
+
+
+or :: Expr Bool -> Aggregate (Expr Bool)
+or = unsafeMakeAggregate unsafeToPrimExpr unsafeFromPrimExpr $
+  Just Aggregator
+    { operation = Opaleye.AggrBoolOr
+    , ordering = []
+    , distinction = Opaleye.AggrAll
+    }
+
+
+max :: (DBMax db, Nullabilizes db a) => Expr a -> Aggregate (Expr a)
+max = unsafeMakeAggregate unsafeToPrimExpr unsafeFromPrimExpr $
+  Just Aggregator
+    { operation = Opaleye.AggrSum
+    , ordering = []
+    , distinction = Opaleye.AggrAll
+    }
+
+
+min :: (DBMin db, Nullabilizes db a) => Expr a -> Aggregate (Expr a)
+min = unsafeMakeAggregate unsafeToPrimExpr unsafeFromPrimExpr $
+  Just Aggregator
+    { operation = Opaleye.AggrSum
+    , ordering = []
+    , distinction = Opaleye.AggrAll
+    }
+
+
+sum :: (DBSum db, Nullabilizes db a) => Expr a -> Aggregate (Expr a)
+sum = unsafeMakeAggregate unsafeToPrimExpr (castExpr . unsafeFromPrimExpr) $
+  Just Aggregator
+    { operation = Opaleye.AggrSum
+    , ordering = []
+    , distinction = Opaleye.AggrAll
+    }
+
+
+sumWhere :: (DBNum db, DBSum db, Nullabilizes db a)
+  => Expr Bool -> Expr a -> Aggregate (Expr a)
+sumWhere condition a = sum (caseExpr [(condition, a)] 0)
+
+
+stringAgg :: (DBString db, Nullabilizes db a)
+  => Expr db -> Expr a -> Aggregate (Expr a)
+stringAgg delimiter =
+  unsafeMakeAggregate unsafeToPrimExpr (castExpr . unsafeFromPrimExpr) $
+    Just Aggregator
+      { operation = Opaleye.AggrStringAggr (unsafeToPrimExpr delimiter)
+      , ordering = []
+      , distinction = Opaleye.AggrAll
+      }
+
+
+groupByExpr :: (DBEq db, Nullabilizes db a) => Expr a -> Aggregate (Expr a)
+groupByExpr = sgroupByExpr nullabilization
+
+
+listAggExpr :: Expr a -> Aggregate (Expr [a])
+listAggExpr = unsafeMakeAggregate unsafeToPrimExpr fromPrimExpr $ Just
+  Aggregator
+    { operation = Opaleye.AggrArr
+    , ordering = []
+    , distinction = Opaleye.AggrAll
+    }
+
+
+nonEmptyAggExpr :: Expr a -> Aggregate (Expr (NonEmpty a))
+nonEmptyAggExpr = unsafeMakeAggregate unsafeToPrimExpr fromPrimExpr $ Just
+  Aggregator
+    { operation = Opaleye.AggrArr
+    , ordering = []
+    , distinction = Opaleye.AggrAll
+    }
+
+
+sgroupByExpr :: DBEq db => Nullability db a -> Expr a -> Aggregate (Expr a)
+sgroupByExpr _ = unsafeMakeAggregate unsafeToPrimExpr unsafeFromPrimExpr Nothing

src/Rel8/Expr/Array.hs

@@ -0,0 +1,59 @@
+{-# language DataKinds #-}
+{-# language FlexibleContexts #-}
+{-# language ScopedTypeVariables #-}
+{-# language TypeApplications #-}
+{-# language TypeFamilies #-}
+
+{-# options_ghc -fno-warn-redundant-constraints #-}
+
+module Rel8.Expr.Array
+  ( listOf, nonEmptyOf
+  , sappend, sappend1, sempty
+  )
+where
+
+-- base
+import Data.List.NonEmpty ( NonEmpty )
+import Prelude
+
+-- opaleye
+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
+
+-- rel8
+import {-# SOURCE #-} Rel8.Expr ( Expr )
+import Rel8.Expr.Opaleye
+  ( unsafeFromPrimExpr, unsafeToPrimExpr
+  , zipPrimExprsWith
+  )
+import Rel8.Type ( DBType, typeInformation )
+import Rel8.Type.Array ( array )
+import Rel8.Type.Information ( TypeInformation(..) )
+import Rel8.Schema.Nullability ( Nullability, Nullabilizes )
+
+
+sappend :: Expr [a] -> Expr [a] -> Expr [a]
+sappend = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
+
+
+sappend1 :: Expr (NonEmpty a) -> Expr (NonEmpty a) -> Expr (NonEmpty a)
+sappend1 = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
+
+
+sempty :: Nullability t a -> TypeInformation t -> Expr [a]
+sempty _ info = unsafeFromPrimExpr $ array info []
+
+
+listOf :: forall a t. (Nullabilizes t a, DBType t)
+  => [Expr a] -> Expr [a]
+listOf =
+  unsafeFromPrimExpr .
+  array (typeInformation @t) .
+  fmap unsafeToPrimExpr
+
+
+nonEmptyOf :: forall a t. (Nullabilizes t a, DBType t)
+  => NonEmpty (Expr a) -> Expr (NonEmpty a)
+nonEmptyOf =
+  unsafeFromPrimExpr .
+  array (typeInformation @t) .
+  fmap unsafeToPrimExpr

src/Rel8/Expr/Bool.hs

@@ -0,0 +1,68 @@
+module Rel8.Expr.Bool
+  ( false, true
+  , (&&.), (||.), not_
+  , and_, or_
+  , boolExpr
+  , caseExpr
+  , fromTrool
+  )
+where
+
+-- base
+import Data.Foldable ( foldl' )
+import Prelude hiding ( null )
+
+-- opaleye
+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
+
+-- rel8
+import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
+import Rel8.Expr.Opaleye ( mapPrimExpr, zipPrimExprsWith )
+import Rel8.Expr.Serialize ( litExpr )
+
+
+false :: Expr Bool
+false = litExpr False
+
+
+true :: Expr Bool
+true = litExpr True
+
+
+(&&.) :: Expr Bool -> Expr Bool -> Expr Bool
+(&&.) = zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpAnd)
+infixr 3 &&.
+
+
+(||.) :: Expr Bool -> Expr Bool -> Expr Bool
+(||.) = zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpOr)
+infixr 2 ||.
+
+
+not_ :: Expr Bool -> Expr Bool
+not_ = mapPrimExpr (Opaleye.UnExpr Opaleye.OpNot)
+
+
+and_ :: Foldable f => f (Expr Bool) -> Expr Bool
+and_ = foldl' (&&.) true
+
+
+or_ :: Foldable f => f (Expr Bool) -> Expr Bool
+or_ = foldl' (||.) false
+
+
+boolExpr :: Expr a -> Expr a -> Expr Bool -> Expr a
+boolExpr ifFalse ifTrue condition = caseExpr [(condition, ifTrue)] ifFalse
+
+
+caseExpr :: [(Expr Bool, Expr a)] -> Expr a -> Expr a
+caseExpr branches (Expr fallback) =
+  Expr $ Opaleye.CaseExpr (map go branches) fallback
+  where
+    go (Expr condition, Expr value) = (condition, value)
+
+
+fromTrool :: Expr (Maybe Bool) -> Expr Bool
+fromTrool (Expr a) = Expr a &&. Expr (Opaleye.FunExpr "COALESCE" [a, untrue])
+  where
+    untrue = Opaleye.ConstExpr (Opaleye.BoolLit False)

src/Rel8/Expr/Eq.hs

@@ -0,0 +1,93 @@
+{-# language GADTs #-}
+{-# language LambdaCase #-}
+{-# language ViewPatterns #-}
+
+{-# options_ghc -fno-warn-redundant-constraints #-}
+
+module Rel8.Expr.Eq
+  ( seq, sne
+  , (==.), (/=.)
+  , (==?), (/=?)
+  , in_
+  )
+where
+
+-- base
+import Data.Foldable ( toList )
+import Data.List.NonEmpty ( nonEmpty )
+import Prelude hiding ( seq, sin )
+
+-- opaleye
+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
+
+-- rel8
+import Rel8.Expr ( Expr )
+import Rel8.Expr.Bool ( (&&.), (||.), false, or_, fromTrool )
+import Rel8.Expr.Null ( isNull, unsafeLiftOpNullable )
+import Rel8.Expr.Opaleye
+  ( unsafeFromPrimExpr, unsafeToPrimExpr
+  , unsafeZipPrimExprsWith
+  )
+import Rel8.Schema.Nullability
+  ( Nullability( NonNullable, Nullable )
+  , Nullabilizes, nullabilization
+  )
+import Rel8.Type.Eq ( DBEq )
+
+
+eq :: DBEq a => Expr a -> Expr a -> Expr Bool
+eq = unsafeZipPrimExprsWith (Opaleye.BinExpr (Opaleye.:==))
+
+
+ne :: DBEq a => Expr a -> Expr a -> Expr Bool
+ne = unsafeZipPrimExprsWith (Opaleye.BinExpr (Opaleye.:<>))
+
+
+seq :: DBEq db => Nullability db a -> Expr a -> Expr a -> Expr Bool
+seq = \case
+  Nullable -> \ma mb -> isNull ma &&. isNull mb ||. ma ==? mb
+  NonNullable -> eq
+
+
+sne :: DBEq db => Nullability db a -> Expr a -> Expr a -> Expr Bool
+sne = \case
+  Nullable -> \ma mb -> isNull ma `ne` isNull mb ||. ma /=? mb
+  NonNullable -> ne
+
+
+sin :: (DBEq db, Foldable f)
+  => Nullability db a -> f (Expr a) -> Expr a -> Expr Bool
+sin nullability (toList -> as) a = case nullability of
+  Nullable -> or_ $ map (seq Nullable a) as
+  NonNullable -> case nonEmpty as of
+     Nothing -> false
+     Just xs ->
+       unsafeFromPrimExpr $
+         Opaleye.BinExpr Opaleye.OpIn
+           (unsafeToPrimExpr a)
+           (Opaleye.ListExpr (unsafeToPrimExpr <$> xs))
+
+
+(==.) :: (DBEq db, Nullabilizes db a) => Expr a -> Expr a -> Expr Bool
+(==.) = seq nullabilization
+infix 4 ==.
+
+
+(/=.) :: (DBEq db, Nullabilizes db a) => Expr a -> Expr a -> Expr Bool
+(/=.) = sne nullabilization
+infix 4 /=.
+
+
+(==?) :: DBEq a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
+a ==? b = fromTrool $ unsafeLiftOpNullable eq a b
+infix 4 ==?
+
+
+(/=?) :: DBEq a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
+a /=? b = fromTrool $ unsafeLiftOpNullable ne a b
+infix 4 /=?
+
+
+in_ :: (DBEq db, Nullabilizes db a, Foldable f)
+  => f (Expr a) -> Expr a -> Expr Bool
+in_ = sin nullabilization

src/Rel8/Expr/Function.hs

@@ -0,0 +1,81 @@
+{-# language FlexibleContexts #-}
+{-# language FlexibleInstances #-}
+{-# language MultiParamTypeClasses #-}
+{-# language StandaloneKindSignatures #-}
+{-# language TypeFamilies #-}
+{-# language UndecidableInstances #-}
+
+module Rel8.Expr.Function
+  ( Function, function
+  , nullaryFunction
+  , binaryOperator
+  , unsafeBinaryOperator
+  )
+where
+
+-- base
+import Data.Kind ( Constraint, Type )
+import Prelude
+
+-- opaleye
+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
+
+-- rel8
+import Rel8.Expr ( Expr( Expr ) )
+import Rel8.Expr.Opaleye
+  ( castExpr
+  , fromPrimExpr, toPrimExpr, zipPrimExprsWith
+  , unsafeZipPrimExprsWith
+  )
+import Rel8.Kind.Bool ( KnownBool, IsList )
+import Rel8.Schema.Nullability ( Nullabilizes )
+import Rel8.Type ( DBType )
+
+
+type Function :: Type -> Type -> Constraint
+class Function arg res where
+  applyArgument :: ([Opaleye.PrimExpr] -> Opaleye.PrimExpr) -> arg -> res
+
+
+instance
+  ( arg ~ Expr a
+  , Nullabilizes _a a, KnownBool (IsList _a)
+  , DBType _b, Nullabilizes _b b, KnownBool (IsList _b)
+  )
+  => Function arg (Expr b)
+ where
+  applyArgument f a = castExpr $ fromPrimExpr $ f [toPrimExpr a]
+
+
+instance
+  ( arg ~ Expr a
+  , Nullabilizes _a a, KnownBool (IsList _a)
+  , Function args res
+  ) =>
+  Function arg (args -> res)
+ where
+  applyArgument f a = applyArgument (f . (toPrimExpr a :))
+
+
+function :: Function args result => String -> args -> result
+function = applyArgument . Opaleye.FunExpr
+
+
+nullaryFunction :: (DBType db, Nullabilizes db a) => String -> Expr a
+nullaryFunction name = castExpr $ Expr (Opaleye.FunExpr name [])
+
+
+binaryOperator ::
+  ( Nullabilizes _a a, KnownBool (IsList _a)
+  , Nullabilizes _b b, KnownBool (IsList _b)
+  , DBType _c, Nullabilizes _c c, KnownBool (IsList _c)
+  )
+  => String -> Expr a -> Expr b -> Expr c
+binaryOperator operator a b =
+  castExpr $ zipPrimExprsWith (Opaleye.BinExpr (Opaleye.OpOther operator)) a b
+
+
+unsafeBinaryOperator :: (DBType _c, Nullabilizes _c c)
+  => String -> Expr a -> Expr b -> Expr c
+unsafeBinaryOperator operator a b =
+  castExpr $ unsafeZipPrimExprsWith (Opaleye.BinExpr (Opaleye.OpOther operator)) a b

src/Rel8/Expr/Null.hs

@@ -0,0 +1,87 @@
+{-# language DataKinds #-}
+{-# language FlexibleContexts #-}
+{-# language TypeFamilies #-}
+
+{-# options -fno-warn-redundant-constraints #-}
+
+module Rel8.Expr.Null
+  ( null, snull, nullable, nullableOf
+  , isNull, isNonNull
+  , nullify, unsafeUnnullify
+  , mapNullable, liftOpNullable
+  , unsafeMapNullable, unsafeLiftOpNullable
+  )
+where
+
+-- base
+import Prelude hiding ( null )
+
+-- opaleye
+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
+
+-- rel8
+import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
+import Rel8.Expr.Bool ( (||.), boolExpr )
+import Rel8.Expr.Opaleye ( scastExpr, unsafeMapPrimExpr )
+import Rel8.Schema.Nullability ( Nullability( Nullable ), IsMaybe )
+import Rel8.Type ( DBType, typeInformation )
+import Rel8.Type.Information ( TypeInformation )
+
+
+nullify :: IsMaybe a ~ 'False => Expr a -> Expr (Maybe a)
+nullify (Expr a) = Expr a
+
+
+unsafeUnnullify :: Expr (Maybe a) -> Expr a
+unsafeUnnullify (Expr a) = Expr a
+
+
+nullable :: Expr b -> (Expr a -> Expr b) -> Expr (Maybe a) -> Expr b
+nullable b f ma = boolExpr (f (unsafeUnnullify ma)) b (isNull ma)
+
+
+nullableOf :: (IsMaybe a ~ 'False, DBType a)
+  => Maybe (Expr a) -> Expr (Maybe a)
+nullableOf = maybe null nullify
+
+
+isNull :: Expr (Maybe a) -> Expr Bool
+isNull = unsafeMapPrimExpr (Opaleye.UnExpr Opaleye.OpIsNull)
+
+
+isNonNull :: Expr (Maybe a) -> Expr Bool
+isNonNull = unsafeMapPrimExpr (Opaleye.UnExpr Opaleye.OpIsNotNull)
+
+
+mapNullable :: (IsMaybe b ~ 'False, DBType b)
+  => (Expr a -> Expr b) -> Expr (Maybe a) -> Expr (Maybe b)
+mapNullable f ma = boolExpr (unsafeMapNullable f ma) null (isNull ma)
+
+
+liftOpNullable :: (IsMaybe c ~ 'False, DBType c)
+  => (Expr a -> Expr b -> Expr c)
+  -> Expr (Maybe a) -> Expr (Maybe b) -> Expr (Maybe c)
+liftOpNullable f ma mb =
+  boolExpr (unsafeLiftOpNullable f ma mb) null
+    (isNull ma ||. isNull mb)
+
+
+snull :: Nullability a (Maybe a) -> TypeInformation a -> Expr (Maybe a)
+snull nullability info =
+  scastExpr nullability info $ Expr $ Opaleye.ConstExpr Opaleye.NullLit
+
+
+null :: (IsMaybe a ~ 'False, DBType a) => Expr (Maybe a)
+null = snull Nullable typeInformation
+
+
+unsafeMapNullable :: IsMaybe b ~ 'False
+  => (Expr a -> Expr b) -> Expr (Maybe a) -> Expr (Maybe b)
+unsafeMapNullable f ma = nullify (f (unsafeUnnullify ma))
+
+
+unsafeLiftOpNullable :: IsMaybe c ~ 'False
+  => (Expr a -> Expr b -> Expr c)
+  -> Expr (Maybe a) -> Expr (Maybe b) -> Expr (Maybe c)
+unsafeLiftOpNullable f ma mb =
+  nullify (f (unsafeUnnullify ma) (unsafeUnnullify mb))

src/Rel8/Expr/Num.hs

@@ -0,0 +1,80 @@
+{-# language TypeFamilies #-}
+
+{-# options_ghc -fno-warn-redundant-constraints #-}
+
+module Rel8.Expr.Num
+  ( fromIntegral, realToFrac, div, mod, ceiling, floor, round, truncate
+  )
+where
+
+-- base
+import Prelude ()
+
+-- rel
+import Rel8.Expr ( Expr( Expr ) )
+import Rel8.Expr.Function ( function )
+import Rel8.Expr.Opaleye ( castExpr )
+import Rel8.Schema.Nullability ( IsMaybe, Nullabilizes )
+import Rel8.Type.Num ( DBFractional, DBIntegral, DBNum )
+
+
+fromIntegral ::
+  ( DBIntegral _a, Nullabilizes _a a
+  , DBNum _b, Nullabilizes _b b
+  , IsMaybe a ~ IsMaybe b
+  )
+  => Expr a -> Expr b
+fromIntegral (Expr a) = castExpr (Expr a)
+
+
+realToFrac ::
+  ( DBNum _a, Nullabilizes _a a
+  , DBFractional _b, Nullabilizes _b b
+  , IsMaybe a ~ IsMaybe b
+  )
+  => Expr a -> Expr b
+realToFrac (Expr a) = castExpr (Expr a)
+
+
+ceiling ::
+  ( DBFractional _a, Nullabilizes _a a
+  , DBIntegral _b, Nullabilizes _b b
+  , IsMaybe a ~ IsMaybe b
+  )
+  => Expr a -> Expr b
+ceiling = function "CEILING"
+
+
+div :: (DBIntegral _a, Nullabilizes _a a) => Expr a -> Expr a -> Expr a
+div = function "DIV"
+
+
+mod :: (DBIntegral _a, Nullabilizes _a a) => Expr a -> Expr a -> Expr a
+mod = function "MOD"
+
+
+floor ::
+  ( DBFractional _a, Nullabilizes _a a
+  , DBIntegral _b, Nullabilizes _b b
+  , IsMaybe a ~ IsMaybe b
+  )
+  => Expr a -> Expr b
+floor = function "FLOOR"
+
+
+round ::
+  ( DBFractional _a, Nullabilizes _a a
+  , DBIntegral _b, Nullabilizes _b b
+  , IsMaybe a ~ IsMaybe b
+  )
+  => Expr a -> Expr b
+round = function "ROUND"
+
+
+truncate ::
+  ( DBFractional _a, Nullabilizes _a a
+  , DBIntegral _b, Nullabilizes _b b
+  , IsMaybe a ~ IsMaybe b
+  )
+  => Expr a -> Expr b
+truncate = function "TRUNC"

src/Rel8/Expr/Opaleye.hs

@@ -0,0 +1,145 @@
+{-# language FlexibleContexts #-}
+{-# language LambdaCase #-}
+{-# language NamedFieldPuns #-}
+{-# language ScopedTypeVariables #-}
+{-# language TypeApplications #-}
+{-# language TypeFamilies #-}
+
+{-# options_ghc -fno-warn-redundant-constraints #-}
+
+module Rel8.Expr.Opaleye
+  ( castExpr, unsafeCastExpr
+  , scastExpr, sunsafeCastExpr
+  , unsafeLiteral
+  , unsafeFromPrimExpr, unsafeToPrimExpr, unsafeMapPrimExpr
+  , unsafeZipPrimExprsWith, unsafeTraversePrimExpr
+  , sfromPrimExpr, stoPrimExpr
+  , fromPrimExpr, toPrimExpr, mapPrimExpr, zipPrimExprsWith
+  , toColumn, fromColumn
+  )
+where
+
+-- base
+import Prelude
+
+-- opaleye
+import qualified Opaleye.Internal.Column as Opaleye
+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
+
+-- rel8
+import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
+import Rel8.Kind.Bool ( SBool( SFalse, STrue ), KnownBool, boolSing, IsList )
+import Rel8.Schema.Nullability ( Nullability, Nullabilizes, nullabilization )
+import Rel8.Type ( DBType, typeInformation )
+import Rel8.Type.Information ( TypeInformation(..) )
+
+
+castExpr :: (DBType db, Nullabilizes db a) => Expr a -> Expr a
+castExpr = scastExpr nullabilization typeInformation
+
+
+unsafeCastExpr :: (DBType db, Nullabilizes db b) => Expr a -> Expr b
+unsafeCastExpr = sunsafeCastExpr nullabilization typeInformation
+
+
+scastExpr :: Nullability db a -> TypeInformation db -> Expr a -> Expr a
+scastExpr = sunsafeCastExpr
+
+
+sunsafeCastExpr :: ()
+  => Nullability db b -> TypeInformation db -> Expr a -> Expr b
+sunsafeCastExpr _ TypeInformation {typeName} =
+  Expr . Opaleye.CastExpr typeName . unsafeToPrimExpr
+
+
+unsafeLiteral :: (DBType db, Nullabilizes db a) => String -> Expr a
+unsafeLiteral = castExpr . Expr . Opaleye.ConstExpr . Opaleye.OtherLit
+
+
+unsafeFromPrimExpr :: Opaleye.PrimExpr -> Expr a
+unsafeFromPrimExpr = Expr
+
+
+unsafeToPrimExpr :: Expr a -> Opaleye.PrimExpr
+unsafeToPrimExpr (Expr a) = a
+
+
+unsafeMapPrimExpr :: ()
+  => (Opaleye.PrimExpr -> Opaleye.PrimExpr) -> Expr a -> Expr b
+unsafeMapPrimExpr f = unsafeFromPrimExpr . f . unsafeToPrimExpr
+
+
+unsafeZipPrimExprsWith :: ()
+  => (Opaleye.PrimExpr -> Opaleye.PrimExpr -> Opaleye.PrimExpr)
+  -> Expr a -> Expr b -> Expr c
+unsafeZipPrimExprsWith f a b =
+  unsafeFromPrimExpr (f (unsafeToPrimExpr a) (unsafeToPrimExpr b))
+
+
+unsafeTraversePrimExpr :: Functor f
+  => (Opaleye.PrimExpr -> f Opaleye.PrimExpr) -> Expr a -> f (Expr b)
+unsafeTraversePrimExpr f = fmap unsafeFromPrimExpr . f . unsafeToPrimExpr
+
+
+fromPrimExpr ::
+  ( KnownBool (IsList _a), Nullabilizes _a a
+  )
+  => Opaleye.PrimExpr -> Expr a
+fromPrimExpr = sfromPrimExpr nullabilization boolSing
+
+
+toPrimExpr ::
+  ( KnownBool (IsList _a), Nullabilizes _a a
+  )
+  => Expr a -> Opaleye.PrimExpr
+toPrimExpr = stoPrimExpr nullabilization boolSing
+
+
+sfromPrimExpr :: ()
+  => Nullability _a a -> SBool (IsList _a) -> Opaleye.PrimExpr -> Expr a
+sfromPrimExpr _ = \case
+  SFalse -> unsafeFromPrimExpr
+  STrue -> \a -> Expr $
+    Opaleye.CaseExpr
+      [ (Opaleye.UnExpr Opaleye.OpIsNull a, Opaleye.ConstExpr Opaleye.NullLit)
+      ]
+      (Opaleye.UnExpr (Opaleye.UnOpOther "ROW") a)
+
+
+stoPrimExpr :: ()
+  => Nullability _a a -> SBool (IsList _a) -> Expr a -> Opaleye.PrimExpr
+stoPrimExpr _ = \case
+  SFalse -> unsafeToPrimExpr
+  STrue -> \(Expr a) ->
+    Opaleye.CaseExpr
+      [ (Opaleye.UnExpr Opaleye.OpIsNull a, Opaleye.ConstExpr Opaleye.NullLit)
+      ]
+      -- Requires at least Postgres 13
+      (Opaleye.CompositeExpr a "f1")
+
+
+mapPrimExpr ::
+  ( KnownBool (IsList _a), Nullabilizes _a a
+  , KnownBool (IsList _b), Nullabilizes _b b
+  )
+  => (Opaleye.PrimExpr -> Opaleye.PrimExpr)
+  -> Expr a -> Expr b
+mapPrimExpr f = fromPrimExpr . f . toPrimExpr
+
+
+zipPrimExprsWith ::
+  ( KnownBool (IsList _a), Nullabilizes _a a
+  , KnownBool (IsList _b), Nullabilizes _b b
+  , KnownBool (IsList _c), Nullabilizes _c c
+  )
+  => (Opaleye.PrimExpr -> Opaleye.PrimExpr -> Opaleye.PrimExpr)
+  -> Expr a -> Expr b -> Expr c
+zipPrimExprsWith f a b = fromPrimExpr (f (toPrimExpr a) (toPrimExpr b))
+
+
+toColumn :: Opaleye.PrimExpr -> Opaleye.Column b
+toColumn = Opaleye.Column
+
+
+fromColumn :: Opaleye.Column b -> Opaleye.PrimExpr
+fromColumn (Opaleye.Column a) = a

src/Rel8/Expr/Ord.hs

@@ -0,0 +1,130 @@
+{-# language DataKinds #-}
+{-# language LambdaCase #-}
+{-# language GADTs #-}
+{-# language ScopedTypeVariables #-}
+{-# language TypeApplications #-}
+
+{-# options_ghc -fno-warn-redundant-constraints #-}
+
+module Rel8.Expr.Ord
+  ( slt, sle, sgt, sge
+  , (<.), (<=.), (>.), (>=.)
+  , (<?), (<=?), (>?), (>=?)
+  , leastExpr, greatestExpr
+  )
+where
+
+-- base
+import Prelude
+
+-- opaleye
+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
+
+-- rel8
+import Rel8.Expr ( Expr( Expr ) )
+import Rel8.Expr.Bool ( (&&.), (||.), fromTrool )
+import Rel8.Expr.Null ( isNull, isNonNull, nullable, unsafeLiftOpNullable )
+import Rel8.Expr.Opaleye ( unsafeZipPrimExprsWith )
+import Rel8.Schema.Nullability
+  ( Nullability( NonNullable, Nullable )
+  , Nullabilizes, nullabilization
+  )
+import Rel8.Type.Ord ( DBOrd )
+
+
+lt :: DBOrd a => Expr a -> Expr a -> Expr Bool
+lt = unsafeZipPrimExprsWith (Opaleye.BinExpr (Opaleye.:<))
+
+
+le :: DBOrd a => Expr a -> Expr a -> Expr Bool
+le = unsafeZipPrimExprsWith (Opaleye.BinExpr (Opaleye.:<=))
+
+
+gt :: DBOrd a => Expr a -> Expr a -> Expr Bool
+gt = unsafeZipPrimExprsWith (Opaleye.BinExpr (Opaleye.:>))
+
+
+ge :: DBOrd a => Expr a -> Expr a -> Expr Bool
+ge = unsafeZipPrimExprsWith (Opaleye.BinExpr (Opaleye.:>=))
+
+
+slt :: DBOrd db => Nullability db a -> Expr a -> Expr a -> Expr Bool
+slt = \case
+  Nullable -> \ma mb -> isNull ma &&. isNonNull mb ||. ma <? mb
+  NonNullable -> lt
+
+
+sle :: DBOrd db => Nullability db a -> Expr a -> Expr a -> Expr Bool
+sle = \case
+  Nullable -> \ma mb -> isNull ma ||. ma <=? mb
+  NonNullable -> le
+
+
+sgt :: DBOrd db => Nullability db a -> Expr a -> Expr a -> Expr Bool
+sgt = \case
+  Nullable -> \ma mb -> isNonNull ma &&. isNull mb ||. ma >? mb
+  NonNullable -> gt
+
+
+sge :: DBOrd db => Nullability db a -> Expr a -> Expr a -> Expr Bool
+sge = \case
+  Nullable -> \ma mb -> isNull mb ||. ma >=? mb
+  NonNullable -> ge
+
+
+(<.) :: (DBOrd db, Nullabilizes db a) => Expr a -> Expr a -> Expr Bool
+(<.) = slt nullabilization
+infix 4 <.
+
+
+(<=.) :: (DBOrd db, Nullabilizes db a) => Expr a -> Expr a -> Expr Bool
+(<=.) = sle nullabilization
+infix 4 <=.
+
+
+(>.) :: (DBOrd db, Nullabilizes db a) => Expr a -> Expr a -> Expr Bool
+(>.) = sgt nullabilization
+infix 4 >.
+
+
+(>=.) :: (DBOrd db, Nullabilizes db a) => Expr a -> Expr a -> Expr Bool
+(>=.) = sge nullabilization
+infix 4 >=.
+
+
+(<?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
+a <? b = fromTrool $ unsafeLiftOpNullable lt a b
+infix 4 <?
+
+
+(<=?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
+a <=? b = fromTrool $ unsafeLiftOpNullable le a b
+infix 4 <=?
+
+
+(>?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
+a >? b = fromTrool $ unsafeLiftOpNullable gt a b
+infix 4 >?
+
+
+(>=?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
+a >=? b = fromTrool $ unsafeLiftOpNullable ge a b
+infix 4 >=?
+
+
+leastExpr :: forall a db. (DBOrd db, Nullabilizes db a)
+  => Expr a -> Expr a -> Expr a
+leastExpr ma mb = case nullabilization @a of
+  Nullable -> nullable ma (\a -> nullable mb (least_ a) mb) ma
+  NonNullable -> least_ ma mb
+  where
+    least_ (Expr a) (Expr b) = Expr (Opaleye.FunExpr "LEAST" [a, b])
+
+
+greatestExpr :: forall a db. (DBOrd db, Nullabilizes db a)
+  => Expr a -> Expr a -> Expr a
+greatestExpr ma mb = case nullabilization @a of
+  Nullable -> nullable mb (\a -> nullable ma (greatest_ a) mb) ma
+  NonNullable -> greatest_ ma mb
+  where
+    greatest_ (Expr a) (Expr b) = Expr (Opaleye.FunExpr "GREATEST" [a, b])

src/Rel8/Expr/Order.hs

@@ -0,0 +1,63 @@
+{-# language DataKinds #-}
+
+{-# options_ghc -fno-warn-redundant-constraints #-}
+
+module Rel8.Expr.Order
+  ( asc
+  , desc
+  , nullsFirst
+  , nullsLast
+  )
+where
+
+-- base
+import Data.Bifunctor ( first )
+import Prelude
+
+-- opaleye
+import Opaleye.Internal.HaskellDB.PrimQuery ( OrderOp( orderDirection, orderNulls ) )
+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
+import qualified Opaleye.Internal.Order as Opaleye
+
+-- rel8
+import Rel8.Expr ( Expr )
+import Rel8.Expr.Null ( unsafeUnnullify )
+import Rel8.Expr.Opaleye ( unsafeToPrimExpr )
+import Rel8.Order ( Order( Order ) )
+import Rel8.Type.Ord ( DBOrd )
+
+
+asc :: DBOrd a => Order (Expr a)
+asc = Order $ Opaleye.Order (\expr -> [(orderOp, unsafeToPrimExpr expr)])
+  where
+    orderOp :: Opaleye.OrderOp
+    orderOp = Opaleye.OrderOp
+      { orderDirection = Opaleye.OpAsc
+      , orderNulls = Opaleye.NullsLast
+      }
+
+
+desc :: DBOrd a => Order (Expr a)
+desc = Order $ Opaleye.Order (\expr -> [(orderOp, unsafeToPrimExpr expr)])
+  where
+    orderOp :: Opaleye.OrderOp
+    orderOp = Opaleye.OrderOp
+      { orderDirection = Opaleye.OpDesc
+      , orderNulls = Opaleye.NullsFirst
+      }
+
+
+nullsFirst :: Order (Expr a) -> Order (Expr (Maybe a))
+nullsFirst (Order (Opaleye.Order f)) =
+  Order $ Opaleye.Order $ fmap (first g) . f . unsafeUnnullify
+  where
+    g :: Opaleye.OrderOp -> Opaleye.OrderOp
+    g orderOp = orderOp { Opaleye.orderNulls = Opaleye.NullsFirst }
+
+
+nullsLast :: Order (Expr a) -> Order (Expr (Maybe a))
+nullsLast (Order (Opaleye.Order f)) =
+  Order $ Opaleye.Order $ fmap (first g) . f . unsafeUnnullify
+  where
+    g :: Opaleye.OrderOp -> Opaleye.OrderOp
+    g orderOp = orderOp { Opaleye.orderNulls = Opaleye.NullsLast }

src/Rel8/Expr/Serialize.hs

@@ -0,0 +1,47 @@
+{-# language NamedFieldPuns #-}
+{-# language TypeFamilies #-}
+
+module Rel8.Expr.Serialize
+  ( litExpr
+  , slitExpr
+  , sparseValue
+  )
+where
+
+-- base
+import Prelude
+
+-- hasql
+import qualified Hasql.Decoders as Hasql
+
+-- opaleye
+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
+
+-- rel8
+import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
+import Rel8.Expr.Opaleye ( scastExpr )
+import Rel8.Schema.Nullability
+  ( Nullability( Nullable, NonNullable )
+  , Nullabilizes, nullabilization
+  )
+import Rel8.Type ( DBType, typeInformation )
+import Rel8.Type.Information ( TypeInformation(..) )
+
+
+litExpr :: (DBType db, Nullabilizes db a) => a -> Expr a
+litExpr = slitExpr nullabilization typeInformation
+
+
+slitExpr :: Nullability db a -> TypeInformation db -> a -> Expr a
+slitExpr nullable info@TypeInformation {encode} =
+  scastExpr nullable info . Expr . encoder
+  where
+    encoder = case nullable of
+      Nullable -> maybe (Opaleye.ConstExpr Opaleye.NullLit) encode
+      NonNullable -> encode
+
+
+sparseValue :: Nullability db a -> TypeInformation db -> Hasql.Row a
+sparseValue nullability TypeInformation {decode} = case nullability of
+  Nullable -> Hasql.column $ Hasql.nullable decode
+  NonNullable -> Hasql.column $ Hasql.nonNullable decode

src/Rel8/Expr/Text.hs

@@ -0,0 +1,241 @@
+{-# language DataKinds #-}
+
+module Rel8.Expr.Text
+  (
+    -- * String concatenation
+    (++.)
+
+    -- * Regular expression operators
+  , (~.), (~*), (!~), (!~*)
+
+    -- * Standard SQL functions
+  , bitLength, charLength, lower, octetLength, upper
+
+    -- * PostgreSQL functions
+  , ascii, btrim, chr, convert, convertFrom, convertTo, decode, encode
+  , initcap, left, length, lengthEncoding, lpad, ltrim, md5
+  , pgClientEncoding, quoteIdent, quoteLiteral, quoteNullable, regexpReplace
+  , regexpSplitToArray, repeat, replace, reverse, right, rpad, rtrim
+  , splitPart, strpos, substr, toAscii, toHex, translate
+  )
+where
+
+-- base
+import Data.Bool ( Bool )
+import Data.Int ( Int32 )
+import Data.List.NonEmpty ( NonEmpty )
+import Data.Maybe ( Maybe( Nothing, Just ) )
+import Prelude ()
+
+-- bytestring
+import Data.ByteString ( ByteString )
+
+-- rel8
+import Rel8.Expr ( Expr )
+import Rel8.Expr.Function ( binaryOperator, function, nullaryFunction )
+
+-- text
+import Data.Text (Text)
+
+
+-- | The PostgreSQL string concatenation operator.
+(++.) :: Expr Text -> Expr Text -> Expr Text
+(++.) = binaryOperator "||"
+infixr 6 ++.
+
+
+-- * Regular expression operators
+
+-- See https://www.postgresql.org/docs/9.5/static/functions-matching.html#FUNCTIONS-POSIX-REGEXP
+
+
+-- | Matches regular expression, case sensitive
+(~.) :: Expr Text -> Expr Text -> Expr Bool
+(~.) = binaryOperator "~."
+infix 2 ~.
+
+
+-- | Matches regular expression, case insensitive
+(~*) :: Expr Text -> Expr Text -> Expr Bool
+(~*) = binaryOperator "~*"
+infix 2 ~*
+
+
+-- | Does not match regular expression, case sensitive
+(!~) :: Expr Text -> Expr Text -> Expr Bool
+(!~) = binaryOperator "!~"
+infix 2 !~
+
+
+-- | Does not match regular expression, case insensitive
+(!~*) :: Expr Text -> Expr Text -> Expr Bool
+(!~*) = binaryOperator "!~*"
+infix 2 !~*
+
+
+-- See https://www.postgresql.org/docs/9.5/static/functions-Expr.'PGHtml
+
+-- * Standard SQL functions
+
+
+bitLength :: Expr Text -> Expr Int32
+bitLength = function "bit_length"
+
+
+charLength :: Expr Text -> Expr Int32
+charLength = function "char_length"
+
+
+lower :: Expr Text -> Expr Text
+lower = function "lower"
+
+
+octetLength :: Expr Text -> Expr Int32
+octetLength = function "octet_length"
+
+
+upper :: Expr Text -> Expr Text
+upper = function "upper"
+
+
+-- * PostgreSQL functions
+ascii :: Expr Text -> Expr Int32
+ascii = function "ascii"
+
+
+btrim :: Expr Text -> Maybe (Expr Text) -> Expr Text
+btrim a (Just b) = function "btrim" a b
+btrim a Nothing = function "btrim" a
+
+
+chr :: Expr Int32 -> Expr Text
+chr = function "chr"
+
+
+convert :: Expr ByteString -> Expr Text -> Expr Text -> Expr ByteString
+convert = function "convert"
+
+
+convertFrom :: Expr ByteString -> Expr Text -> Expr Text
+convertFrom = function "convert_from"
+
+
+convertTo :: Expr Text -> Expr Text -> Expr ByteString
+convertTo = function "convert_to"
+
+
+decode :: Expr Text -> Expr Text -> Expr ByteString
+decode = function "decode"
+
+
+encode :: Expr ByteString -> Expr Text -> Expr Text
+encode = function "encode"
+
+
+initcap :: Expr Text -> Expr Text
+initcap = function "initcap"
+
+
+left :: Expr Text -> Expr Int32 -> Expr Text
+left = function "left"
+
+
+length :: Expr Text -> Expr Int32
+length = function "length"
+
+
+lengthEncoding :: Expr ByteString -> Expr Text -> Expr Int32
+lengthEncoding = function "length"
+
+
+lpad :: Expr Text -> Expr Int32 -> Maybe (Expr Text) -> Expr Text
+lpad a b (Just c) = function "lpad" a b c
+lpad a b Nothing = function "lpad" a b
+
+
+ltrim :: Expr Text -> Maybe (Expr Text) -> Expr Text
+ltrim a (Just b) = function "ltrim" a b
+ltrim a Nothing = function "ltrim" a
+
+
+md5 :: Expr Text -> Expr Text
+md5 = function "md5"
+
+
+pgClientEncoding :: Expr Text
+pgClientEncoding = nullaryFunction "pg_client_encoding"
+
+
+quoteIdent :: Expr Text -> Expr Text
+quoteIdent = function "quote_ident"
+
+
+quoteLiteral :: Expr Text -> Expr Text
+quoteLiteral = function "quote_literal"
+
+
+quoteNullable :: Expr Text -> Expr Text
+quoteNullable = function "quote_nullable"
+
+
+regexpReplace :: ()
+  => Expr Text -> Expr Text -> Expr Text -> Maybe (Expr Text) -> Expr Text
+regexpReplace a b c (Just d) = function "regexp_replace" a b c d
+regexpReplace a b c Nothing = function "regexp_replace" a b c
+
+
+regexpSplitToArray :: ()
+  => Expr Text -> Expr Text -> Maybe (Expr Text) -> Expr (NonEmpty Text)
+regexpSplitToArray a b (Just c) = function "regexp_split_to_array" a b c
+regexpSplitToArray a b Nothing = function "regexp_split_to_array" a b
+
+
+repeat :: Expr Text -> Expr Int32 -> Expr Text
+repeat = function "repeat"
+
+
+replace :: Expr Text -> Expr Text -> Expr Text -> Expr Text
+replace = function "replace"
+
+
+reverse :: Expr Text -> Expr Text
+reverse = function "reverse"
+
+
+right :: Expr Text -> Expr Int32 -> Expr Text
+right = function "right"
+
+
+rpad :: Expr Text -> Expr Int32 -> Maybe (Expr Text) -> Expr Text
+rpad a b (Just c) = function "rpad" a b c
+rpad a b Nothing = function "rpad" a b
+
+
+rtrim :: Expr Text -> Maybe (Expr Text) -> Expr Text
+rtrim a (Just b) = function "rtrim" a b
+rtrim a Nothing = function "rtrim" a
+
+
+splitPart :: Expr Text -> Expr Text -> Expr Int32 -> Expr Text
+splitPart = function "split_part"
+
+
+strpos :: Expr Text -> Expr Text -> Expr Int32
+strpos = function "strpos"
+
+
+substr :: Expr Text -> Expr Int32 -> Maybe (Expr Int32) -> Expr Text
+substr a b (Just c) = function "substr" a b c
+substr a b Nothing = function "substr" a b
+
+
+toAscii :: Expr Text -> Expr Text -> Expr Text
+toAscii = function "toAscii"
+
+
+toHex :: Expr Int32 -> Expr Text
+toHex = function "toHex"
+
+
+translate :: Expr Text -> Expr Text -> Expr Text -> Expr Text
+translate = function "translate"

src/Rel8/Expr/Time.hs

@@ -0,0 +1,155 @@
+module Rel8.Expr.Time
+  ( -- * Working with @Day@
+    today
+  , toDay
+  , fromDay
+  , addDays
+  , diffDays
+  , subtractDays
+
+    -- * Working with @UTCTime@
+  , now
+  , addTime
+  , diffTime
+  , subtractTime
+
+  -- Working with @DiffTime@
+  , scaleInterval
+  , second, seconds
+  , minute, minutes
+  , hour, hours
+  , day, days
+  , month, months
+  , year, years
+  ) where
+
+-- base
+import Data.Int ( Int32 )
+import Prelude
+
+-- rel8
+import Rel8.Expr ( Expr )
+import Rel8.Expr.Function ( binaryOperator, nullaryFunction )
+import Rel8.Expr.Opaleye ( unsafeCastExpr, unsafeLiteral )
+
+-- time
+import Data.Time.Calendar ( Day )
+import Data.Time.Clock ( DiffTime, UTCTime )
+
+
+-- | Corresponds to @date(now())@.
+today :: Expr Day
+today = toDay now
+
+
+-- | Corresponds to calling the @date@ function with a given time.
+toDay :: Expr UTCTime -> Expr Day
+toDay = unsafeCastExpr
+
+
+-- | Corresponds to @x::timestamptz@.
+fromDay :: Expr Day -> Expr UTCTime
+fromDay = unsafeCastExpr
+
+
+-- | Move forward a given number of days from a particular day.
+addDays :: Expr Int32 -> Expr Day -> Expr Day
+addDays = flip (binaryOperator "+")
+
+
+-- | Find the number of days between two days. Corresponds to the @-@ operator.
+diffDays :: Expr Day -> Expr Day -> Expr Int32
+diffDays = binaryOperator "-"
+
+
+-- | Subtract a given number of days from a particular 'Day'. 
+subtractDays :: Expr Int32 -> Expr Day -> Expr Day
+subtractDays = flip (binaryOperator "-")
+
+
+-- | Corresponds to @now()@.
+now :: Expr UTCTime
+now = nullaryFunction "now"
+
+
+-- | Add a time interval to a point in time, yielding a new point in time.
+addTime :: Expr DiffTime -> Expr UTCTime -> Expr UTCTime
+addTime = flip (binaryOperator "+")
+
+
+-- | Find the duration between two times.
+diffTime :: Expr UTCTime -> Expr UTCTime -> Expr DiffTime
+diffTime = binaryOperator "-"
+
+
+-- | Subtract a time interval from a point in time, yielding a new point in time.
+subtractTime :: Expr DiffTime -> Expr UTCTime -> Expr UTCTime
+subtractTime = flip (binaryOperator "-")
+
+
+scaleInterval :: Expr Double -> Expr DiffTime -> Expr DiffTime
+scaleInterval = binaryOperator "*"
+
+
+-- | An interval of one second.
+second :: Expr DiffTime
+second = singleton "second"
+
+
+-- | Create a literal interval from an integral number of seconds.
+seconds :: Expr Double -> Expr DiffTime
+seconds = (`scaleInterval` second)
+
+
+-- | An interval of one minute.
+minute :: Expr DiffTime
+minute = singleton "minute"
+
+
+-- | Create a literal interval from an integral number of minutes.
+minutes :: Expr Double -> Expr DiffTime
+minutes = (`scaleInterval` minute)
+
+
+-- | An interval of one hour.
+hour :: Expr DiffTime
+hour = singleton "hour"
+
+
+-- | Create a literal interval from an integral number of hours.
+hours :: Expr Double -> Expr DiffTime
+hours = (`scaleInterval` hour)
+
+
+-- | An interval of one day.
+day :: Expr DiffTime
+day = singleton "day"
+
+
+-- | Create a literal interval from a number of days.
+days ::  Expr Double -> Expr DiffTime
+days = (`scaleInterval` day)
+
+
+-- | An interval of one month.
+month :: Expr DiffTime
+month = singleton "month"
+
+
+-- | Create a literal interval from a number of months.
+months ::  Expr Double -> Expr DiffTime
+months = (`scaleInterval` month)
+
+
+-- | An interval of one year.
+year :: Expr DiffTime
+year = singleton "year"
+
+
+-- | Create a literal interval from a number of years.
+years ::  Expr Double -> Expr DiffTime
+years = (`scaleInterval` year)
+
+
+singleton :: String -> Expr DiffTime
+singleton unit = unsafeLiteral $ "'1 " ++ unit ++ "'"

src/Rel8/Kind/Bool.hs

@@ -0,0 +1,43 @@
+{-# language DataKinds #-}
+{-# language GADTs #-}
+{-# language StandaloneKindSignatures #-}
+{-# language TypeFamilies #-}
+
+module Rel8.Kind.Bool
+  ( Bool( False, True )
+  , SBool ( SFalse, STrue )
+  , KnownBool( boolSing )
+  , IsList
+  )
+where
+
+-- base
+import Data.Kind ( Constraint, Type )
+import Data.List.NonEmpty ( NonEmpty )
+import Prelude
+
+
+type SBool :: Bool -> Type
+data SBool bool where
+  SFalse :: SBool 'False
+  STrue :: SBool 'True
+
+
+type KnownBool :: Bool -> Constraint
+class KnownBool bool where
+  boolSing :: SBool bool
+
+
+instance KnownBool 'False where
+  boolSing = SFalse
+
+
+instance KnownBool 'True where
+  boolSing = STrue
+
+
+type IsList :: Type -> Bool
+type family IsList a where
+  IsList [_] = 'True
+  IsList (NonEmpty _) = 'True
+  IsList _ = 'False

src/Rel8/Kind/Labels.hs

@@ -0,0 +1,61 @@
+{-# language DataKinds #-}
+{-# language FlexibleContexts #-}
+{-# language FlexibleInstances #-}
+{-# language GADTs #-}
+{-# language LambdaCase #-}
+{-# language StandaloneKindSignatures #-}
+{-# language TypeOperators #-}
+
+module Rel8.Kind.Labels
+  ( Labels
+  , SLabels( SLabel, SLabels )
+  , KnownLabels( labelsSing )
+  , renderLabels
+  )
+where
+
+-- base
+import Data.Kind ( Constraint, Type )
+import Data.List.NonEmpty ( NonEmpty( (:|) ), (<|) )
+import Data.Proxy ( Proxy( Proxy ) )
+import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )
+import Prelude
+
+
+type Labels :: Type
+type Labels = [Symbol]
+
+
+type SLabels :: Labels -> Type
+data SLabels labels where
+  SLabel :: KnownSymbol label => Proxy label -> SLabels '[label]
+  SLabels :: KnownSymbol label => Proxy label -> SLabels labels -> SLabels (label ': labels)
+
+
+type KnownLabels :: Labels -> Constraint
+class KnownLabels labels where
+  labelsSing :: SLabels labels
+
+
+instance KnownSymbol label => KnownLabels (label ': '[]) where
+  labelsSing = SLabel Proxy
+
+
+instance (KnownSymbol label, KnownLabels (label_ ': labels)) =>
+  KnownLabels (label ': (label_ ': labels))
+ where
+  labelsSing = SLabels Proxy labelsSing
+
+
+renderLabels :: SLabels labels -> NonEmpty String
+renderLabels = cleanup . go
+  where
+    go :: SLabels labels -> NonEmpty String
+    go = \case
+      SLabel label -> pure (symbolVal label)
+      SLabels label labels -> symbolVal label <| go labels
+
+    cleanup ("" :| []) = "anon" :| []
+    cleanup (a :| []) = a :| []
+    cleanup (a :| [""]) = a :| []
+    cleanup (a :| (b : c)) = a <| cleanup (b :| c)

src/Rel8/Kind/Necessity.hs

@@ -0,0 +1,38 @@
+{-# language DataKinds #-}
+{-# language FlexibleContexts #-}
+{-# language GADTs #-}
+{-# language StandaloneKindSignatures #-}
+
+module Rel8.Kind.Necessity
+  ( Necessity( Optional, Required )
+  , SNecessity( SOptional, SRequired )
+  , KnownNecessity( necessitySing )
+  )
+where
+
+-- base
+import Data.Kind ( Constraint, Type )
+import Prelude ()
+
+
+type Necessity :: Type
+data Necessity = Optional | Required
+
+
+type SNecessity :: Necessity -> Type
+data SNecessity necessity where
+  SOptional :: SNecessity 'Optional
+  SRequired :: SNecessity 'Required
+
+
+type KnownNecessity :: Necessity -> Constraint
+class KnownNecessity necessity where
+  necessitySing :: SNecessity necessity
+
+
+instance KnownNecessity 'Optional where
+  necessitySing = SOptional
+
+
+instance KnownNecessity 'Required where
+  necessitySing = SRequired

src/Rel8/Opaque.hs

@@ -0,0 +1,20 @@
+{-# language PolyKinds #-}
+{-# language StandaloneKindSignatures #-}
+
+module Rel8.Opaque
+  ( Opaque
+  , Opaque1
+  )
+where
+
+-- base
+import Data.Kind ( Type )
+import Prelude ()
+
+
+type Opaque :: Type
+data Opaque
+
+
+type Opaque1 :: k -> Type -> Type
+data Opaque1 a x

src/Rel8/Order.hs

@@ -0,0 +1,24 @@
+{-# language DerivingStrategies #-}
+{-# language GeneralizedNewtypeDeriving #-}
+{-# language StandaloneKindSignatures #-}
+
+module Rel8.Order
+  ( Order(..)
+  )
+where
+
+-- base
+import Data.Functor.Contravariant ( Contravariant )
+import Data.Kind ( Type )
+import Prelude
+
+-- contravariant
+import Data.Functor.Contravariant.Divisible ( Decidable, Divisible )
+
+-- opaleye
+import qualified Opaleye.Internal.Order as Opaleye
+
+
+type Order :: Type -> Type
+newtype Order a = Order (Opaleye.Order a)
+  deriving newtype (Contravariant, Divisible, Decidable, Semigroup, Monoid)

src/Rel8/Query.hs

@@ -0,0 +1,36 @@
+{-# language DerivingStrategies #-}
+{-# language GeneralizedNewtypeDeriving #-}
+{-# language StandaloneKindSignatures #-}
+
+module Rel8.Query
+  ( Query( Query )
+  )
+where
+
+-- base
+import Data.Kind ( Type )
+import Prelude
+
+-- opaleye
+import qualified Opaleye.Select as Opaleye
+
+-- rel8
+import Rel8.Query.Set ( unionAll )
+import Rel8.Query.Values ( values )
+import Rel8.Table.Alternative
+  ( AltTable, (<|>:)
+  , AlternativeTable, emptyTable
+  )
+
+
+type Query :: Type -> Type
+newtype Query a = Query (Opaleye.Select a)
+  deriving newtype (Functor, Applicative, Monad)
+
+
+instance AltTable Query where
+  (<|>:) = unionAll
+
+
+instance AlternativeTable Query where
+  emptyTable = values []

src/Rel8/Query.hs-boot

@@ -0,0 +1,17 @@
+{-# language StandaloneKindSignatures #-}
+
+module Rel8.Query
+  ( Query( Query )
+  )
+where
+
+-- base
+import Data.Kind ( Type )
+import Prelude ()
+
+-- opaleye
+import qualified Opaleye.Select as Opaleye
+
+
+type Query :: Type -> Type
+newtype Query a = Query (Opaleye.Select a)

src/Rel8/Query/Aggregate.hs

@@ -0,0 +1,22 @@
+{-# language FlexibleContexts #-}
+
+module Rel8.Query.Aggregate
+  ( aggregate
+  )
+where
+
+-- base
+import Prelude ()
+
+-- opaleye
+import qualified Opaleye.Aggregate as Opaleye
+
+-- rel8
+import Rel8.Aggregate ( Aggregate )
+import Rel8.Query ( Query )
+import Rel8.Query.Opaleye ( mapOpaleye )
+import Rel8.Table.Opaleye ( aggregator )
+
+
+aggregate :: Query (Aggregate exprs) -> Query exprs
+aggregate = mapOpaleye (Opaleye.aggregate aggregator)

src/Rel8/Query/Distinct.hs

@@ -0,0 +1,37 @@
+{-# options_ghc -fno-warn-redundant-constraints #-}
+
+module Rel8.Query.Distinct
+  ( distinct
+  , distinctOn
+  , distinctOnBy
+  )
+where
+
+-- base
+import Prelude
+
+-- opaleye
+import qualified Opaleye.Distinct as Opaleye
+import qualified Opaleye.Internal.Order as Opaleye
+import qualified Opaleye.Internal.QueryArr as Opaleye
+
+-- rel8
+import Rel8.Order ( Order( Order ) )
+import Rel8.Query ( Query )
+import Rel8.Query.Opaleye ( mapOpaleye )
+import Rel8.Table.Eq ( EqTable )
+import Rel8.Table.Opaleye ( distinctspec, unpackspec )
+
+
+distinct :: EqTable a => Query a -> Query a
+distinct = mapOpaleye (Opaleye.distinctExplicit distinctspec)
+
+
+distinctOn :: EqTable b => (a -> b) -> Query a -> Query a
+distinctOn proj =
+  mapOpaleye (\q -> Opaleye.productQueryArr (Opaleye.distinctOn unpackspec proj . Opaleye.runSimpleQueryArr q))
+
+
+distinctOnBy :: EqTable b => (a -> b) -> Order a -> Query a -> Query a
+distinctOnBy proj (Order order) =
+  mapOpaleye (\q -> Opaleye.productQueryArr (Opaleye.distinctOnBy unpackspec proj order . Opaleye.runSimpleQueryArr q))

src/Rel8/Query/Each.hs

@@ -0,0 +1,29 @@
+{-# language FlexibleContexts #-}
+
+module Rel8.Query.Each
+  ( each
+  )
+where
+
+-- base
+import Prelude
+
+-- opaleye
+import qualified Opaleye.Table as Opaleye
+
+-- rel8
+import Rel8.Query ( Query )
+import Rel8.Query.Opaleye ( fromOpaleye )
+import Rel8.Schema.Table ( TableSchema )
+import Rel8.Table ( fromColumns, toColumns )
+import Rel8.Table.Opaleye ( table, unpackspec )
+import Rel8.Table.Recontextualize ( Selects )
+
+
+each :: Selects names exprs => TableSchema names -> Query exprs
+each =
+  fmap fromColumns .
+  fromOpaleye .
+  Opaleye.selectTableExplicit unpackspec .
+  table .
+  fmap toColumns

src/Rel8/Query/Either.hs

@@ -0,0 +1,64 @@
+{-# language FlexibleContexts #-}
+
+module Rel8.Query.Either
+  ( keepLeftTable
+  , keepRightTable
+  , bindEitherTable
+  , bitraverseEitherTable
+  )
+where
+
+-- base
+import Prelude
+
+-- rel8
+import Rel8.Expr.Eq ( (==.) )
+import Rel8.Query ( Query )
+import Rel8.Query.Filter ( where_ )
+import Rel8.Query.Maybe ( optional )
+import Rel8.Query.Set ( unionAll )
+import Rel8.Schema.Context ( DB )
+import Rel8.Table ( Table )
+import Rel8.Table.Bool ( bool )
+import Rel8.Table.Either
+  ( EitherTable( EitherTable )
+  , leftTable, rightTable
+  , isLeftTable, isRightTable
+  )
+import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
+
+
+keepLeftTable :: EitherTable a b -> Query a
+keepLeftTable e@(EitherTable _ a _) = do
+  where_ $ isLeftTable e
+  pure a
+
+
+keepRightTable :: EitherTable a b -> Query b
+keepRightTable e@(EitherTable _ _ b) = do
+  where_ $ isRightTable e
+  pure b
+
+
+bindEitherTable :: (Table DB a, Monad m)
+  => (i -> m (EitherTable a b)) -> EitherTable a i -> m (EitherTable a b)
+bindEitherTable query e@(EitherTable input a i) = do
+  EitherTable output a' b <- query i
+  pure $ EitherTable (input <> output) (bool a a' (isRightTable e)) b
+
+
+bitraverseEitherTable :: (Table DB c, Table DB d)
+  => (a -> Query c)
+  -> (b -> Query d)
+  -> EitherTable a b
+  -> Query (EitherTable c d)
+bitraverseEitherTable f g e = traverseLeftTable `unionAll` traverseRightTable
+  where
+    traverseLeftTable = do
+      mc@(MaybeTable _ c) <- optional (f =<< keepLeftTable e)
+      where_ $ isJustTable mc ==. isLeftTable e
+      pure $ leftTable c
+    traverseRightTable = do
+      md@(MaybeTable _ d) <- optional (g =<< keepRightTable e)
+      where_ $ isJustTable md ==. isRightTable e
+      pure $ rightTable d

src/Rel8/Query/Exists.hs

@@ -0,0 +1,57 @@
+{-# language DataKinds #-}
+
+module Rel8.Query.Exists
+  ( exists, inQuery
+  , whereExists, with, withBy
+  , whereNotExists, without, withoutBy
+  )
+where
+
+-- base
+import Prelude hiding ( filter )
+
+-- opaleye
+import qualified Opaleye.Operators as Opaleye
+
+-- rel8
+import Rel8.Expr ( Expr )
+import Rel8.Query ( Query )
+import Rel8.Query.Filter ( filter )
+import Rel8.Query.Maybe ( optional )
+import Rel8.Query.Opaleye ( mapOpaleye )
+import Rel8.Table.Eq ( EqTable, (==:) )
+import Rel8.Table.Maybe ( isJustTable )
+
+
+exists :: Query a -> Query (Expr Bool)
+exists = fmap isJustTable . optional . whereExists
+-- FIXME: change this when b7aacc07c6392654cae439fc3b997620c3aa7a87 makes it
+-- into a release of Opaleye
+
+
+inQuery :: EqTable a => a -> Query a -> Query (Expr Bool)
+inQuery a = exists . (>>= filter (a ==:))
+
+
+whereExists :: Query a -> Query ()
+whereExists = mapOpaleye Opaleye.restrictExists
+
+
+whereNotExists :: Query a -> Query ()
+whereNotExists = mapOpaleye Opaleye.restrictNotExists
+
+
+with :: (a -> Query b) -> a -> Query a
+with f a = a <$ whereExists (f a)
+
+
+withBy :: (a -> b -> Expr Bool) -> Query b -> a -> Query a
+withBy predicate bs = with $ \a -> bs >>= filter (predicate a)
+
+
+without :: (a -> Query b) -> a -> Query a
+without f a = a <$ whereNotExists (f a)
+
+
+withoutBy :: (a -> b -> Expr Bool) -> Query b -> a -> Query a
+withoutBy predicate bs = without $ \a -> bs >>= filter (predicate a)

src/Rel8/Query/Filter.hs

@@ -0,0 +1,29 @@
+module Rel8.Query.Filter
+  ( filter
+  , where_
+  )
+where
+
+-- base
+import Prelude hiding ( filter )
+
+-- opaleye
+import qualified Opaleye.Operators as Opaleye
+
+-- profunctors
+import Data.Profunctor ( lmap )
+
+-- rel8
+import Rel8.Expr ( Expr )
+import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )
+import Rel8.Query ( Query )
+import Rel8.Query.Opaleye ( fromOpaleye )
+
+
+filter :: (a -> Expr Bool) -> a -> Query a
+filter f a = a <$ where_ (f a)
+
+
+where_ :: Expr Bool -> Query ()
+where_ condition =
+  fromOpaleye $ lmap (\_ -> toColumn $ toPrimExpr condition) Opaleye.restrict

src/Rel8/Query/Limit.hs

@@ -0,0 +1,23 @@
+module Rel8.Query.Limit
+  ( limit
+  , offset
+  )
+where
+
+-- base
+import Prelude
+
+-- opaleye
+import qualified Opaleye
+
+-- rel8
+import Rel8.Query ( Query )
+import Rel8.Query.Opaleye ( mapOpaleye )
+
+
+limit :: Word -> Query a -> Query a
+limit = mapOpaleye . Opaleye.limit . fromIntegral
+
+
+offset :: Word -> Query a -> Query a
+offset = mapOpaleye . Opaleye.offset . fromIntegral

src/Rel8/Query/List.hs

@@ -0,0 +1,28 @@
+{-# language FlexibleContexts #-}
+
+module Rel8.Query.List
+  ( many, some
+  )
+where
+
+-- base
+import Prelude
+
+-- rel8
+import Rel8.Query ( Query )
+import Rel8.Query.Aggregate ( aggregate )
+import Rel8.Query.Maybe ( optional )
+import Rel8.Schema.Context ( DB )
+import Rel8.Table ( Table )
+import Rel8.Table.Aggregate ( listAgg, nonEmptyAgg )
+import Rel8.Table.List ( ListTable )
+import Rel8.Table.Maybe ( maybeTable )
+import Rel8.Table.NonEmpty ( NonEmptyTable )
+
+
+some :: Table DB a => Query a -> Query (NonEmptyTable a)
+some = aggregate . fmap nonEmptyAgg
+
+
+many :: Table DB a => Query a -> Query (ListTable a)
+many = fmap (maybeTable mempty id) . optional . aggregate . fmap listAgg

src/Rel8/Query/Maybe.hs

@@ -0,0 +1,60 @@
+module Rel8.Query.Maybe
+  ( optional
+  , catMaybeTable
+  , bindMaybeTable
+  , traverseMaybeTable
+  )
+where
+
+-- base
+import Prelude
+
+-- opaleye
+import qualified Opaleye.Internal.PackMap as Opaleye
+import qualified Opaleye.Internal.PrimQuery as Opaleye
+import qualified Opaleye.Internal.QueryArr as Opaleye
+import qualified Opaleye.Internal.Tag as Opaleye
+import qualified Opaleye.Internal.Unpackspec as Opaleye
+
+-- rel8
+import Rel8.Expr.Bool ( true )
+import Rel8.Expr.Eq ( (==.) )
+import Rel8.Expr.Opaleye ( unsafeToPrimExpr )
+import Rel8.Query ( Query )
+import Rel8.Query.Filter ( where_ )
+import Rel8.Query.Opaleye ( mapOpaleye )
+import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
+import Rel8.Table.Opaleye ( unpackspec )
+
+
+optional :: Query a -> Query (MaybeTable a)
+optional = mapOpaleye $ Opaleye.QueryArr . go
+  where
+    go query (i, left, tag) = (MaybeTable t' a, join, Opaleye.next tag')
+      where
+        (MaybeTable t a, right, tag') =
+          Opaleye.runSimpleQueryArr (pure <$> query) (i, tag)
+        (t', bindings) = Opaleye.run $
+          Opaleye.runUnpackspec unpackspec (Opaleye.extractAttr "maybe" tag') t
+        join = Opaleye.Join Opaleye.LeftJoin condition [] bindings left right
+        condition = unsafeToPrimExpr true
+
+
+catMaybeTable :: MaybeTable a -> Query a
+catMaybeTable ma@(MaybeTable _ a) = do
+  where_ $ isJustTable ma
+  pure a
+
+
+bindMaybeTable :: Monad m
+  => (a -> m (MaybeTable b)) -> MaybeTable a -> m (MaybeTable b)
+bindMaybeTable query (MaybeTable input a) = do
+  MaybeTable output b <- query a
+  pure $ MaybeTable (input <> output) b
+
+
+traverseMaybeTable :: (a -> Query b) -> MaybeTable a -> Query (MaybeTable b)
+traverseMaybeTable query ma@(MaybeTable input _) = do
+  MaybeTable output b <- optional (query =<< catMaybeTable ma)
+  where_ $ output ==. input
+  pure $ MaybeTable input b

src/Rel8/Query/Null.hs

@@ -0,0 +1,19 @@
+module Rel8.Query.Null
+  ( catNullable
+  )
+where
+
+-- base
+import Prelude
+
+-- rel8
+import Rel8.Expr ( Expr )
+import Rel8.Expr.Null ( isNonNull, unsafeUnnullify )
+import Rel8.Query ( Query )
+import Rel8.Query.Filter ( where_ )
+
+
+catNullable :: Expr (Maybe a) -> Query (Expr a)
+catNullable a = do
+  where_ $ isNonNull a
+  pure $ unsafeUnnullify a

src/Rel8/Query/Opaleye.hs

@@ -0,0 +1,34 @@
+module Rel8.Query.Opaleye
+  ( fromOpaleye
+  , toOpaleye
+  , mapOpaleye
+  , zipOpaleyeWith
+  )
+where
+
+-- base
+import Prelude
+
+-- opaleye
+import qualified Opaleye.Select as Opaleye
+
+-- rel8
+import {-# SOURCE #-} Rel8.Query ( Query( Query ) )
+
+
+fromOpaleye :: Opaleye.Select a -> Query a
+fromOpaleye = Query
+
+
+toOpaleye :: Query a -> Opaleye.Select a
+toOpaleye (Query a) = a
+
+
+mapOpaleye :: (Opaleye.Select a -> Opaleye.Select b) -> Query a -> Query b
+mapOpaleye f = fromOpaleye . f . toOpaleye
+
+
+zipOpaleyeWith :: ()
+  => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)
+  -> Query a -> Query b -> Query c
+zipOpaleyeWith f a b = fromOpaleye $ f (toOpaleye a) (toOpaleye b)

src/Rel8/Query/Optimize.hs

@@ -0,0 +1,200 @@
+{-# language ApplicativeDo #-}
+{-# language LambdaCase #-}
+
+{-# options -fno-warn-name-shadowing #-}
+
+module Rel8.Query.Optimize
+  ( optimize
+  )
+where
+
+-- base
+import Control.Applicative
+import Data.Functor.Identity
+import Prelude
+
+-- opaleye
+import Opaleye.Internal.HaskellDB.PrimQuery
+import Opaleye.Internal.PrimQuery
+
+
+optimize :: PrimQuery' a -> PrimQuery' a
+optimize =
+  transformOf primQuery optimisePredicates
+
+
+primQuery
+  :: Applicative f
+  => ( PrimQuery' a -> f ( PrimQuery' a ) ) -> PrimQuery' a -> f ( PrimQuery' a )
+primQuery f = \case
+  Aggregate bindingsAndPrimExpr primQuery -> do
+    primQuery <- f primQuery
+
+    return ( Aggregate bindingsAndPrimExpr primQuery )
+
+  DistinctOnOrderBy maybePrimExprs orderExprs primQuery -> do
+    primQuery <- f primQuery
+
+    return ( DistinctOnOrderBy maybePrimExprs orderExprs primQuery )
+
+  Limit limitOp primQuery -> do
+    primQuery <- f primQuery
+
+    return ( Limit limitOp primQuery )
+
+  Join joinType primExpr bindingsA bindingsB primQueryA primQueryB -> do
+    primQueryA <- f primQueryA
+    primQueryB <- f primQueryB
+
+    return ( Join joinType primExpr bindingsA bindingsB primQueryA primQueryB )
+
+  Exists bool primQueryA primQueryB -> do
+    primQueryA <- f primQueryA
+    primQueryB <- f primQueryB
+
+    return ( Exists bool primQueryA primQueryB )
+
+  Binary binOp primQueries -> do
+    primQueries <- both f primQueries
+
+    return ( Binary binOp primQueries  )
+
+  Label label primQuery -> do
+    primQuery <- f primQuery
+
+    return ( Label label primQuery )
+
+  other ->
+    pure other
+
+
+optimisePredicates :: PrimQuery' a -> PrimQuery' a
+optimisePredicates = \case
+  Join joinType predicate bindingsA bindingsB primQueryA primQueryB ->
+    Join joinType ( nullIsFalse predicate ) bindingsA bindingsB primQueryA primQueryB
+
+  other ->
+    other
+
+
+nullIsFalse :: PrimExpr -> PrimExpr
+nullIsFalse =
+  rewriteOf primExprs simplifyCaseAnalysis
+
+  where
+
+    simplifyCaseAnalysis = \case
+      CaseExpr [ ( UnExpr OpIsNull _, ConstExpr ( BoolLit False ) ) ] notNullBranch ->
+        Just notNullBranch
+
+      CaseExpr [ ( UnExpr OpIsNull x, UnExpr OpIsNull y ) ] notNullBranch ->
+        Just
+          ( BinExpr
+              (:||)
+              ( BinExpr (:&&) ( UnExpr OpIsNull x ) ( UnExpr OpIsNull y ) )
+              notNullBranch
+          )
+
+      _ ->
+        Nothing
+
+
+
+-- | Traverse all immediate 'PrimExpr's
+primExprs :: Applicative f => ( PrimExpr -> f PrimExpr ) -> PrimExpr -> f PrimExpr
+primExprs f = \case
+  AttrExpr ( Symbol string tag ) ->
+    pure ( AttrExpr ( Symbol string tag ) )
+
+  BaseTableAttrExpr attribute ->
+    pure ( BaseTableAttrExpr attribute )
+
+  CompositeExpr primExpr attribute -> do
+    primExpr <- f primExpr
+
+    return ( CompositeExpr primExpr attribute )
+
+  BinExpr binOp a b -> do
+    a <- f a
+    b <- f b
+
+    return ( BinExpr binOp a b )
+
+  UnExpr unOp primExpr -> do
+    primExpr <- f primExpr
+
+    return ( UnExpr unOp primExpr )
+
+  AggrExpr aggrDistinct aggrOp primExpr orderExprs -> do
+    aggrOp <- aggrOpPrimExprs f aggrOp
+    primExpr <- f primExpr
+    orderExprs <- traverse ( orderExprPrimExprs f ) orderExprs
+
+    return ( AggrExpr aggrDistinct aggrOp primExpr orderExprs )
+
+  ConstExpr l ->
+    pure ( ConstExpr l )
+
+  CaseExpr cases def -> do
+    cases <- traverse ( both f ) cases
+    def <- f def
+
+    return ( CaseExpr cases def )
+
+  other ->
+    pure other
+
+
+
+aggrOpPrimExprs :: Applicative f => ( PrimExpr -> f PrimExpr ) -> AggrOp -> f AggrOp
+aggrOpPrimExprs f = \case
+  AggrStringAggr primExpr -> do
+    primExpr <- f primExpr
+
+    return ( AggrStringAggr primExpr )
+
+  other ->
+    pure other
+
+
+orderExprPrimExprs :: Applicative f => ( PrimExpr -> f PrimExpr ) -> OrderExpr -> f OrderExpr
+orderExprPrimExprs f ( OrderExpr orderOp primExpr ) = do
+  primExpr <- f primExpr
+
+  return ( OrderExpr orderOp primExpr )
+
+
+-- | Traverse both sides of a homogeneous tuple.
+both :: Applicative f => ( t -> f b ) -> ( t, t ) -> f ( b, b )
+both f ( a,b ) =
+  liftA2 (,) ( f a ) ( f b )
+
+
+rewriteOf
+  :: ( ( a -> Identity a ) -> a -> Identity a )
+  -> ( a -> Maybe a ) -> a -> a
+rewriteOf l f =
+  go where
+
+  go = transformOf l ( \x -> maybe x go ( f x ) )
+
+
+transformOf
+  :: ( ( a -> Identity a ) -> a -> Identity a )
+  -> ( a -> a )
+  -> a
+  -> a
+{-# inline transformOf #-}
+transformOf l f = go where
+
+  go =
+    f . over l go
+
+
+over
+  :: ( ( s -> Identity t ) -> a -> Identity b )
+  -> ( s -> t )
+  -> a
+  -> b
+over l f =
+  runIdentity . l (Identity . f)

src/Rel8/Query/Order.hs

@@ -0,0 +1,19 @@
+module Rel8.Query.Order
+  ( orderBy
+  )
+where
+
+-- base
+import Prelude ()
+
+-- opaleye
+import qualified Opaleye.Order as Opaleye ( orderBy )
+
+-- rel8
+import Rel8.Order ( Order( Order ) )
+import Rel8.Query ( Query )
+import Rel8.Query.Opaleye ( mapOpaleye )
+
+
+orderBy :: Order a -> Query a -> Query a
+orderBy (Order o) = mapOpaleye (Opaleye.orderBy o)

src/Rel8/Query/SQL.hs

@@ -0,0 +1,72 @@
+{-# language FlexibleContexts #-}
+{-# language TypeFamilies #-}
+{-# language ViewPatterns #-}
+
+module Rel8.Query.SQL
+  ( showQuery
+  , sqlForQuery, sqlForQueryWithNames
+  )
+where
+
+-- base
+import Data.Foldable ( fold )
+import Data.Functor.Const ( Const( Const ), getConst )
+import Data.Void ( Void )
+import Prelude
+
+-- opaleye
+import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye
+import qualified Opaleye.Internal.PrimQuery as Opaleye
+import qualified Opaleye.Internal.Print as Opaleye
+import qualified Opaleye.Internal.Optimize as Opaleye
+import qualified Opaleye.Internal.QueryArr as Opaleye hiding ( Select )
+import qualified Opaleye.Internal.Sql as Opaleye
+
+-- rel8
+import Rel8.Expr.Opaleye ( unsafeToPrimExpr )
+import Rel8.Query ( Query )
+import Rel8.Query.Opaleye ( toOpaleye )
+import qualified Rel8.Query.Optimize as Rel8 ( optimize )
+import Rel8.Schema.Context ( DB( DB ), Name( Name ) )
+import Rel8.Schema.HTable ( htabulateA, hfield )
+import Rel8.Table ( Table, toColumns )
+import Rel8.Table.Name ( namesFromLabels )
+import Rel8.Table.Recontextualize ( Selects )
+
+
+showQuery :: Table DB a => Query a -> String
+showQuery = fold . sqlForQuery
+
+
+sqlForQuery :: Table DB a
+  => Query a -> Maybe String
+sqlForQuery = sqlForQueryWithNames namesFromLabels . fmap toColumns
+
+
+sqlForQueryWithNames :: Selects names exprs
+  => names -> Query exprs -> Maybe String
+sqlForQueryWithNames names query =
+  show . Opaleye.ppSql . selectFrom names exprs <$> optimize primQuery
+  where
+    (exprs, primQuery, _) =
+      Opaleye.runSimpleQueryArrStart (toOpaleye query) ()
+
+
+optimize :: Opaleye.PrimQuery' a -> Maybe (Opaleye.PrimQuery' Void)
+optimize = Opaleye.removeEmpty . Rel8.optimize . Opaleye.optimize
+
+
+selectFrom :: Selects names exprs
+  => names -> exprs -> Opaleye.PrimQuery' Void -> Opaleye.Select
+selectFrom (toColumns -> names) (toColumns -> exprs) query =
+  Opaleye.SelectFrom $ Opaleye.newSelect
+    { Opaleye.attrs = Opaleye.SelectAttrs attributes
+    , Opaleye.tables = Opaleye.oneTable select
+    }
+  where
+    select = Opaleye.foldPrimQuery Opaleye.sqlQueryGenerator query
+    attributes = getConst $ htabulateA $ \field -> case hfield names field of
+      Name name -> case hfield exprs field of
+        DB (unsafeToPrimExpr -> expr) -> Const (pure (makeAttr name expr))
+    makeAttr label expr =
+      (Opaleye.sqlExpr expr, Just (Opaleye.SqlColumn label))

src/Rel8/Query/Set.hs

@@ -0,0 +1,46 @@
+{-# language FlexibleContexts #-}
+
+module Rel8.Query.Set
+  ( union, unionAll
+  , intersect, intersectAll
+  , except, exceptAll
+  )
+where
+
+-- base
+import Prelude ()
+
+-- opaleye
+import qualified Opaleye.Binary as Opaleye
+
+-- rel8
+import {-# SOURCE #-} Rel8.Query ( Query )
+import Rel8.Query.Opaleye ( zipOpaleyeWith )
+import Rel8.Table ( Table  )
+import Rel8.Table.Eq ( EqTable )
+import Rel8.Table.Opaleye ( binaryspec )
+import Rel8.Schema.Context ( DB )
+
+
+union :: EqTable a => Query a -> Query a -> Query a
+union = zipOpaleyeWith (Opaleye.unionExplicit binaryspec)
+
+
+unionAll :: Table DB a => Query a -> Query a -> Query a
+unionAll = zipOpaleyeWith (Opaleye.unionAllExplicit binaryspec)
+
+
+intersect :: EqTable a => Query a -> Query a -> Query a
+intersect = zipOpaleyeWith (Opaleye.intersectExplicit binaryspec)
+
+
+intersectAll :: Table DB a => Query a -> Query a -> Query a
+intersectAll = zipOpaleyeWith (Opaleye.intersectAllExplicit binaryspec)
+
+
+except :: EqTable a => Query a -> Query a -> Query a
+except = zipOpaleyeWith (Opaleye.exceptExplicit binaryspec)
+
+
+exceptAll :: Table DB a => Query a -> Query a -> Query a
+exceptAll = zipOpaleyeWith (Opaleye.exceptAllExplicit binaryspec)

src/Rel8/Query/These.hs

@@ -0,0 +1,129 @@
+{-# language FlexibleContexts #-}
+
+module Rel8.Query.These
+  ( alignBy
+  , keepHereTable, loseHereTable
+  , keepThereTable, loseThereTable
+  , keepThisTable, loseThisTable
+  , keepThatTable, loseThatTable
+  , keepThoseTable, loseThoseTable
+  , bindTheseTable
+  , bitraverseTheseTable
+  )
+where
+
+-- base
+import Data.Bifunctor ( bimap )
+import Prelude
+
+-- opaleye
+import qualified Opaleye.Internal.Join as Opaleye
+import qualified Opaleye.Internal.PrimQuery as Opaleye
+
+-- rel8
+import Rel8.Expr ( Expr )
+import Rel8.Expr.Bool ( (&&.), boolExpr, not_ )
+import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )
+import Rel8.Expr.Serialize ( litExpr )
+import Rel8.Query ( Query )
+import Rel8.Query.Filter ( where_ )
+import Rel8.Query.Maybe ( traverseMaybeTable )
+import Rel8.Query.Opaleye ( zipOpaleyeWith )
+import Rel8.Schema.Context ( DB )
+import Rel8.Table ( Table )
+import Rel8.Table.Either ( EitherTable( EitherTable ) )
+import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
+import Rel8.Table.Opaleye ( unpackspec )
+import Rel8.Table.These
+  ( TheseTable( TheseTable )
+  , isThisTable, isThatTable, isThoseTable
+  )
+import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ) )
+
+
+alignBy :: (Table DB a, Table DB b)
+  => (a -> b -> Expr Bool)
+  -> Query a -> Query b -> Query (TheseTable a b)
+alignBy condition as bs =
+  uncurry TheseTable <$> zipOpaleyeWith fullOuterJoin as bs
+  where
+    fullOuterJoin a b =
+      Opaleye.joinExplicit unpackspec unpackspec pure pure full a b on
+      where
+        full = Opaleye.FullJoin
+        on = toColumn . toPrimExpr . uncurry condition
+
+
+keepHereTable :: TheseTable a b -> Query (a, MaybeTable b)
+keepHereTable = loseThatTable
+
+
+loseHereTable :: TheseTable a b -> Query b
+loseHereTable = keepThatTable
+
+
+keepThereTable :: TheseTable a b -> Query (MaybeTable a, b)
+keepThereTable = loseThisTable
+
+
+loseThereTable :: TheseTable a b -> Query a
+loseThereTable = keepThisTable
+
+
+keepThisTable :: TheseTable a b -> Query a
+keepThisTable t@(TheseTable (MaybeTable _ a) _) = do
+  where_ $ isThisTable t
+  pure a
+
+
+loseThisTable :: TheseTable a b -> Query (MaybeTable a, b)
+loseThisTable t@(TheseTable ma (MaybeTable _ b)) = do
+  where_ $ not_ $ isThisTable t
+  pure (ma, b)
+
+
+keepThatTable :: TheseTable a b -> Query b
+keepThatTable t@(TheseTable _ (MaybeTable _ b)) = do
+  where_ $ isThatTable t
+  pure b
+
+
+loseThatTable :: TheseTable a b -> Query (a, MaybeTable b)
+loseThatTable t@(TheseTable (MaybeTable _ a) mb) = do
+  where_ $ not_ $ isThatTable t
+  pure (a, mb)
+
+
+keepThoseTable :: TheseTable a b -> Query (a, b)
+keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
+  where_ $ isThoseTable t
+  pure (a, b)
+
+
+loseThoseTable :: TheseTable a b -> Query (EitherTable a b)
+loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
+  where_ $ not_ $ isThoseTable t
+  pure $ EitherTable tag a b
+  where
+    tag = boolExpr (litExpr IsLeft) (litExpr IsRight) (isThatTable t)
+
+
+bindTheseTable :: (Table DB a, Semigroup a, Monad m)
+  => (i -> m (TheseTable a b)) -> TheseTable a i -> m (TheseTable a b)
+bindTheseTable query (TheseTable here (MaybeTable input i)) = do
+  TheseTable here' (MaybeTable output b) <- query i
+  pure $ TheseTable (here <> here') (MaybeTable (input <> output) b)
+
+
+bitraverseTheseTable :: (Table DB c, Table DB d)
+  => (a -> Query c)
+  -> (b -> Query d)
+  -> TheseTable a b
+  -> Query (TheseTable c d)
+bitraverseTheseTable f g (TheseTable here there) =
+  bimap fromJustTable fromJustTable <$>
+    alignBy (\l r -> isJustTable l &&. isJustTable r)
+      (traverseMaybeTable f here)
+      (traverseMaybeTable g there)
+  where
+    fromJustTable (MaybeTable _ a) = a

src/Rel8/Query/Values.hs

@@ -0,0 +1,24 @@
+{-# language FlexibleContexts #-}
+
+module Rel8.Query.Values
+  ( values
+  )
+where
+
+-- base
+import Data.Foldable ( toList )
+import Prelude
+
+-- opaleye
+import qualified Opaleye.Values as Opaleye
+
+-- rel8
+import {-# SOURCE #-} Rel8.Query ( Query )
+import Rel8.Query.Opaleye ( fromOpaleye )
+import Rel8.Table ( Table )
+import Rel8.Table.Opaleye ( valuesspec )
+import Rel8.Schema.Context ( DB )
+
+
+values :: (Table DB a, Foldable f) => f a -> Query a
+values = fromOpaleye . Opaleye.valuesExplicit valuesspec . toList

src/Rel8/Schema/Column.hs

@@ -0,0 +1,141 @@
+{-# language DataKinds #-}
+{-# language TypeFamilies #-}
+{-# language StandaloneKindSignatures #-}
+
+module Rel8.Schema.Column
+  ( Column, Default, Label
+  , HEither
+  , HList
+  , HMaybe
+  , HNonEmpty
+  , HThese
+  )
+where
+
+-- base
+import Data.Kind ( Type )
+import Data.List.NonEmpty ( NonEmpty )
+import GHC.TypeLits ( Symbol )
+import Prelude
+
+-- rel8
+import Rel8.Kind.Labels ( Labels )
+import Rel8.Kind.Necessity ( Necessity( Required, Optional ) )
+import Rel8.Schema.Context ( Result, IsSpecialContext )
+import Rel8.Schema.Field ( Field )
+import Rel8.Schema.Nullability ( Unnullify )
+import Rel8.Schema.Spec ( Context )
+import Rel8.Schema.Structure
+  ( Structure
+  , Shape( Either, List, Maybe, NonEmpty, These )
+  , Shape1
+  , Shape2
+  )
+import Rel8.Table.Either ( EitherTable )
+import Rel8.Table.List ( ListTable )
+import Rel8.Table.Maybe ( MaybeTable )
+import Rel8.Table.NonEmpty ( NonEmptyTable )
+import Rel8.Table.These ( TheseTable )
+
+-- these
+import Data.These ( These )
+
+
+type Label :: Symbol -> Type -> Type
+data Label label a
+
+
+type Default :: Type -> Type
+data Default a
+
+
+type GetLabel :: Type -> Labels
+type family GetLabel a where
+  GetLabel (Label label _) = '[label]
+  GetLabel _ = '[]
+
+
+type UnwrapLabel :: Type -> Type
+type family UnwrapLabel a where
+  UnwrapLabel (Label _ a) = a
+  UnwrapLabel a = a
+
+
+type GetNecessity :: Type -> Necessity
+type family GetNecessity a where
+  GetNecessity (Default _) = 'Optional
+  GetNecessity _ = 'Required
+
+
+type UnwrapDefault :: Type -> Type
+type family UnwrapDefault a where
+  UnwrapDefault (Default a) = a
+  UnwrapDefault a = a
+
+
+type Column :: Context -> Type -> Type
+type Column context a =
+  Field context (GetLabel a)
+    (GetNecessity (UnwrapLabel a))
+    (Unnullify (UnwrapDefault (UnwrapLabel a)))
+    (UnwrapDefault (UnwrapLabel a))
+
+
+type IHEither :: Bool -> Context -> Type -> Type -> Type
+type family IHEither isSpecialContext context where
+  IHEither 'False _ = EitherTable
+  IHEither 'True Result = Either
+  IHEither 'True Structure = Shape2 'Either
+  IHEither 'True _ = EitherTable
+
+
+type IHList :: Bool -> Context -> Type -> Type
+type family IHList isSpecialContext context where
+  IHList 'False _ = ListTable
+  IHList 'True Result = []
+  IHList 'True Structure = Shape1 'List
+  IHList 'True _ = ListTable
+
+
+type IHMaybe :: Bool -> Context -> Type -> Type
+type family IHMaybe isSpecialContext context where
+  IHMaybe 'False _ = MaybeTable
+  IHMaybe 'True Result = Maybe
+  IHMaybe 'True Structure = Shape1 'Maybe
+  IHMaybe 'True _ = MaybeTable
+
+
+type IHNonEmpty :: Bool -> Context -> Type -> Type
+type family IHNonEmpty isSpecialContext context where
+  IHNonEmpty 'False _ = NonEmptyTable
+  IHNonEmpty 'True Result = NonEmpty
+  IHNonEmpty 'True Structure = Shape1 'NonEmpty
+  IHNonEmpty 'True _ = NonEmptyTable
+
+
+type IHThese :: Bool -> Context -> Type -> Type -> Type
+type family IHThese isSpecialContext context where
+  IHThese 'False _ = TheseTable
+  IHThese 'True Result = These
+  IHThese 'True Structure = Shape2 'These
+  IHThese 'True _ = TheseTable
+
+
+type HEither :: Context -> Type -> Type -> Type
+type HEither context = IHEither (IsSpecialContext context) context
+
+
+type HList :: Context -> Type -> Type
+type HList context = IHList (IsSpecialContext context) context
+
+
+type HMaybe :: Context -> Type -> Type
+type HMaybe context = IHMaybe (IsSpecialContext context) context
+
+
+type HNonEmpty :: Context -> Type -> Type
+type HNonEmpty context = IHNonEmpty (IsSpecialContext context) context
+
+
+type HThese :: Context -> Type -> Type -> Type
+type HThese context = IHThese (IsSpecialContext context) context

src/Rel8/Schema/Context.hs

@@ -0,0 +1,144 @@
+{-# language DataKinds #-}
+{-# language DerivingStrategies #-}
+{-# language FlexibleInstances #-}
+{-# language GADTs #-}
+{-# language GeneralizedNewtypeDeriving #-}
+{-# language ScopedTypeVariables #-}
+{-# language StandaloneDeriving #-}
+{-# language StandaloneKindSignatures #-}
+{-# language TypeApplications #-}
+{-# language TypeFamilies #-}
+{-# language UndecidableInstances #-}
+
+module Rel8.Schema.Context
+  ( Aggregation( Aggregation )
+  , DB( DB, unDB )
+  , Insertion( RequiredInsert, OptionalInsert )
+  , Name( Name )
+  , Result( Result )
+  , IsSpecialContext
+  )
+where
+
+-- base
+import Control.Applicative ( liftA2 )
+import Data.String ( IsString )
+import Prelude
+
+-- rel8
+import Rel8.Aggregate ( Aggregate )
+import Rel8.Expr ( Expr )
+import Rel8.Kind.Necessity
+  ( Necessity( Optional, Required )
+  , SNecessity( SOptional, SRequired )
+  , KnownNecessity, necessitySing
+  )
+import Rel8.Schema.Nullability ( Nullabilizes )
+import Rel8.Schema.Spec ( Context, Spec( Spec ) )
+import Rel8.Schema.Structure ( Structure )
+import Rel8.Type.Monoid ( DBMonoid )
+import Rel8.Type.Semigroup ( DBSemigroup )
+
+
+type Aggregation :: Context
+data Aggregation spec where
+  Aggregation :: ()
+    => Aggregate (Expr a)
+    -> Aggregation ('Spec labels necessity dbType a)
+
+
+type DB :: Context
+data DB spec where
+  DB :: ()
+    => { unDB :: Expr a }
+    -> DB ('Spec labels necessity dbType a)
+deriving stock instance Show (DB spec)
+
+
+instance
+  ( spec ~ 'Spec labels necessity dbType a
+  , DBSemigroup dbType
+  , Nullabilizes dbType a
+  ) =>
+  Semigroup (DB spec)
+ where
+  DB a <> DB b = DB (a <> b)
+
+
+instance
+  ( spec ~ 'Spec labels necessity dbType a
+  , DBMonoid dbType
+  , Nullabilizes dbType a
+  ) =>
+  Monoid (DB spec)
+ where
+  mempty = DB mempty
+
+
+type Insertion :: Context
+data Insertion spec where
+  RequiredInsert :: ()
+    => Expr a
+    -> Insertion ('Spec labels 'Required dbType a)
+  OptionalInsert :: ()
+    => Maybe (Expr a)
+    -> Insertion ('Spec labels 'Optional dbType a)
+deriving stock instance Show (Insertion spec)
+
+
+instance
+  ( spec ~ 'Spec labels necessity dbType a
+  , DBSemigroup dbType
+  , Nullabilizes dbType a
+  ) =>
+  Semigroup (Insertion spec)
+ where
+  RequiredInsert a <> RequiredInsert b = RequiredInsert (a <> b)
+  OptionalInsert ma <> OptionalInsert mb = OptionalInsert (liftA2 (<>) ma mb)
+
+
+instance
+  ( spec ~ 'Spec labels necessity dbType a
+  , KnownNecessity necessity
+  , DBMonoid dbType
+  , Nullabilizes dbType a
+  ) => Monoid (Insertion spec)
+ where
+  mempty = case necessitySing @necessity of
+    SRequired -> RequiredInsert mempty
+    SOptional -> OptionalInsert (Just mempty)
+
+
+type Name :: Context
+newtype Name spec = Name String
+  deriving stock Show
+  deriving newtype (IsString, Monoid, Semigroup)
+
+
+type Result :: Context
+data Result spec where
+  Result :: a -> Result ('Spec labels necessity dbType a)
+deriving stock instance Show a =>
+  Show (Result ('Spec labels necessity dbType a))
+
+
+instance (spec ~ 'Spec labels necessity dbType a, Semigroup a) =>
+  Semigroup (Result spec)
+ where
+  Result a <> Result b = Result (a <> b)
+
+
+instance (spec ~ 'Spec labels necessity dbType a, Monoid a) =>
+  Monoid (Result spec)
+ where
+  mempty = Result mempty
+
+
+type IsSpecialContext :: Context -> Bool
+type family IsSpecialContext context where
+  IsSpecialContext Aggregation = 'True
+  IsSpecialContext DB = 'True
+  IsSpecialContext Insertion = 'True
+  IsSpecialContext Result = 'True
+  IsSpecialContext Structure = 'True
+  IsSpecialContext _ = 'False

src/Rel8/Schema/Context/Label.hs

@@ -0,0 +1,67 @@
+{-# language DataKinds #-}
+{-# language LambdaCase #-}
+{-# language FlexibleInstances #-}
+{-# language MultiParamTypeClasses #-}
+{-# language StandaloneKindSignatures #-}
+{-# language TypeFamilies #-}
+{-# language TypeOperators #-}
+
+module Rel8.Schema.Context.Label
+  ( Labelable( labeler, unlabeler )
+  )
+where
+
+-- base
+import Data.Kind ( Constraint )
+import Prelude hiding ( null )
+
+-- rel8
+import Rel8.Schema.Context
+  ( Aggregation( Aggregation )
+  , DB( DB )
+  , Insertion( RequiredInsert, OptionalInsert )
+  , Name( Name )
+  , Result( Result )
+  )
+import Rel8.Schema.Spec ( Context, Spec( Spec ) )
+
+
+type Labelable :: Context -> Constraint
+class Labelable context where
+  labeler :: ()
+    => context ('Spec labels necessity db a)
+    -> context ('Spec (label ': labels) necessity db a)
+
+  unlabeler :: ()
+    => context ('Spec (label ': labels) necessity db a)
+    -> context ('Spec labels necessity db a)
+
+
+instance Labelable Aggregation where
+  labeler (Aggregation aggregate) = Aggregation aggregate
+  unlabeler (Aggregation aggregate) = Aggregation aggregate
+
+
+instance Labelable DB where
+  labeler (DB a) = DB a
+  unlabeler (DB a) = DB a
+
+
+instance Labelable Insertion where
+  labeler = \case
+    RequiredInsert a -> RequiredInsert a
+    OptionalInsert ma -> OptionalInsert ma
+
+  unlabeler = \case
+    RequiredInsert a -> RequiredInsert a
+    OptionalInsert ma -> OptionalInsert ma
+
+
+instance Labelable Name where
+  labeler (Name name) = Name name
+  unlabeler (Name name) = Name name
+
+
+instance Labelable Result where
+  labeler (Result a) = Result a
+  unlabeler (Result a) = Result a

src/Rel8/Schema/Context/Nullify.hs

@@ -0,0 +1,165 @@
+{-# language DataKinds #-}
+{-# language LambdaCase #-}
+{-# language FlexibleContexts #-}
+{-# language FlexibleInstances #-}
+{-# language MultiParamTypeClasses #-}
+{-# language NamedFieldPuns #-}
+{-# language ScopedTypeVariables #-}
+{-# language StandaloneKindSignatures #-}
+{-# language TypeApplications #-}
+{-# language TypeFamilies #-}
+
+module Rel8.Schema.Context.Nullify
+  ( Nullifiable( encodeTag, decodeTag, nullifier, unnullifier )
+  , NullifiableEq
+  )
+where
+
+-- base
+import Control.Applicative ( empty )
+import Data.Foldable ( fold )
+import Data.Kind ( Constraint )
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.Monoid ( First( First ), getFirst )
+import Prelude hiding ( null )
+
+-- opaleye
+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
+
+-- rel8
+import Rel8.Aggregate ( Aggregate, foldInputs, mapInputs )
+import Rel8.Expr ( Expr( Expr ) )
+import Rel8.Expr.Aggregate ( groupByExpr )
+import Rel8.Expr.Bool ( boolExpr )
+import Rel8.Expr.Null ( nullify, unsafeUnnullify )
+import Rel8.Expr.Opaleye ( unsafeFromPrimExpr, unsafeToPrimExpr )
+import Rel8.Kind.Labels ( KnownLabels, labelsSing, renderLabels )
+import Rel8.Kind.Necessity ( Necessity( Required ) )
+import Rel8.Schema.Context
+  ( Aggregation( Aggregation )
+  , DB( DB )
+  , Insertion( RequiredInsert, OptionalInsert )
+  , Name( Name )
+  )
+import Rel8.Schema.Nullability
+  ( Nullability( Nullable, NonNullable )
+  , Nullabilizes
+  )
+import Rel8.Schema.Spec ( Context, Spec( Spec ), SSpec(..) )
+import Rel8.Type.Eq ( DBEq )
+import Rel8.Type.Monoid ( DBMonoid )
+
+
+type Nullifiable :: Context -> Constraint
+class Nullifiable context where
+  encodeTag :: (DBEq db, Nullabilizes db a, KnownLabels labels)
+    => Expr a
+    -> context ('Spec labels 'Required db a)
+
+  decodeTag :: (DBMonoid db, Nullabilizes db a)
+    => context ('Spec labels 'Required db a)
+    -> Expr a
+
+  nullifier :: ()
+    => Expr Bool
+    -> SSpec ('Spec labels necessity db a)
+    -> context ('Spec labels necessity db a)
+    -> context ('Spec labels necessity db (Maybe db))
+
+  unnullifier :: ()
+    => Expr Bool
+    -> SSpec ('Spec labels necessity db a)
+    -> context ('Spec labels necessity db (Maybe db))
+    -> context ('Spec labels necessity db a)
+
+
+instance Nullifiable Aggregation where
+  encodeTag = Aggregation . groupByExpr
+  decodeTag (Aggregation aggregate) = fold $ undoGroupBy aggregate
+
+  nullifier tag SSpec {nullability} (Aggregation aggregate) = Aggregation $
+    mapInputs (unsafeToPrimExpr . runTag nullability tag . unsafeFromPrimExpr) $
+    runTag nullability tag <$> aggregate
+
+  unnullifier _ SSpec {nullability} (Aggregation aggregate) =
+    Aggregation $ unnull nullability <$> aggregate
+
+  {-# INLINABLE encodeTag #-}
+  {-# INLINABLE decodeTag #-}
+  {-# INLINABLE nullifier #-}
+  {-# INLINABLE unnullifier #-}
+
+
+instance Nullifiable DB where
+  encodeTag = DB
+  decodeTag (DB a) = a
+  nullifier tag SSpec {nullability} (DB a) = DB $ runTag nullability tag a
+  unnullifier _ SSpec {nullability} (DB a) = DB $ unnull nullability a
+
+  {-# INLINABLE encodeTag #-}
+  {-# INLINABLE decodeTag #-}
+  {-# INLINABLE nullifier #-}
+  {-# INLINABLE unnullifier #-}
+
+
+instance Nullifiable Insertion where
+  encodeTag = RequiredInsert
+  decodeTag (RequiredInsert a) = a
+
+  nullifier tag SSpec {nullability} = \case
+    RequiredInsert a -> RequiredInsert $ runTag nullability tag a
+    OptionalInsert ma -> OptionalInsert $ runTag nullability tag <$> ma
+
+  unnullifier _ SSpec {nullability} = \case
+    RequiredInsert a -> RequiredInsert $ unnull nullability a
+    OptionalInsert ma -> OptionalInsert $ unnull nullability <$> ma
+
+  {-# INLINABLE encodeTag #-}
+  {-# INLINABLE decodeTag #-}
+  {-# INLINABLE nullifier #-}
+  {-# INLINABLE unnullifier #-}
+
+
+instance Nullifiable Name where
+  encodeTag _ = nameFromLabel
+  decodeTag _ = mempty
+  nullifier _ _ (Name name) = Name name
+  unnullifier _ _ (Name name) = Name name
+
+  {-# INLINABLE encodeTag #-}
+  {-# INLINABLE decodeTag #-}
+  {-# INLINABLE nullifier #-}
+  {-# INLINABLE unnullifier #-}
+
+
+type NullifiableEq :: Context -> Context -> Constraint
+class (a ~ b, Nullifiable b) => NullifiableEq a b
+instance (a ~ b, Nullifiable b) => NullifiableEq a b
+
+
+runTag :: Nullability db a -> Expr Bool -> Expr a -> Expr (Maybe db)
+runTag nullability tag a = case nullability of
+  Nullable -> boolExpr null a tag
+  NonNullable -> boolExpr null (nullify a) tag
+  where
+    null = Expr (Opaleye.ConstExpr Opaleye.NullLit)
+
+
+unnull :: Nullability db a -> Expr (Maybe db) -> Expr a
+unnull nullability a = case nullability of
+  Nullable -> a
+  NonNullable -> unsafeUnnullify a
+
+
+-- HACK
+undoGroupBy :: Aggregate (Expr _a) -> Maybe (Expr a)
+undoGroupBy = getFirst . foldInputs go
+  where
+    go Nothing a = pure (Expr a)
+    go _ _ = First empty
+
+
+nameFromLabel :: forall labels necessity db a.
+  KnownLabels labels => Name ('Spec labels necessity db a)
+nameFromLabel = case labelsSing @labels of
+  labels -> Name (NonEmpty.last (renderLabels labels))

src/Rel8/Schema/Context/Result.hs

@@ -0,0 +1,198 @@
+{-# language DataKinds #-}
+{-# language DisambiguateRecordFields #-}
+{-# language NamedFieldPuns #-}
+{-# language TypeFamilies #-}
+
+module Rel8.Schema.Context.Result
+  ( fromHEitherTable, toHEitherTable
+  , fromHListTable, toHListTable
+  , fromHMaybeTable, toHMaybeTable
+  , fromHNonEmptyTable, toHNonEmptyTable
+  , fromHTheseTable, toHTheseTable
+  )
+where
+
+-- base
+import Data.Functor ( ($>) )
+import Data.List.NonEmpty ( NonEmpty )
+import Prelude hiding ( null )
+
+-- rel8
+import Rel8.Schema.Context ( Result( Result ) )
+import Rel8.Schema.HTable ( HTable )
+import Rel8.Schema.HTable.Context ( H )
+import Rel8.Schema.HTable.Either ( HEitherTable(..) )
+import Rel8.Schema.HTable.Identity ( HIdentity(..) )
+import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
+import Rel8.Schema.HTable.List ( HListTable )
+import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable )
+import Rel8.Schema.HTable.Nullify ( hnulls, hnullify, hunnullify )
+import Rel8.Schema.HTable.These ( HTheseTable(..) )
+import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize )
+import Rel8.Schema.Nullability
+  ( Nullability( Nullable, NonNullable )
+  )
+import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
+import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ),  MaybeTag( IsJust ) )
+
+-- these
+import Data.These ( These( This, That, These ) )
+import Data.These.Combinators ( justHere, justThere )
+
+
+toHEitherTable :: (HTable t, HTable u)
+  => Either (t (H Result)) (u (H Result))
+  -> HEitherTable t u (H Result)
+toHEitherTable = either hleft hright
+  where
+    hleft table = HEitherTable
+      { htag = HIdentity (Result IsLeft)
+      , hleft = hnullify nullifier table
+      , hright = hnulls null
+      }
+    hright table = HEitherTable
+      { htag = HIdentity (Result IsRight)
+      , hleft = hnulls null
+      , hright = hnullify nullifier table
+      }
+{-# INLINABLE toHEitherTable #-}
+
+
+fromHEitherTable :: (HTable t, HTable u)
+  => HEitherTable t u (H Result)
+  -> Either (t (H Result)) (u (H Result))
+fromHEitherTable HEitherTable {htag, hleft, hright} = case htag of
+  HIdentity (Result tag) -> case tag of
+    IsLeft -> maybe err Left $ hunnullify unnullifier hleft
+    IsRight -> maybe err Right $ hunnullify unnullifier hright
+  where
+    err = error "fromHEitherTable: mismatch between tag and data"
+{-# INLINABLE fromHEitherTable #-}
+
+
+toHListTable :: HTable t => [t (H Result)] -> HListTable t (H Result)
+toHListTable = hvectorize vectorizer
+{-# INLINABLE toHListTable #-}
+
+
+fromHListTable :: HTable t => HListTable t (H Result) -> [t (H Result)]
+fromHListTable = hunvectorize unvectorizer
+{-# INLINABLE fromHListTable #-}
+
+
+toHMaybeTable :: HTable t => Maybe (t (H Result)) -> HMaybeTable t (H Result)
+toHMaybeTable = maybe hnothing hjust
+  where
+    hnothing = HMaybeTable
+      { htag = HIdentity (Result Nothing)
+      , hjust = hnulls null
+      }
+    hjust table = HMaybeTable
+      { htag = HIdentity (Result (Just IsJust))
+      , hjust = hnullify nullifier table
+      }
+{-# INLINABLE toHMaybeTable #-}
+
+
+fromHMaybeTable :: HTable t => HMaybeTable t (H Result) -> Maybe (t (H Result))
+fromHMaybeTable HMaybeTable {htag, hjust} = case htag of
+  HIdentity (Result tag) -> tag $>
+    case hunnullify unnullifier hjust of
+      Nothing -> error "fromHMaybeTable: mismatch between tag and data"
+      Just just -> just
+{-# INLINABLE fromHMaybeTable #-}
+
+
+toHNonEmptyTable :: HTable t => NonEmpty (t (H Result)) -> HNonEmptyTable t (H Result)
+toHNonEmptyTable = hvectorize vectorizer
+{-# INLINABLE toHNonEmptyTable #-}
+
+
+fromHNonEmptyTable :: HTable t => HNonEmptyTable t (H Result) -> NonEmpty (t (H Result))
+fromHNonEmptyTable = hunvectorize unvectorizer
+{-# INLINABLE fromHNonEmptyTable #-}
+
+
+toHTheseTable :: (HTable t, HTable u)
+  => These (t (H Result)) (u (H Result))
+  -> HTheseTable t u (H Result)
+toHTheseTable tables = HTheseTable
+  { hhereTag = relabel hhereTag
+  , hhere
+  , hthereTag = relabel hthereTag
+  , hthere
+  }
+  where
+    HMaybeTable
+      { htag = hhereTag
+      , hjust = hhere
+      } = toHMaybeTable (justHere tables)
+    HMaybeTable
+      { htag = hthereTag
+      , hjust = hthere
+      } = toHMaybeTable (justThere tables)
+{-# INLINABLE toHTheseTable #-}
+
+
+fromHTheseTable :: (HTable t, HTable u)
+  => HTheseTable t u (H Result)
+  -> These (t (H Result)) (u (H Result))
+fromHTheseTable HTheseTable {hhereTag, hhere, hthereTag, hthere} =
+  case (fromHMaybeTable mhere, fromHMaybeTable mthere) of
+    (Just a, Nothing) -> This a
+    (Nothing, Just b) -> That b
+    (Just a, Just b) -> These a b
+    _ -> error "fromHTheseTable: mismatch between tags and data"
+  where
+    mhere = HMaybeTable
+      { htag = relabel hhereTag
+      , hjust = hhere
+      }
+    mthere = HMaybeTable
+      { htag = relabel hthereTag
+      , hjust = hthere
+      }
+{-# INLINABLE fromHTheseTable #-}
+
+
+null :: Result ('Spec labels necessity db (Maybe db))
+null = Result Nothing
+
+
+nullifier :: ()
+  => SSpec ('Spec labels necessity db a)
+  -> Result ('Spec labels necessity db a)
+  -> Result ('Spec labels necessity db (Maybe db))
+nullifier SSpec {nullability} (Result a) = Result $ case nullability of
+  Nullable -> a
+  NonNullable -> Just a
+
+
+unnullifier :: ()
+  => SSpec ('Spec labels necessity db a)
+  -> Result ('Spec labels necessity db (Maybe db))
+  -> Maybe (Result ('Spec labels necessity db a))
+unnullifier SSpec {nullability} (Result a) =
+  case nullability of
+    Nullable -> pure $ Result a
+    NonNullable -> Result <$> a
+
+
+vectorizer :: Functor f
+  => SSpec ('Spec labels necessity db a)
+  -> f (Result ('Spec labels necessity db a))
+  -> Result ('Spec labels necessity (f a) (f a))
+vectorizer _ = Result . fmap (\(Result a) -> a)
+
+
+unvectorizer :: Functor f
+  => SSpec ('Spec labels necessity db a)
+  -> Result ('Spec labels necessity (f a) (f a))
+  -> f (Result ('Spec labels necessity db a))
+unvectorizer _ (Result results) = Result <$> results
+
+
+relabel :: ()
+  => HIdentity ('Spec labels necessity db a) (H Result)
+  -> HIdentity ('Spec relabels necessity db a) (H Result)
+relabel (HIdentity (Result a)) = HIdentity (Result a)

src/Rel8/Schema/Dict.hs

@@ -0,0 +1,18 @@
+{-# language ConstraintKinds #-}
+{-# language GADTs #-}
+{-# language PolyKinds #-}
+{-# language StandaloneKindSignatures #-}
+
+module Rel8.Schema.Dict
+  ( Dict( Dict )
+  )
+where
+
+-- base
+import Data.Kind ( Constraint, Type )
+import Prelude ()
+
+
+type Dict :: (a -> Constraint) -> a -> Type
+data Dict c a where
+  Dict :: c a => Dict c a

src/Rel8/Schema/Field.hs

@@ -0,0 +1,41 @@
+{-# language DataKinds #-}
+{-# language StandaloneKindSignatures #-}
+{-# language TypeFamilies #-}
+{-# language UndecidableInstances #-}
+
+module Rel8.Schema.Field
+  ( Field
+  )
+where
+
+-- base
+import Data.Kind ( Type )
+import Prelude
+
+-- rel8
+import Rel8.Aggregate ( Aggregate )
+import Rel8.Expr ( Expr )
+import Rel8.Kind.Labels ( Labels )
+import Rel8.Kind.Necessity ( Necessity( Required, Optional ) )
+import Rel8.Schema.Context
+  ( Aggregation, DB, Insertion, Result
+  , IsSpecialContext
+  )
+import Rel8.Schema.Spec ( Context, Spec( Spec ) )
+import Rel8.Schema.Structure ( Structure, Shape( Column ), Shape1 )
+
+
+type IField :: Bool -> Context -> Labels -> Necessity -> Type -> Type -> Type
+type family IField isSpecialContext labels context necessity db a where
+  IField 'False context     labels  necessity  db  a = context ('Spec labels necessity db a)
+  IField 'True  Result      _labels _necessity _db a = a
+  IField 'True  DB          _labels _necessity _db a = Expr a
+  IField 'True  Insertion   _labels 'Required  _db a = Expr a
+  IField 'True  Insertion   _labels 'Optional  _db a = Maybe (Expr a)
+  IField 'True  Aggregation _labels _necessity _db a = Aggregate (Expr a)
+  IField 'True  Structure   labels necessity   db  a = Shape1 'Column ('Spec labels necessity db a)
+
+
+type Field :: Context -> Labels -> Necessity -> Type -> Type -> Type
+type Field context labels necessity db a =
+  IField (IsSpecialContext context) context labels necessity db a

src/Rel8/Schema/Generic/Test.hs

@@ -0,0 +1,79 @@
+{-# language DataKinds #-}
+{-# language DeriveAnyClass #-}
+{-# language DeriveGeneric #-}
+{-# language DerivingStrategies #-}
+{-# language DuplicateRecordFields #-}
+
+{-# options_ghc -O0 #-}
+
+module Rel8.Schema.Generic.Test
+  ( module Rel8.Schema.Generic.Test
+  )
+where
+
+-- base
+import GHC.Generics ( Generic )
+import Prelude
+
+-- rel8
+import Rel8.Schema.Column
+import Rel8.Schema.Generic
+
+-- text
+import Data.Text ( Text )
+
+
+data Table f = Table
+  { foo :: Column f (Label "blah" Bool)
+  , bar :: Column f (Maybe Bool)
+  }
+  deriving stock Generic
+  deriving anyclass Rel8able
+
+
+data TablePair f = TablePair
+  { foo :: Column f (Default Bool)
+  , bars :: (Column f Text, Column f Text)
+  }
+  deriving stock Generic
+  deriving anyclass Rel8able
+
+
+data TableMaybe f = TableMaybe
+  { foo :: Column f (Label "ABC" [Maybe Bool])
+  , bars :: HMaybe f (TablePair f, TablePair f)
+  }
+  deriving stock Generic
+  deriving anyclass Rel8able
+
+
+data TableEither f = TableEither
+  { foo :: Column f Bool
+  , bars :: HEither f (HMaybe f (TablePair f, TablePair f)) (Column f (Label "XYZ" Char))
+  }
+  deriving stock Generic
+  deriving anyclass Rel8able
+
+
+data TableThese f = TableThese
+  { foo :: Column f Bool
+  , bars :: HThese f (TableMaybe f) (TableEither f)
+  }
+  deriving stock Generic
+  deriving anyclass Rel8able
+
+
+data TableList f = TableList
+  { foo :: Column f Bool
+  , bars :: HList f (TableThese f)
+  }
+  deriving stock Generic
+  deriving anyclass Rel8able
+
+
+data TableNonEmpty f = TableNonEmpty
+  { foo :: Column f Bool
+  , bars :: HNonEmpty f (TableList f)
+  }
+  deriving stock Generic
+  deriving anyclass Rel8able

src/Rel8/Schema/HTable.hs

@@ -0,0 +1,173 @@
+{-# language AllowAmbiguousTypes #-}
+{-# language DataKinds #-}
+{-# language DefaultSignatures #-}
+{-# language FlexibleContexts #-}
+{-# language FlexibleInstances #-}
+{-# language FunctionalDependencies #-}
+{-# language LambdaCase #-}
+{-# language RankNTypes #-}
+{-# language ScopedTypeVariables #-}
+{-# language StandaloneKindSignatures #-}
+{-# language TypeApplications #-}
+{-# language TypeFamilyDependencies #-}
+{-# language TypeOperators #-}
+{-# language UndecidableInstances #-}
+
+module Rel8.Schema.HTable
+  ( HTable (HField, HConstrainTable)
+  , hfield, htabulate, htraverse, hdicts, hspecs
+  , htabulateA
+
+  , HPair(..)
+  )
+where
+
+-- base
+import Data.Kind ( Constraint, Type )
+import Data.Functor.Compose ( Compose( Compose ), getCompose )
+import Data.Proxy ( Proxy )
+import GHC.Generics
+  ( (:*:)( (:*:) )
+  , Generic (Rep, from, to)
+  , K1( K1 )
+  , M1( M1 )
+  )
+import Prelude
+
+-- rel8
+import Rel8.Schema.Dict ( Dict )
+import Rel8.Schema.Spec ( Spec, SSpec, Context )
+import Rel8.Schema.HTable.Context ( HKTable, H )
+import Rel8.Schema.HTable.Pair ( HPair( HPair ) )
+
+-- semigroupoids
+import Data.Functor.Apply ( Apply, (<.>) )
+
+
+type HTable :: HKTable -> Constraint
+class HTable t where
+  type HField t = (field :: Context) | field -> t
+  type HConstrainTable t (c :: Spec -> Constraint) :: Constraint
+
+  hfield :: t (H context) -> HField t spec -> context spec
+  htabulate :: (forall spec. HField t spec -> context spec) -> t (H context)
+  htraverse :: Apply m => (forall spec. f spec -> m (g spec)) -> t (H f) -> m (t (H g))
+  hdicts :: HConstrainTable t c => t (H (Dict c))
+  hspecs :: t (H SSpec)
+
+  type HField t = GHField t
+  type HConstrainTable t c = HConstrainTable (GHColumns (Rep (t (H Proxy)))) c
+
+  default hfield ::
+    ( Generic (t (H context))
+    , HField t ~ GHField t
+    , HField (GHColumns (Rep (t (H Proxy)))) ~ HField (GHColumns (Rep (t (H context))))
+    , GHTable context (Rep (t (H context)))
+    )
+    => t (H context) -> HField t spec -> context spec
+  hfield table (GHField field) = hfield (toGHColumns (from table)) field
+
+  default htabulate ::
+    ( Generic (t (H context))
+    , HField t ~ GHField t
+    , HField (GHColumns (Rep (t (H Proxy)))) ~ HField (GHColumns (Rep (t (H context))))
+    , GHTable context (Rep (t (H context)))
+    )
+    => (forall spec. HField t spec -> context spec) -> t (H context)
+  htabulate f = to $ fromGHColumns $ htabulate (f . GHField)
+
+  default htraverse
+    :: forall f g m
+     . ( Apply m
+       , Generic (t (H f)), GHTable f (Rep (t (H f)))
+       , Generic (t (H g)), GHTable g (Rep (t (H g)))
+       , GHColumns (Rep (t (H f))) ~ GHColumns (Rep (t (H g)))
+       )
+    => (forall spec. f spec -> m (g spec)) -> t (H f) -> m (t (H g))
+  htraverse f = fmap (to . fromGHColumns) . htraverse f . toGHColumns . from
+
+  default hdicts
+    :: forall c
+     . ( Generic (t (H (Dict c)))
+       , GHTable (Dict c) (Rep (t (H (Dict c))))
+       , GHColumns (Rep (t (H Proxy))) ~ GHColumns (Rep (t (H (Dict c))))
+       , HConstrainTable (GHColumns (Rep (t (H Proxy)))) c
+       )
+    => t (H (Dict c))
+  hdicts = to $ fromGHColumns (hdicts @(GHColumns (Rep (t (H Proxy)))) @c)
+
+  default hspecs ::
+    ( Generic (t (H SSpec))
+    , GHTable SSpec (Rep (t (H SSpec)))
+    )
+    => t (H SSpec)
+  hspecs = to $ fromGHColumns hspecs
+
+  {-# INLINABLE hfield #-}
+  {-# INLINABLE htabulate #-}
+  {-# INLINABLE htraverse #-}
+  {-# INLINABLE hdicts #-}
+  {-# INLINABLE hspecs #-}
+
+
+htabulateA :: (HTable t, Apply m)
+  => (forall spec. HField t spec -> m (context spec))
+  -> m (t (H context))
+htabulateA f = htraverse getCompose $ htabulate $ Compose . f
+{-# INLINABLE htabulateA #-}
+
+
+type GHField :: HKTable -> Context
+newtype GHField t spec = GHField (HField (GHColumns (Rep (t (H Proxy)))) spec)
+
+
+type GHTable :: Context -> (Type -> Type) -> Constraint
+class HTable (GHColumns rep) => GHTable context rep | rep -> context where
+  type GHColumns rep :: HKTable
+  toGHColumns :: rep x -> GHColumns rep (H context)
+  fromGHColumns :: GHColumns rep (H context) -> rep x
+
+
+instance GHTable context rep => GHTable context (M1 i c rep) where
+  type GHColumns (M1 i c rep) = GHColumns rep
+  toGHColumns (M1 a) = toGHColumns a
+  fromGHColumns = M1 . fromGHColumns
+
+
+instance HTable table => GHTable context (K1 i (table (H context))) where
+  type GHColumns (K1 i (table (H context))) = table
+  toGHColumns (K1 a) = a
+  fromGHColumns = K1
+
+
+instance (GHTable context a, GHTable context b) => GHTable context (a :*: b) where
+  type GHColumns (a :*: b) = HPair (GHColumns a) (GHColumns b)
+  toGHColumns (a :*: b) = HPair (toGHColumns a) (toGHColumns b)
+  fromGHColumns (HPair a b) = fromGHColumns a :*: fromGHColumns b
+
+
+-- | A HField type for indexing into HPair.
+type HPairField :: HKTable -> HKTable -> Context
+data HPairField x y spec
+  = HFst (HField x spec)
+  | HSnd (HField y spec)
+
+
+instance (HTable x, HTable y) => HTable (HPair x y) where
+  type HConstrainTable (HPair x y) c = (HConstrainTable x c, HConstrainTable y c)
+  type HField (HPair x y) = HPairField x y
+
+  hfield (HPair l r) = \case
+    HFst i -> hfield l i
+    HSnd i -> hfield r i
+
+  htabulate f = HPair (htabulate (f . HFst)) (htabulate (f . HSnd))
+  htraverse f (HPair x y) = HPair <$> htraverse f x <.> htraverse f y
+  hdicts = HPair hdicts hdicts
+  hspecs = HPair hspecs hspecs
+
+  {-# INLINABLE hfield #-}
+  {-# INLINABLE htabulate #-}
+  {-# INLINABLE htraverse #-}
+  {-# INLINABLE hdicts #-}
+  {-# INLINABLE hspecs #-}

src/Rel8/Schema/HTable/Context.hs

@@ -0,0 +1,26 @@
+{-# language DataKinds #-}
+{-# language StandaloneKindSignatures #-}
+
+module Rel8.Schema.HTable.Context
+  ( HContext, H, HKTable
+  )
+where
+
+-- base
+import Data.Kind ( Type )
+import Prelude ()
+
+-- rel8
+import Rel8.Schema.Spec ( Context )
+
+
+type HContext :: Type
+newtype HContext = H Context
+
+
+type H :: Context -> HContext
+type H = 'H
+
+
+type HKTable :: Type
+type HKTable = HContext -> Type

src/Rel8/Schema/HTable/Either.hs

@@ -0,0 +1,33 @@
+{-# language DataKinds #-}
+{-# language DeriveAnyClass #-}
+{-# language DeriveGeneric #-}
+{-# language DerivingStrategies #-}
+{-# language StandaloneKindSignatures #-}
+
+module Rel8.Schema.HTable.Either
+  ( HEitherTable(..)
+  )
+where
+
+-- base
+import GHC.Generics ( Generic )
+import Prelude ()
+
+-- rel8
+import Rel8.Kind.Necessity ( Necessity( Required ) )
+import Rel8.Schema.HTable ( HTable )
+import Rel8.Schema.HTable.Context ( HKTable )
+import Rel8.Schema.HTable.Identity ( HIdentity(..) )
+import Rel8.Schema.HTable.Nullify ( HNullify )
+import Rel8.Schema.Spec ( Spec( Spec ) )
+import Rel8.Type.Tag ( EitherTag )
+
+
+type HEitherTable :: HKTable -> HKTable -> HKTable
+data HEitherTable left right context = HEitherTable
+  { htag :: HIdentity ('Spec '["isRight"] 'Required EitherTag EitherTag) context
+  , hleft :: HNullify left context
+  , hright :: HNullify right context
+  }
+  deriving stock Generic
+  deriving anyclass HTable

src/Rel8/Schema/HTable/Identity.hs

@@ -0,0 +1,44 @@
+{-# language DataKinds #-}
+{-# language GADTs #-}
+{-# language StandaloneKindSignatures #-}
+{-# language TypeFamilies #-}
+
+module Rel8.Schema.HTable.Identity
+  ( HIdentity(..)
+  )
+where
+
+-- base
+import Prelude
+
+-- rel8
+import Rel8.Schema.Dict ( Dict( Dict ) )
+import Rel8.Schema.HTable
+  ( HTable, HConstrainTable, HField
+  , hfield, htabulate, htraverse, hdicts, hspecs
+  )
+import Rel8.Schema.HTable.Context ( H, HKTable )
+import Rel8.Schema.Spec ( Context, Spec, KnownSpec, specSing )
+
+
+type HIdentity :: Spec -> HKTable
+data HIdentity spec context where
+  HIdentity ::
+    { unHIdentity :: context spec
+    } -> HIdentity spec (H context)
+
+
+type HIdentityField :: Spec -> Context
+data HIdentityField _spec spec where
+  HIdentityField :: HIdentityField spec spec
+
+
+instance KnownSpec spec => HTable (HIdentity spec) where
+  type HConstrainTable (HIdentity spec) c = c spec
+  type HField (HIdentity spec) = HIdentityField spec
+
+  hfield (HIdentity a) HIdentityField = a
+  htabulate f = HIdentity $ f HIdentityField
+  htraverse f (HIdentity a) = HIdentity <$> f a
+  hdicts = HIdentity Dict
+  hspecs = HIdentity specSing

src/Rel8/Schema/HTable/Label.hs

@@ -0,0 +1,131 @@
+{-# language ConstraintKinds #-}
+{-# language DataKinds #-}
+{-# language FlexibleInstances #-}
+{-# language GADTs #-}
+{-# language InstanceSigs #-}
+{-# language MultiParamTypeClasses #-}
+{-# language QuantifiedConstraints #-}
+{-# language RankNTypes #-}
+{-# language RecordWildCards #-}
+{-# language ScopedTypeVariables #-}
+{-# language StandaloneKindSignatures #-}
+{-# language TypeApplications #-}
+{-# language TypeFamilies #-}
+{-# language TypeOperators #-}
+{-# language UndecidableInstances #-}
+
+module Rel8.Schema.HTable.Label
+  ( HLabel( HLabel )
+  , hlabel, hunlabel
+  )
+where
+
+-- base
+import Data.Kind ( Constraint, Type )
+import Data.Proxy ( Proxy( Proxy ) )
+import GHC.TypeLits ( KnownSymbol, Symbol )
+import Prelude
+
+-- rel8
+import Rel8.Kind.Labels ( SLabels( SLabels ) )
+import Rel8.Schema.Dict ( Dict( Dict ) )
+import Rel8.Schema.HTable
+  ( HTable, HConstrainTable, HField
+  , hfield, htabulate, htraverse, hdicts, hspecs
+  )
+import Rel8.Schema.HTable.Context ( H, HKTable )
+import Rel8.Schema.Spec ( Context, Spec( Spec ), SSpec(..) )
+
+
+type HLabel :: Symbol -> HKTable -> HKTable
+data HLabel label table context where
+  HLabel :: table (H (LabelSpec label context)) -> HLabel label table (H context)
+
+
+type HLabelField :: Symbol -> HKTable -> Context
+data HLabelField label table spec where
+  HLabelField
+    :: HField table ('Spec labels necessity db a)
+    -> HLabelField label table ('Spec (label ': labels) necessity db a)
+
+
+instance (HTable table, KnownSymbol label) => HTable (HLabel label table) where
+  type HField (HLabel label table) = HLabelField label table
+  type HConstrainTable (HLabel label table) c =
+    HConstrainTable table (LabelSpecC label c)
+
+  hfield (HLabel table) (HLabelField field) =
+    getLabelSpec (hfield table field)
+
+  htabulate f = HLabel $ htabulate $ \field -> case hfield hspecs field of
+    SSpec {} -> LabelSpec (f (HLabelField field))
+  htraverse f (HLabel t) = HLabel <$> htraverse (traverseLabelSpec f) t
+
+  hdicts :: forall c. HConstrainTable table (LabelSpecC label c)
+    => HLabel label table (H (Dict c))
+  hdicts = HLabel $ htabulate $ \field -> case hfield hspecs field of
+    SSpec {} -> case hfield (hdicts @_ @(LabelSpecC label c)) field of
+      Dict -> LabelSpec Dict
+
+  hspecs = HLabel $ htabulate $ \field -> case hfield hspecs field of
+    SSpec {..} -> LabelSpec SSpec {labels = SLabels Proxy labels, ..}
+
+  {-# INLINABLE hfield #-}
+  {-# INLINABLE htabulate #-}
+  {-# INLINABLE htraverse #-}
+  {-# INLINABLE hdicts #-}
+  {-# INLINABLE hspecs #-}
+
+
+type LabelingSpec :: Type -> Type
+type LabelingSpec r = Symbol -> (Spec -> r) -> Spec -> r
+
+
+type LabelSpec :: LabelingSpec Type
+data LabelSpec label context spec where
+  LabelSpec
+    :: { getLabelSpec :: context ('Spec (label ': labels) necessity db a) }
+    -> LabelSpec label context ('Spec labels necessity db a)
+
+
+type LabelSpecC :: LabelingSpec Constraint
+class
+  ( forall labels necessity db a.
+    ( spec ~ 'Spec labels necessity db a =>
+       constraint ('Spec (label ': labels) necessity db a)
+    )
+  ) => LabelSpecC label constraint spec
+instance
+  ( spec ~ 'Spec labels necessity db a
+  , constraint ('Spec (label ': labels) necessity db a)
+  ) => LabelSpecC label constraint spec
+
+
+traverseLabelSpec :: forall context context' label spec m. Functor m
+  => (forall x. context x -> m (context' x))
+  -> LabelSpec label context spec -> m (LabelSpec label context' spec)
+traverseLabelSpec f (LabelSpec a) = LabelSpec <$> f a
+
+
+hlabel :: HTable t
+  => (forall labels necessity db a. ()
+    => context ('Spec labels necessity db a)
+    -> context ('Spec (label ': labels) necessity db a))
+  -> t (H context)
+  -> HLabel label t (H context)
+hlabel labeler a = HLabel $ htabulate $ \field ->
+  case hfield hspecs field of
+    SSpec {} -> LabelSpec (labeler (hfield a field))
+{-# INLINABLE hlabel #-}
+
+
+hunlabel :: HTable t
+  => (forall labels necessity db a. ()
+    => context ('Spec (label ': labels) necessity db a)
+    -> context ('Spec labels necessity db a))
+  -> HLabel label t (H context)
+  -> t (H context)
+hunlabel unlabler (HLabel as) =
+  htabulate $ \field -> case hfield as field of
+      LabelSpec a -> unlabler a
+{-# INLINABLE hunlabel #-}

src/Rel8/Schema/HTable/List.hs

@@ -0,0 +1,18 @@
+{-# language DataKinds #-}
+{-# language StandaloneKindSignatures #-}
+
+module Rel8.Schema.HTable.List
+  ( HListTable
+  )
+where
+
+-- base
+import Prelude ()
+
+-- rel8
+import Rel8.Schema.HTable.Context ( HKTable )
+import Rel8.Schema.HTable.Vectorize ( HVectorize )
+
+
+type HListTable :: HKTable -> HKTable
+type HListTable = HVectorize []

src/Rel8/Schema/HTable/Maybe.hs

@@ -0,0 +1,32 @@
+{-# language DataKinds #-}
+{-# language DeriveAnyClass #-}
+{-# language DeriveGeneric #-}
+{-# language DerivingStrategies #-}
+{-# language StandaloneKindSignatures #-}
+
+module Rel8.Schema.HTable.Maybe
+  ( HMaybeTable(..)
+  )
+where
+
+-- base
+import GHC.Generics ( Generic )
+import Prelude
+
+-- rel8
+import Rel8.Kind.Necessity ( Necessity( Required ) )
+import Rel8.Schema.HTable ( HTable )
+import Rel8.Schema.HTable.Context ( HKTable )
+import Rel8.Schema.HTable.Identity ( HIdentity(..) )
+import Rel8.Schema.HTable.Nullify ( HNullify )
+import Rel8.Schema.Spec ( Spec( Spec ) )
+import Rel8.Type.Tag ( MaybeTag )
+
+
+type HMaybeTable :: HKTable -> HKTable
+data HMaybeTable table context = HMaybeTable
+  { htag :: HIdentity ('Spec '["isJust"] 'Required MaybeTag (Maybe MaybeTag)) context
+  , hjust :: HNullify table context
+  }
+  deriving stock Generic
+  deriving anyclass HTable

src/Rel8/Schema/HTable/NonEmpty.hs

@@ -0,0 +1,19 @@
+{-# language DataKinds #-}
+{-# language StandaloneKindSignatures #-}
+
+module Rel8.Schema.HTable.NonEmpty
+  ( HNonEmptyTable
+  )
+where
+
+-- base
+import Data.List.NonEmpty ( NonEmpty )
+import Prelude ()
+
+-- rel8
+import Rel8.Schema.HTable.Context ( HKTable )
+import Rel8.Schema.HTable.Vectorize ( HVectorize )
+
+
+type HNonEmptyTable :: HKTable -> HKTable
+type HNonEmptyTable = HVectorize NonEmpty

src/Rel8/Schema/HTable/Nullify.hs

@@ -0,0 +1,146 @@
+{-# language ConstraintKinds #-}
+{-# language DataKinds #-}
+{-# language FlexibleInstances #-}
+{-# language GADTs #-}
+{-# language InstanceSigs #-}
+{-# language MultiParamTypeClasses #-}
+{-# language QuantifiedConstraints #-}
+{-# language RankNTypes #-}
+{-# language RecordWildCards #-}
+{-# language ScopedTypeVariables #-}
+{-# language StandaloneKindSignatures #-}
+{-# language TypeApplications #-}
+{-# language TypeFamilies #-}
+{-# language UndecidableInstances #-}
+
+module Rel8.Schema.HTable.Nullify
+  ( HNullify( HNullify )
+  , hnulls, hnullify, hunnullify
+  )
+where
+
+-- base
+import Data.Kind ( Constraint, Type )
+import Prelude hiding ( null )
+
+-- rel8
+import Rel8.Schema.Dict ( Dict( Dict ) )
+import Rel8.Schema.HTable
+  ( HTable, HConstrainTable, HField
+  , hfield, htabulate, htabulateA, htraverse, hdicts, hspecs
+  )
+import Rel8.Schema.HTable.Context ( H, HKTable )
+import Rel8.Schema.Nullability ( Nullability( Nullable, NonNullable ) )
+import Rel8.Schema.Spec ( Context, Spec( Spec ), SSpec(..) )
+
+-- semigroupoids
+import Data.Functor.Apply ( Apply )
+
+
+type HNullify :: HKTable -> HKTable
+data HNullify table context where
+  HNullify :: table (H (NullifySpec context)) -> HNullify table (H context)
+
+
+type HNullifyField :: HKTable -> Context
+data HNullifyField table spec where
+  HNullifyField
+    :: HField table ('Spec labels necessity dbType a)
+    -> HNullifyField table ('Spec labels necessity dbType (Maybe dbType))
+
+
+instance HTable table => HTable (HNullify table) where
+  type HField (HNullify table) = HNullifyField table
+  type HConstrainTable (HNullify table) c =
+    HConstrainTable table (NullifySpecC c)
+
+  hfield (HNullify table) (HNullifyField field) =
+    getNullifySpec (hfield table field)
+
+  htabulate f = HNullify $ htabulate $ \field -> case hfield hspecs field of
+    SSpec {} -> NullifySpec (f (HNullifyField field))
+
+  htraverse f (HNullify t) = HNullify <$> htraverse (traverseNullifySpec f) t
+
+  hdicts :: forall c. HConstrainTable table (NullifySpecC c)
+    => HNullify table (H (Dict c))
+  hdicts = HNullify $ htabulate $ \field -> case hfield hspecs field of
+    SSpec {} -> case hfield (hdicts @_ @(NullifySpecC c)) field of
+      Dict -> NullifySpec Dict
+
+  hspecs = HNullify $ htabulate $ \field -> case hfield hspecs field of
+    SSpec {..} -> case nullability of
+      Nullable -> NullifySpec SSpec {nullability = Nullable, ..}
+      NonNullable -> NullifySpec SSpec {nullability = Nullable, ..}
+
+  {-# INLINABLE hfield #-}
+  {-# INLINABLE htabulate #-}
+  {-# INLINABLE htraverse #-}
+  {-# INLINABLE hdicts #-}
+  {-# INLINABLE hspecs #-}
+
+
+type NullifyingSpec :: Type -> Type
+type NullifyingSpec r = (Spec -> r) -> Spec -> r
+
+
+type NullifySpec :: NullifyingSpec Type
+data NullifySpec context spec where
+  NullifySpec
+    :: { getNullifySpec :: context ('Spec labels necessity dbType (Maybe dbType)) }
+    -> NullifySpec context ('Spec labels necessity dbType a)
+
+
+type NullifySpecC :: NullifyingSpec Constraint
+class
+  ( forall labels necessity dbType a.
+    ( spec ~ 'Spec labels necessity dbType a =>
+       constraint ('Spec labels necessity dbType (Maybe dbType))
+    )
+  ) => NullifySpecC constraint spec
+instance
+  ( spec ~ 'Spec labels necessity dbType a
+  , constraint ('Spec labels necessity dbType (Maybe dbType))
+  ) => NullifySpecC constraint spec
+
+
+traverseNullifySpec :: forall context context' spec m. Functor m
+  => (forall x. context x -> m (context' x))
+  -> NullifySpec context spec -> m (NullifySpec context' spec)
+traverseNullifySpec f (NullifySpec a) = NullifySpec <$> f a
+
+
+hnulls :: HTable t
+  => (forall labels necessity dbType. ()
+    => context ('Spec labels necessity dbType (Maybe dbType)))
+  -> HNullify t (H context)
+hnulls null = HNullify $ htabulate $ \field -> case hfield hspecs field of
+  SSpec {} -> NullifySpec null
+{-# INLINABLE hnulls #-}
+
+
+hnullify :: HTable t
+  => (forall labels necessity dbType a. ()
+    => SSpec ('Spec labels necessity dbType a)
+    -> context ('Spec labels necessity dbType a)
+    -> context ('Spec labels necessity dbType (Maybe dbType)))
+  -> t (H context)
+  -> HNullify t (H context)
+hnullify nullifier a = HNullify $ htabulate $ \field ->
+  case hfield hspecs field of
+    spec@SSpec {} -> NullifySpec (nullifier spec (hfield a field))
+{-# INLINABLE hnullify #-}
+
+
+hunnullify :: (HTable t, Apply m)
+  => (forall labels necessity dbType a. ()
+    => SSpec ('Spec labels necessity dbType a)
+    -> context ('Spec labels necessity dbType (Maybe dbType))
+    -> m (context ('Spec labels necessity dbType a)))
+  -> HNullify t (H context)
+  -> m (t (H context))
+hunnullify unnullifier (HNullify as) =
+  htabulateA $ \field -> case hfield hspecs field of
+    spec@SSpec {} -> case hfield as field of
+      NullifySpec a -> unnullifier spec a
+{-# INLINABLE hunnullify #-}

src/Rel8/Schema/HTable/Pair.hs

@@ -0,0 +1,20 @@
+{-# language DataKinds #-}
+{-# language StandaloneKindSignatures #-}
+
+module Rel8.Schema.HTable.Pair
+  ( HPair(..)
+  )
+where
+
+-- base
+import Prelude ()
+
+-- rel8
+import Rel8.Schema.HTable.Context ( HKTable )
+
+
+type HPair :: HKTable -> HKTable -> HKTable
+data HPair fst snd context = HPair
+  { hfst :: fst context
+  , hsnd :: snd context
+  }

src/Rel8/Schema/HTable/Quartet.hs

@@ -0,0 +1,29 @@
+{-# language DataKinds #-}
+{-# language DeriveAnyClass #-}
+{-# language DeriveGeneric #-}
+{-# language DerivingStrategies #-}
+{-# language StandaloneKindSignatures #-}
+
+module Rel8.Schema.HTable.Quartet
+  ( HQuartet(..)
+  )
+where
+
+-- base
+import GHC.Generics ( Generic )
+import Prelude ()
+
+-- rel8
+import Rel8.Schema.HTable ( HTable )
+import Rel8.Schema.HTable.Context ( HKTable )
+
+
+type HQuartet :: HKTable -> HKTable -> HKTable -> HKTable -> HKTable
+data HQuartet w x y z context = HQuartet
+  { hfst :: w context
+  , hsnd :: x context
+  , htrd :: y context
+  , hfrt :: z context
+  }
+  deriving stock Generic
+  deriving anyclass HTable

src/Rel8/Schema/HTable/Quintet.hs

@@ -0,0 +1,30 @@
+{-# language DataKinds #-}
+{-# language DeriveAnyClass #-}
+{-# language DeriveGeneric #-}
+{-# language DerivingStrategies #-}
+{-# language StandaloneKindSignatures #-}
+
+module Rel8.Schema.HTable.Quintet
+  ( HQuintet(..)
+  )
+where
+
+-- base
+import GHC.Generics ( Generic )
+import Prelude ()
+
+-- rel8
+import Rel8.Schema.HTable ( HTable )
+import Rel8.Schema.HTable.Context ( HKTable )
+
+
+type HQuintet :: HKTable -> HKTable -> HKTable -> HKTable -> HKTable -> HKTable
+data HQuintet v w x y z context = HQuintet
+  { hfst :: v context
+  , hsnd :: w context
+  , htrd :: x context
+  , hfrt :: y context
+  , hfft :: z context
+  }
+  deriving stock Generic
+  deriving anyclass HTable

src/Rel8/Schema/HTable/These.hs

@@ -0,0 +1,34 @@
+{-# language DataKinds #-}
+{-# language DeriveAnyClass #-}
+{-# language DeriveGeneric #-}
+{-# language DerivingStrategies #-}
+{-# language StandaloneKindSignatures #-}
+
+module Rel8.Schema.HTable.These
+  ( HTheseTable(..)
+  )
+where
+
+-- base
+import GHC.Generics ( Generic )
+import Prelude
+
+-- rel8
+import Rel8.Kind.Necessity ( Necessity( Required ) )
+import Rel8.Schema.HTable ( HTable )
+import Rel8.Schema.HTable.Context ( HKTable )
+import Rel8.Schema.HTable.Identity ( HIdentity )
+import Rel8.Schema.HTable.Nullify ( HNullify )
+import Rel8.Schema.Spec ( Spec( Spec ) )
+import Rel8.Type.Tag ( MaybeTag )
+
+
+type HTheseTable :: HKTable -> HKTable -> HKTable
+data HTheseTable here there context = HTheseTable
+  { hhereTag :: HIdentity ('Spec '["hasHere"] 'Required MaybeTag (Maybe MaybeTag)) context
+  , hhere :: HNullify here context
+  , hthereTag :: HIdentity ('Spec '["hasThere"] 'Required MaybeTag (Maybe MaybeTag)) context
+  , hthere :: HNullify there context
+  }
+  deriving stock Generic
+  deriving anyclass HTable

src/Rel8/Schema/HTable/Trio.hs

@@ -0,0 +1,28 @@
+{-# language DataKinds #-}
+{-# language DeriveAnyClass #-}
+{-# language DeriveGeneric #-}
+{-# language DerivingStrategies #-}
+{-# language StandaloneKindSignatures #-}
+
+module Rel8.Schema.HTable.Trio
+  ( HTrio(..)
+  )
+where
+
+-- base
+import GHC.Generics ( Generic )
+import Prelude ()
+
+-- rel8
+import Rel8.Schema.HTable ( HTable )
+import Rel8.Schema.HTable.Context ( HKTable )
+
+
+type HTrio :: HKTable -> HKTable -> HKTable -> HKTable
+data HTrio x y z context = HTrio
+  { hfst :: x context
+  , hsnd :: y context
+  , htrd :: z context
+  }
+  deriving stock Generic
+  deriving anyclass HTable

src/Rel8/Schema/HTable/Type.hs

@@ -0,0 +1,60 @@
+{-# language DataKinds #-}
+{-# language GADTs #-}
+{-# language StandaloneKindSignatures #-}
+{-# language TypeFamilies #-}
+{-# language UndecidableInstances #-}
+
+module Rel8.Schema.HTable.Type
+  ( HType(..)
+  )
+where
+
+-- base
+import Data.Kind ( Type )
+import Data.Proxy ( Proxy( Proxy ) )
+import Prelude
+
+-- rel8
+import Rel8.Kind.Bool ( KnownBool, boolSing, IsList )
+import Rel8.Kind.Labels ( SLabels( SLabel ) )
+import Rel8.Kind.Necessity ( Necessity( Required ), SNecessity( SRequired ) )
+import Rel8.Schema.Dict ( Dict( Dict ) )
+import Rel8.Schema.HTable
+  ( HTable, HConstrainTable, HField
+  , hfield, htabulate, htraverse, hdicts, hspecs
+  )
+import Rel8.Schema.HTable.Context ( H, HKTable )
+import Rel8.Schema.Nullability ( Unnullify, Nullabilizes, nullabilization )
+import Rel8.Schema.Spec ( Context, Spec( Spec ), SSpec(..) )
+import Rel8.Type ( DBType, typeInformation )
+
+
+type HType :: Type -> HKTable
+data HType a context where
+  HType ::
+    { unHType :: context ('Spec '[""] 'Required (Unnullify a) a)
+    } -> HType a (H context)
+
+
+type HTypeField :: Type -> Context
+data HTypeField a spec where
+  HTypeField :: HTypeField a ('Spec '[""] 'Required (Unnullify a) a)
+
+
+instance (DBType db, Nullabilizes db a, KnownBool (IsList db)) =>
+  HTable (HType a)
+ where
+  type HConstrainTable (HType a) c = c ('Spec '[""] 'Required (Unnullify a) a)
+  type HField (HType a) = HTypeField a
+
+  hfield (HType a) HTypeField = a
+  htabulate f = HType $ f HTypeField
+  htraverse f (HType a) = HType <$> f a
+  hdicts = HType Dict
+  hspecs = HType SSpec
+    { labels = SLabel Proxy
+    , necessity = SRequired
+    , info = typeInformation
+    , nullability = nullabilization
+    , isList = boolSing
+    }

src/Rel8/Schema/HTable/Vectorize.hs

@@ -0,0 +1,220 @@
+{-# language AllowAmbiguousTypes #-}
+{-# language ConstraintKinds #-}
+{-# language DataKinds #-}
+{-# language FlexibleContexts #-}
+{-# language FlexibleInstances #-}
+{-# language GADTs #-}
+{-# language InstanceSigs #-}
+{-# language MultiParamTypeClasses #-}
+{-# language NamedFieldPuns #-}
+{-# language QuantifiedConstraints #-}
+{-# language RankNTypes #-}
+{-# language RecordWildCards #-}
+{-# language ScopedTypeVariables #-}
+{-# language StandaloneKindSignatures #-}
+{-# language TypeApplications #-}
+{-# language TypeFamilies #-}
+{-# language TypeOperators #-}
+{-# language UndecidableInstances #-}
+
+module Rel8.Schema.HTable.Vectorize
+  ( HVectorize( HVectorize )
+  , hvectorize, hunvectorize
+  , happend, hempty
+  , hrelabel
+  )
+where
+
+-- base
+import Data.Kind ( Constraint, Type )
+import Data.List.NonEmpty ( NonEmpty )
+import Data.Type.Equality ( (:~:)( Refl ) )
+import Prelude
+
+-- rel8
+import Rel8.Kind.Bool ( IsList, SBool( STrue ) )
+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
+import Rel8.Schema.Dict ( Dict( Dict ) )
+import Rel8.Schema.HTable
+  ( HTable, HConstrainTable, HField
+  , hfield, htabulate, htabulateA, htraverse, hdicts, hspecs
+  )
+import Rel8.Schema.HTable.Context ( H, HKTable )
+import Rel8.Schema.Nullability ( IsMaybe, Nullability( NonNullable ) )
+import Rel8.Schema.Spec ( Context, Spec( Spec ), SSpec(..) )
+import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
+import Rel8.Type.Information ( TypeInformation )
+
+-- semialign
+import Data.Zip ( Unzip, Repeat, Zippy(..) )
+
+
+class Vector list where
+  listIsList :: proxy a -> IsList (list a) :~: 'True
+  listIsn'tMaybe :: proxy a -> IsMaybe (list a) :~: 'False
+  vectorTypeInformation :: ()
+    => Nullability a ma
+    -> TypeInformation a
+    -> TypeInformation (list ma)
+
+
+instance Vector [] where
+  listIsList _ = Refl
+  listIsn'tMaybe _ = Refl
+  vectorTypeInformation = listTypeInformation
+
+
+instance Vector NonEmpty where
+  listIsList _ = Refl
+  listIsn'tMaybe _ = Refl
+  vectorTypeInformation = nonEmptyTypeInformation
+
+
+type HVectorize :: (Type -> Type) -> HKTable -> HKTable
+data HVectorize list table context where
+  HVectorize :: table (H (VectorizeSpec list context)) -> HVectorize list table (H context)
+
+
+type HVectorizeField :: (Type -> Type) -> HKTable -> Context
+data HVectorizeField list table spec where
+  HVectorizeField
+    :: HField table ('Spec labels necessity db a)
+    -> HVectorizeField list table
+       ('Spec labels necessity (list a) (list a)
+       )
+
+
+instance (HTable table, Vector list) => HTable (HVectorize list table) where
+
+  type HField (HVectorize list table) = HVectorizeField list table
+  type HConstrainTable (HVectorize list table) c =
+    HConstrainTable table (VectorizeSpecC list c)
+
+  hfield (HVectorize table) (HVectorizeField field) =
+    getVectorizeSpec (hfield table field)
+
+  htabulate f = HVectorize $ htabulate $ \field -> case hfield hspecs field of
+    SSpec {} -> VectorizeSpec (f (HVectorizeField field))
+  htraverse f (HVectorize t) = HVectorize <$> htraverse (traverseVectorizeSpec f) t
+
+  hdicts :: forall c. HConstrainTable table (VectorizeSpecC list c) =>
+    HVectorize list table (H (Dict c))
+  hdicts = HVectorize $ htabulate $ \field -> case hfield hspecs field of
+    SSpec {} -> case hfield (hdicts @_ @(VectorizeSpecC list c)) field of
+      Dict -> VectorizeSpec Dict
+
+  hspecs = HVectorize $ htabulate $ \field -> case hfield hspecs field of
+    SSpec {..} -> case listIsList @list nullability of
+      Refl -> case listIsn'tMaybe @list nullability of
+        Refl -> VectorizeSpec SSpec
+          { nullability = NonNullable
+          , info = vectorTypeInformation nullability info
+          , isList = STrue
+          , ..
+          }
+
+  {-# INLINABLE hfield #-}
+  {-# INLINABLE htabulate #-}
+  {-# INLINABLE htraverse #-}
+  {-# INLINABLE hdicts #-}
+  {-# INLINABLE hspecs #-}
+
+
+type VectorizingSpec :: Type -> Type
+type VectorizingSpec r = (Type -> Type) -> (Spec -> r) -> Spec -> r
+
+
+type VectorizeSpec :: VectorizingSpec Type
+data VectorizeSpec list context spec where
+  VectorizeSpec ::
+    { getVectorizeSpec :: context ('Spec labels necessity (list a) (list a))
+    } -> VectorizeSpec list context ('Spec labels necessity db a)
+
+
+instance Labelable context => Labelable (VectorizeSpec list context) where
+  labeler (VectorizeSpec a) = VectorizeSpec (labeler a)
+  unlabeler (VectorizeSpec a) = VectorizeSpec (unlabeler a)
+
+
+type VectorizeSpecC :: VectorizingSpec Constraint
+class
+  ( forall labels necessity db a.
+    ( spec ~ 'Spec labels necessity db a
+      => constraint ('Spec labels necessity (list a) (list a))
+    )
+  )
+  => VectorizeSpecC list constraint spec
+instance
+  ( spec ~ 'Spec labels necessity db a
+  , constraint ('Spec labels necessity (list a) (list a))
+  )
+  => VectorizeSpecC list constraint spec
+
+
+traverseVectorizeSpec :: forall context context' list spec m. Functor m
+  => (forall x. context x -> m (context' x))
+  -> VectorizeSpec list context spec
+  -> m (VectorizeSpec list context' spec)
+traverseVectorizeSpec f (VectorizeSpec a) = VectorizeSpec <$> f a
+
+
+hvectorize :: (HTable t, Unzip f)
+  => (forall labels necessity db a. ()
+    => SSpec ('Spec labels necessity db a)
+    -> f (context ('Spec labels necessity db a))
+    -> context' ('Spec labels necessity (list a) (list a)))
+  -> f (t (H context))
+  -> HVectorize list t (H context')
+hvectorize vectorizer as = HVectorize $ htabulate $ \field ->
+  case hfield hspecs field of
+    spec@SSpec {} -> VectorizeSpec (vectorizer spec (fmap (`hfield` field) as))
+{-# INLINABLE hvectorize #-}
+
+
+hunvectorize :: (HTable t, Repeat f)
+  => (forall labels necessity db a. ()
+    => SSpec ('Spec labels necessity db a)
+    -> context ('Spec labels necessity (list a) (list a))
+    -> f (context' ('Spec labels necessity db a)))
+  -> HVectorize list t (H context)
+  -> f (t (H context'))
+hunvectorize unvectorizer (HVectorize table) =
+  getZippy $ htabulateA $ \field -> case hfield hspecs field of
+    spec -> case hfield table field of
+      VectorizeSpec a -> Zippy (unvectorizer spec a)
+{-# INLINABLE hunvectorize #-}
+
+
+happend :: HTable t =>
+  ( forall labels necessity db a. ()
+    => Nullability db a
+    -> TypeInformation db
+    -> context ('Spec labels necessity (list a) (list a))
+    -> context ('Spec labels necessity (list a) (list a))
+    -> context ('Spec labels necessity (list a) (list a))
+  )
+  -> HVectorize list t (H context)
+  -> HVectorize list t (H context)
+  -> HVectorize list t (H context)
+happend append (HVectorize as) (HVectorize bs) = HVectorize $
+  htabulate $ \field -> case (hfield as field, hfield bs field) of
+    (VectorizeSpec a, VectorizeSpec b) -> case hfield hspecs field of
+      SSpec {nullability, info} -> VectorizeSpec $ append nullability info a b
+
+
+hempty :: HTable t =>
+  ( forall labels necessity db a. ()
+    => Nullability db a
+    -> TypeInformation db
+    -> context ('Spec labels necessity [a] [a])
+  )
+  -> HVectorize [] t (H context)
+hempty empty = HVectorize $ htabulate $ \field -> case hfield hspecs field of
+  SSpec {nullability, info} -> VectorizeSpec (empty nullability info)
+
+
+hrelabel :: Labelable context
+  => (forall ctx. Labelable ctx => t (H ctx) -> u (H ctx))
+  -> HVectorize list t (H context)
+  -> HVectorize list u (H context)
+hrelabel f (HVectorize table) = HVectorize (f table)

src/Rel8/Schema/Nullability.hs

@@ -0,0 +1,86 @@
+{-# language ConstraintKinds #-}
+{-# language DataKinds #-}
+{-# language FlexibleContexts #-}
+{-# language FlexibleInstances #-}
+{-# language FunctionalDependencies #-}
+{-# language GADTs #-}
+{-# language MultiParamTypeClasses #-}
+{-# language QuantifiedConstraints #-}
+{-# language StandaloneKindSignatures #-}
+{-# language TypeFamilies #-}
+{-# language UndecidableInstances #-}
+
+module Rel8.Schema.Nullability
+  ( IsMaybe, Nullify, Unnullify
+  , Nullability( Nullable, NonNullable )
+  , Nullabilizes, nullabilization
+  )
+where
+
+-- base
+import Data.Kind ( Constraint, Type )
+import Prelude
+
+-- rel8
+import Rel8.Opaque ( Opaque )
+
+
+type IsMaybe :: Type -> Bool
+type family IsMaybe a where
+  IsMaybe (Maybe _) = 'True
+  IsMaybe _ = 'False
+
+
+type Unnullify' :: Bool -> Type -> Type
+type family Unnullify' isMaybe ma where
+  Unnullify' 'False a = a
+  Unnullify' 'True (Maybe a) = a
+
+
+type Unnullify :: Type -> Type
+type Unnullify a = Unnullify' (IsMaybe a) a
+
+
+type Nullify' :: Bool -> Type -> Type
+type family Nullify' isMaybe a where
+  Nullify' 'False a = a
+  Nullify' 'True a = Maybe a
+
+
+type Nullify :: Type -> Type
+type Nullify a = Maybe (Unnullify a)
+
+
+type Nullability :: Type -> Type -> Type
+data Nullability a ma where
+  NonNullable :: IsMaybe a ~ 'False => Nullability a a
+  Nullable :: IsMaybe a ~ 'False => Nullability a (Maybe a)
+
+
+type Nullabilizes' :: Bool -> Type -> Type -> Constraint
+class
+  ( IsMaybe ma ~ isMaybe
+  , IsMaybe a ~ 'False
+  , Unnullify ma ~ a
+  , Nullify' isMaybe a ~ ma
+  ) => Nullabilizes' isMaybe a ma | isMaybe ma -> a, isMaybe a -> ma
+ where
+  nullabilization' :: Nullability a ma
+
+
+instance IsMaybe a ~ 'False => Nullabilizes' 'False a a where
+  nullabilization' = NonNullable
+
+
+instance IsMaybe a ~ 'False => Nullabilizes' 'True a (Maybe a) where
+  nullabilization' = Nullable
+
+
+type Nullabilizes :: Type -> Type -> Constraint
+class Nullabilizes' (IsMaybe ma) a ma => Nullabilizes a ma
+instance Nullabilizes' (IsMaybe ma) a ma => Nullabilizes a ma
+instance {-# OVERLAPPING #-} Nullabilizes Opaque Opaque
+
+
+nullabilization :: forall a db. Nullabilizes db a => Nullability db a
+nullabilization = nullabilization'

src/Rel8/Schema/Spec.hs

@@ -0,0 +1,75 @@
+{-# language DataKinds #-}
+{-# language FlexibleContexts #-}
+{-# language GADTs #-}
+{-# language StandaloneKindSignatures #-}
+{-# language UndecidableInstances #-}
+
+module Rel8.Schema.Spec
+  ( Spec( Spec )
+  , SSpec( SSpec, labels, necessity, info, nullability, isList )
+  , KnownSpec( specSing )
+  , Context, KTable
+  )
+where
+
+-- base
+import Data.Kind ( Constraint, Type )
+import Prelude ()
+
+-- rel8
+import Rel8.Kind.Bool ( SBool, KnownBool, boolSing, IsList )
+import Rel8.Kind.Labels ( Labels, SLabels, KnownLabels, labelsSing )
+import Rel8.Kind.Necessity
+  ( Necessity
+  , SNecessity
+  , KnownNecessity, necessitySing
+  )
+import Rel8.Schema.Nullability ( Nullability, Nullabilizes, nullabilization )
+import Rel8.Type ( DBType, typeInformation )
+import Rel8.Type.Information ( TypeInformation )
+
+
+type Spec :: Type
+data Spec = Spec Labels Necessity Type Type
+
+
+type SSpec :: Spec -> Type
+data SSpec spec where
+  SSpec ::
+    { labels :: SLabels labels
+    , necessity :: SNecessity necessity
+    , info :: TypeInformation db
+    , nullability :: Nullability db a
+    , isList :: SBool (IsList db)
+    }
+    -> SSpec ('Spec labels necessity db a)
+
+
+type KnownSpec :: Spec -> Constraint
+class KnownSpec spec where
+  specSing :: SSpec spec
+
+
+instance
+  ( KnownLabels labels
+  , KnownNecessity necessity
+  , DBType db
+  , Nullabilizes db a
+  , KnownBool (IsList db)
+  ) => KnownSpec ('Spec labels necessity db a)
+ where
+  specSing = SSpec
+    { labels = labelsSing
+    , necessity = necessitySing
+    , info = typeInformation
+    , nullability = nullabilization
+    , isList = boolSing
+    }
+
+
+type Context :: Type
+type Context = Spec -> Type
+
+
+type KTable :: Type
+type KTable = Context -> Type

src/Rel8/Schema/Spec/ConstrainContext.hs

@@ -0,0 +1,23 @@
+{-# language ConstraintKinds #-}
+{-# language DataKinds #-}
+{-# language FlexibleInstances #-}
+{-# language MultiParamTypeClasses #-}
+{-# language StandaloneKindSignatures #-}
+{-# language UndecidableSuperClasses #-}
+
+module Rel8.Schema.Spec.ConstrainContext
+  ( ConstrainContext
+  )
+where
+
+-- base
+import Data.Kind ( Constraint, Type )
+import Prelude ()
+
+-- rel8
+import Rel8.Schema.Spec ( Context, Spec )
+
+
+type ConstrainContext :: (Type -> Constraint) -> Context -> Spec -> Constraint
+class constraint (context spec) => ConstrainContext constraint context spec
+instance constraint (context spec) => ConstrainContext constraint context spec

src/Rel8/Schema/Spec/ConstrainDBType.hs

@@ -0,0 +1,34 @@
+{-# language ConstraintKinds #-}
+{-# language DataKinds #-}
+{-# language FlexibleInstances #-}
+{-# language MultiParamTypeClasses #-}
+{-# language QuantifiedConstraints #-}
+{-# language StandaloneKindSignatures #-}
+{-# language TypeFamilies #-}
+{-# language UndecidableInstances #-}
+
+module Rel8.Schema.Spec.ConstrainDBType
+  ( ConstrainDBType
+  )
+where
+
+-- base
+import Data.Kind ( Constraint, Type )
+import Prelude ()
+
+-- rel8
+import Rel8.Schema.Spec ( Spec( Spec ) )
+
+
+type ConstrainDBType :: (Type -> Constraint) -> Spec -> Constraint
+class
+  ( forall labels necessity db a. ()
+     => (spec ~ 'Spec labels necessity db a)
+     => constraint db
+  )
+  => ConstrainDBType constraint spec
+instance
+  ( spec ~ 'Spec labels necessity db a
+  , constraint db
+  )
+  => ConstrainDBType constraint spec

src/Rel8/Schema/Spec/ConstrainType.hs

@@ -0,0 +1,31 @@
+{-# language ConstraintKinds #-}
+{-# language DataKinds #-}
+{-# language FlexibleInstances #-}
+{-# language MultiParamTypeClasses #-}
+{-# language QuantifiedConstraints #-}
+{-# language StandaloneKindSignatures #-}
+{-# language TypeFamilies #-}
+{-# language UndecidableInstances #-}
+
+module Rel8.Schema.Spec.ConstrainType
+  ( ConstrainType
+  )
+where
+
+-- base
+import Data.Kind ( Constraint, Type )
+import Prelude ()
+
+-- rel8
+import Rel8.Schema.Spec ( Spec( Spec ) )
+
+
+type ConstrainType :: (Type -> Constraint) -> Spec -> Constraint
+class
+  ( forall labels necessity db a. ()
+     => (spec ~ 'Spec labels necessity db a)
+     => constraint a
+  ) =>
+  ConstrainType constraint spec
+instance (spec ~ 'Spec labels necessity db a, constraint a) =>
+  ConstrainType constraint spec

src/Rel8/Schema/Structure.hs

@@ -0,0 +1,53 @@
+{-# language DataKinds #-}
+{-# language StandaloneKindSignatures #-}
+{-# language PolyKinds #-}
+{-# language TypeFamilies #-}
+
+module Rel8.Schema.Structure
+  ( Structure
+  , Shape( Column, Either, List, Maybe, NonEmpty, These )
+  , Shape1
+  , Shape2
+  , IsStructure
+  )
+where
+
+-- base
+import Data.Kind ( Type )
+import Prelude
+
+-- rel8
+import Rel8.Schema.Spec ( Context, Spec )
+
+
+type Structure :: Context
+data Structure spec
+
+
+type Shape :: Type
+data Shape
+  = Column Spec
+  | Either Type Type
+  | List Type
+  | Maybe Type
+  | NonEmpty Type
+  | These Type Type
+
+
+type Shape1 :: (a -> Shape) -> a -> Type
+data Shape1 shape a
+
+
+type Shape2 :: (a -> b -> Shape) -> a -> b -> Type
+data Shape2 shape a b
+
+
+type IsStructure :: Type -> Bool
+type family IsStructure a where
+  IsStructure (Shape1 _ _) = 'True
+  IsStructure (Shape2 _ _ _) = 'True
+  IsStructure (_, _) = 'True
+  IsStructure (_, _, _) = 'True
+  IsStructure (_, _, _, _) = 'True
+  IsStructure (_, _, _, _, _) = 'True
+  IsStructure _ = 'False

src/Rel8/Schema/Table.hs

@@ -0,0 +1,18 @@
+{-# language DeriveFunctor #-}
+{-# language DerivingStrategies #-}
+
+module Rel8.Schema.Table
+  ( TableSchema(..)
+  )
+where
+
+-- base
+import Prelude
+
+
+data TableSchema names = TableSchema
+  { name :: String
+  , schema :: Maybe String
+  , columns :: names
+  }
+  deriving stock Functor

src/Rel8/Statement/Delete.hs

@@ -0,0 +1,87 @@
+{-# language GADTs #-}
+{-# language NamedFieldPuns #-}
+{-# language ScopedTypeVariables #-}
+{-# language StandaloneKindSignatures #-}
+{-# language TypeApplications #-}
+
+module Rel8.Statement.Delete
+  ( Delete(..)
+  , delete
+  )
+where
+
+-- base
+import Control.Exception ( throwIO )
+import Control.Monad ( (>=>) )
+import Data.Kind ( Type )
+import Prelude
+
+-- hasql
+import Hasql.Connection ( Connection )
+import qualified Hasql.Decoders as Hasql
+import qualified Hasql.Encoders as Hasql
+import qualified Hasql.Session as Hasql
+import qualified Hasql.Statement as Hasql
+
+-- opaleye
+import qualified Opaleye.Internal.Manipulation as Opaleye
+
+-- rel8
+import Rel8.Expr ( Expr )
+import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )
+import Rel8.Schema.Table ( TableSchema )
+import Rel8.Statement.Returning ( Returning( NumberOfRowsAffected, Projection ) )
+import Rel8.Table ( fromColumns, toColumns )
+import Rel8.Table.Opaleye ( table, unpackspec )
+import Rel8.Table.Recontextualize ( Selects )
+import Rel8.Table.Serialize ( Serializable, parse )
+
+-- text
+import qualified Data.Text as Text
+import Data.Text.Encoding ( encodeUtf8 )
+
+
+type Delete :: Type -> Type
+data Delete a where
+  Delete :: Selects names exprs =>
+    { from :: TableSchema names
+    , deleteWhere :: exprs -> Expr Bool
+    , returning :: Returning names a
+    }
+    -> Delete a
+
+
+delete :: Delete a -> Connection -> IO a
+delete Delete {from, deleteWhere, returning} =
+  case returning of
+    NumberOfRowsAffected -> Hasql.run session >=> either throwIO pure
+      where
+        session = Hasql.statement () statement
+        statement = Hasql.Statement bytes params decode prepare
+        bytes = encodeUtf8 $ Text.pack sql
+        params = Hasql.noParams
+        decode = Hasql.rowsAffected
+        prepare = False
+        sql = Opaleye.arrangeDeleteSql from' where'
+          where
+            from' = table $ toColumns <$> from
+            where' = toColumn . toPrimExpr . deleteWhere . fromColumns
+
+    Projection project -> Hasql.run session >=> either throwIO pure
+      where
+        session = Hasql.statement () statement
+        statement = Hasql.Statement bytes params decode prepare
+        bytes = encodeUtf8 $ Text.pack sql
+        params = Hasql.noParams
+        decode = decoder project
+        prepare = False
+        sql =
+          Opaleye.arrangeDeleteReturningSql unpackspec from' where' project'
+          where
+            from' = table $ toColumns <$> from
+            where' = toColumn . toPrimExpr . deleteWhere . fromColumns
+            project' = toColumns . project . fromColumns
+  where
+    decoder :: forall exprs projection a. Serializable projection a
+      => (exprs -> projection) -> Hasql.Result [a]
+    decoder _ = Hasql.rowList (parse @projection @a)

src/Rel8/Statement/Insert.hs

@@ -0,0 +1,105 @@
+{-# language FlexibleContexts #-}
+{-# language GADTs #-}
+{-# language NamedFieldPuns #-}
+{-# language ScopedTypeVariables #-}
+{-# language StandaloneKindSignatures #-}
+{-# language TypeApplications #-}
+
+module Rel8.Statement.Insert
+  ( Insert(..)
+  , OnConflict(..)
+  , insert
+  )
+where
+
+-- base
+import Control.Exception ( throwIO )
+import Control.Monad ( (>=>) )
+import Data.Kind ( Type )
+import Data.List.NonEmpty ( NonEmpty( (:|) ) )
+import Prelude
+
+-- hasql
+import Hasql.Connection ( Connection )
+import qualified Hasql.Decoders as Hasql
+import qualified Hasql.Encoders as Hasql
+import qualified Hasql.Session as Hasql
+import qualified Hasql.Statement as Hasql
+
+-- rel8
+import qualified Opaleye.Internal.Manipulation as Opaleye
+import qualified Opaleye.Manipulation as Opaleye
+import Rel8.Schema.Table ( TableSchema )
+import Rel8.Statement.Returning ( Returning( Projection, NumberOfRowsAffected ) )
+import Rel8.Table ( fromColumns, toColumns )
+import Rel8.Table.Opaleye ( table, unpackspec )
+import Rel8.Table.Recontextualize ( Inserts, Selects )
+import Rel8.Table.Serialize ( Serializable, parse )
+
+-- text
+import qualified Data.Text as Text ( pack )
+import Data.Text.Encoding ( encodeUtf8 )
+
+
+type Insert :: Type -> Type
+data Insert a where
+  Insert :: (Selects names exprs, Inserts exprs inserts) =>
+    { into :: TableSchema names
+    , rows :: [inserts]
+    , onConflict :: OnConflict
+    , returning :: Returning names a
+    }
+    -> Insert a
+
+
+data OnConflict = Abort | DoNothing
+
+
+insert :: Insert a -> Connection -> IO a
+insert Insert {into, rows, onConflict, returning} =
+  case (rows, returning) of
+    ([], NumberOfRowsAffected) -> const $ pure 0
+    ([], Projection _) -> const $ pure []
+
+    (x:xs, NumberOfRowsAffected) -> Hasql.run session >=> either throwIO pure
+      where
+        session = Hasql.statement () statement
+        statement = Hasql.Statement bytes params decode prepare
+        bytes = encodeUtf8 $ Text.pack sql
+        params = Hasql.noParams
+        decode = Hasql.rowsAffected
+        prepare = False
+        sql = Opaleye.arrangeInsertManySql into' rows' onConflict'
+          where
+            into' = table $ toColumns <$> into
+            rows' = toColumns <$> x :| xs
+
+    (x:xs, Projection project) -> Hasql.run session >=> either throwIO pure
+      where
+        session = Hasql.statement () statement
+        statement = Hasql.Statement bytes params decode prepare
+        bytes = encodeUtf8 $ Text.pack sql
+        params = Hasql.noParams
+        decode = decoder project
+        prepare = False
+        sql =
+          Opaleye.arrangeInsertManyReturningSql
+            unpackspec
+            into'
+            rows'
+            project'
+            onConflict'
+          where
+            into' = table $ toColumns <$> into
+            rows' = toColumns <$> x :| xs
+            project' = toColumns . project . fromColumns
+
+  where
+    onConflict' =
+      case onConflict of
+        DoNothing -> Just Opaleye.DoNothing
+        Abort     -> Nothing
+
+    decoder :: forall exprs projection a. Serializable projection a
+      => (exprs -> projection) -> Hasql.Result [a]
+    decoder _ = Hasql.rowList (parse @projection @a)

src/Rel8/Statement/Returning.hs

@@ -0,0 +1,24 @@
+{-# language GADTs #-}
+{-# language StandaloneKindSignatures #-}
+
+module Rel8.Statement.Returning
+  ( Returning(..)
+  )
+where
+
+-- base
+import Data.Int ( Int64 )
+import Data.Kind ( Type )
+import Prelude ()
+
+-- rel8
+import Rel8.Table.Recontextualize ( Selects )
+import Rel8.Table.Serialize ( Serializable )
+
+
+type Returning :: Type -> Type -> Type
+data Returning names a where
+  NumberOfRowsAffected :: Returning names Int64
+  Projection :: (Selects names exprs, Serializable projection a)
+    => (exprs -> projection)
+    -> Returning names [a]

src/Rel8/Statement/Select.hs

@@ -0,0 +1,61 @@
+{-# language ScopedTypeVariables #-}
+{-# language TypeApplications #-}
+
+module Rel8.Statement.Select
+  ( select
+  , selectWithNames
+  )
+where
+
+-- base
+import Control.Exception ( throwIO )
+import Control.Monad ( (>=>) )
+import Prelude
+
+-- hasql
+import Hasql.Connection ( Connection )
+import qualified Hasql.Decoders as Hasql
+import qualified Hasql.Encoders as Hasql
+import qualified Hasql.Session as Hasql
+import qualified Hasql.Statement as Hasql
+
+-- rel8
+import Rel8.Query ( Query )
+import Rel8.Query.SQL ( sqlForQuery, sqlForQueryWithNames )
+import Rel8.Table.Recontextualize ( Selects )
+import Rel8.Table.Serialize ( Serializable, parse )
+
+-- text
+import qualified Data.Text as Text
+import Data.Text.Encoding ( encodeUtf8 )
+
+
+select :: forall exprs a. Serializable exprs a
+  => Query exprs -> Connection -> IO [a]
+select query = case sqlForQuery query of
+  Nothing -> const $ pure []
+  Just sql -> Hasql.run session >=> either throwIO pure
+    where
+      session = Hasql.statement () statement
+      statement = Hasql.Statement bytes params decode prepare
+      bytes = encodeUtf8 (Text.pack sql)
+      params = Hasql.noParams
+      decode = Hasql.rowList (parse @exprs @a)
+      prepare = False
+
+
+selectWithNames :: forall exprs a names.
+  ( Selects names exprs
+  , Serializable exprs a
+  )
+  => names -> Query exprs -> Connection -> IO [a]
+selectWithNames names query = case sqlForQueryWithNames names query of
+  Nothing -> const $ pure []
+  Just sql -> Hasql.run session >=> either throwIO pure
+    where
+      session = Hasql.statement () statement
+      statement = Hasql.Statement bytes params decode prepare
+      bytes = encodeUtf8 (Text.pack sql)
+      params = Hasql.noParams
+      decode = Hasql.rowList (parse @exprs @a)
+      prepare = False

src/Rel8/Statement/Update.hs

@@ -0,0 +1,100 @@
+{-# language GADTs #-}
+{-# language NamedFieldPuns #-}
+{-# language ScopedTypeVariables #-}
+{-# language StandaloneKindSignatures #-}
+{-# language TypeApplications #-}
+
+module Rel8.Statement.Update
+  ( Update(..)
+  , update
+  )
+where
+
+-- base
+import Control.Exception ( throwIO )
+import Control.Monad ( (>=>) )
+import Data.Kind ( Type )
+import Prelude
+
+-- hasql
+import Hasql.Connection ( Connection )
+import qualified Hasql.Decoders as Hasql
+import qualified Hasql.Encoders as Hasql
+import qualified Hasql.Session as Hasql
+import qualified Hasql.Statement as Hasql
+
+-- opaleye
+import qualified Opaleye.Internal.Manipulation as Opaleye
+
+-- profunctors
+import Data.Profunctor ( lmap )
+
+-- rel8
+import Rel8.Expr ( Expr )
+import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )
+import Rel8.Schema.Table ( TableSchema )
+import Rel8.Statement.Returning ( Returning( Projection, NumberOfRowsAffected ) )
+import Rel8.Table ( fromColumns, toColumns )
+import Rel8.Table.Insert ( toInsert )
+import Rel8.Table.Opaleye ( table, unpackspec )
+import Rel8.Table.Recontextualize ( Selects )
+import Rel8.Table.Serialize ( Serializable, parse )
+
+-- text
+import qualified Data.Text as Text
+import Data.Text.Encoding ( encodeUtf8 )
+
+
+type Update :: Type -> Type
+data Update a where
+  Update :: Selects names exprs =>
+    { target :: TableSchema names
+    , set :: exprs -> exprs
+    , updateWhere :: exprs -> Expr Bool
+    , returning :: Returning names a
+    }
+    -> Update a
+
+
+update :: Update a -> Connection -> IO a
+update Update {target, set, updateWhere, returning} =
+  case returning of
+    NumberOfRowsAffected -> Hasql.run session >=> either throwIO pure
+      where
+        session = Hasql.statement () statement
+        statement = Hasql.Statement bytes params decode prepare
+        bytes = encodeUtf8 $ Text.pack sql
+        params = Hasql.noParams
+        decode = Hasql.rowsAffected
+        prepare = False
+        sql = Opaleye.arrangeUpdateSql target' set' where'
+          where
+            target' = lmap toInsert $ table $ toColumns <$> target
+            set' = toColumns . set . fromColumns
+            where' = toColumn . toPrimExpr . updateWhere . fromColumns
+
+    Projection project -> Hasql.run session >=> either throwIO pure
+      where
+        session = Hasql.statement () statement
+        statement = Hasql.Statement bytes params decode prepare
+        bytes = encodeUtf8 $ Text.pack sql
+        params = Hasql.noParams
+        decode = decoder project
+        prepare = False
+        sql =
+          Opaleye.arrangeUpdateReturningSql
+            unpackspec
+            target'
+            set'
+            where'
+            project'
+          where
+            target' = lmap toInsert $ table $ toColumns <$> target
+            set' = toColumns . set . fromColumns
+            where' = toColumn . toPrimExpr . updateWhere . fromColumns
+            project' = toColumns . project . fromColumns
+
+  where
+    decoder :: forall exprs projection a. Serializable projection a
+      => (exprs -> projection) -> Hasql.Result [a]
+    decoder _ = Hasql.rowList (parse @projection @a)

src/Rel8/Statement/View.hs

@@ -0,0 +1,59 @@
+{-# language FlexibleContexts #-}
+
+module Rel8.Statement.View
+  ( createView
+  )
+where
+
+-- base
+import Control.Exception ( throwIO )
+import Control.Monad ( (>=>) )
+import Data.Foldable ( fold )
+import Data.Maybe ( fromMaybe )
+import Prelude
+
+-- hasql
+import Hasql.Connection ( Connection )
+import qualified Hasql.Decoders as Hasql
+import qualified Hasql.Encoders as Hasql
+import qualified Hasql.Session as Hasql
+import qualified Hasql.Statement as Hasql
+
+-- rel8
+import Rel8.Query ( Query )
+import Rel8.Query.SQL ( sqlForQueryWithNames )
+import Rel8.Schema.Table ( TableSchema( TableSchema ) )
+import Rel8.Table.Alternative ( emptyTable )
+import Rel8.Table.Recontextualize ( Selects )
+
+-- text
+import qualified Data.Text as Text
+import Data.Text.Encoding ( encodeUtf8 )
+
+
+createView :: Selects names exprs
+  => TableSchema names -> Query exprs -> Connection -> IO ()
+createView (TableSchema name mschema names) query =
+  Hasql.run session >=> either throwIO pure
+  where
+    session = Hasql.statement () statement
+    statement = Hasql.Statement bytes params decode prepare
+    bytes = encodeUtf8 (Text.pack sql)
+    params = Hasql.noParams
+    decode = Hasql.noResult
+    prepare = False
+    sql = "CREATE VIEW " <> title <> " WITH " <> select
+      where
+        title = case mschema of
+          Nothing -> quote name
+          Just schema -> quote schema <> "." <> quote name
+    select = fromMaybe fallback $ sqlForQueryWithNames names query
+      where
+        fallback = fold $ sqlForQueryWithNames names emptyTable
+
+
+quote :: String -> String
+quote string = "\"" <> concatMap go string <> "\""
+  where
+    go '"' = "\"\""
+    go c = [c]

src/Rel8/Table.hs

@@ -0,0 +1,236 @@
+{-# language DataKinds #-}
+{-# language DisambiguateRecordFields #-}
+{-# language FlexibleContexts #-}
+{-# language FlexibleInstances #-}
+{-# language FunctionalDependencies #-}
+{-# language StandaloneKindSignatures #-}
+{-# language TypeFamilies #-}
+{-# language UndecidableInstances #-}
+
+module Rel8.Table
+  ( Table (Columns, Context)
+  , toColumns, fromColumns
+  , Congruent
+  )
+where
+
+-- base
+import Data.Functor.Identity ( Identity( Identity ) )
+import Data.Kind ( Constraint, Type )
+import Prelude
+
+-- rel8
+import Rel8.Aggregate ( Aggregate )
+import Rel8.Expr ( Expr )
+import Rel8.Kind.Bool ( KnownBool, IsList )
+import Rel8.Opaque ( Opaque, Opaque1 )
+import Rel8.Schema.Context
+  ( Aggregation( Aggregation )
+  , DB( DB ), unDB
+  , Result( Result )
+  )
+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
+import Rel8.Schema.HTable ( HTable, hfield, hspecs, htabulate, htabulateA )
+import Rel8.Schema.HTable.Context ( H, HKTable )
+import Rel8.Schema.HTable.Identity ( HIdentity(..) )
+import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
+import Rel8.Schema.HTable.Pair ( HPair(..) )
+import Rel8.Schema.HTable.Quartet ( HQuartet(..) )
+import Rel8.Schema.HTable.Quintet ( HQuintet(..) )
+import Rel8.Schema.HTable.Trio ( HTrio(..) )
+import Rel8.Schema.HTable.Type ( HType( HType ) )
+import Rel8.Schema.Nullability ( Nullabilizes )
+import Rel8.Schema.Spec ( SSpec( SSpec ), KnownSpec )
+import qualified Rel8.Schema.Spec as Kind ( Context )
+import Rel8.Type ( DBType )
+
+
+type Table :: Kind.Context -> Type -> Constraint
+class (HTable (Columns a), context ~ Context a) => Table context a | a -> context where
+  type Columns a :: HKTable
+  type Context a :: Kind.Context
+
+  toColumns :: a -> Columns a (H (Context a))
+  fromColumns :: Columns a (H (Context a)) -> a
+
+
+-- | Any 'HTable' is also a 'Table'.
+instance HTable t => Table context (t (H context)) where
+  type Columns (t (H context)) = t
+  type Context (t (H context)) = context
+
+  toColumns = id
+  fromColumns = id
+
+
+-- | Any context is trivially a table.
+instance KnownSpec spec => Table context (context spec) where
+  type Columns (context spec) = HIdentity spec
+  type Context (context spec) = context
+
+  toColumns = HIdentity
+  fromColumns = unHIdentity
+
+
+instance Table DB a => Table Aggregation (Aggregate a) where
+  type Columns (Aggregate a) = Columns a
+  type Context (Aggregate a) = Aggregation
+
+  toColumns a = htabulate $ \field -> case hfield hspecs field of
+    SSpec {} -> Aggregation $ unDB . (`hfield` field) . toColumns <$> a
+  fromColumns as = fmap fromColumns $ htabulateA $ \field ->
+    case hfield as field of
+      Aggregation a -> DB <$> a
+
+
+instance
+  ( DBType db
+  , Nullabilizes db a
+  , KnownBool (IsList db)
+  )
+  => Table DB (Expr a)
+ where
+  type Columns (Expr a) = HType a
+  type Context (Expr a) = DB
+
+  toColumns a = HType (DB a)
+  fromColumns (HType (DB a)) = a
+
+
+instance
+  ( DBType db
+  , Nullabilizes db a
+  , KnownBool (IsList db)
+  )
+  => Table Result (Identity a)
+ where
+  type Columns (Identity a) = HType a
+  type Context (Identity a) = Result
+
+  toColumns (Identity a) = HType (Result a)
+  fromColumns (HType (Result a)) = Identity a
+
+
+instance
+  ( Table context a, Table context b
+  , Labelable context
+  ) =>
+  Table context (a, b)
+ where
+  type Columns (a, b) =
+    HPair
+      (HLabel "fst" (Columns a))
+      (HLabel "snd" (Columns b))
+  type Context (a, b) = Context a
+
+  toColumns (a, b) = HPair
+    { hfst = hlabel labeler $ toColumns a
+    , hsnd = hlabel labeler $ toColumns b
+    }
+  fromColumns (HPair a b) =
+    ( fromColumns $ hunlabel unlabeler a
+    , fromColumns $ hunlabel unlabeler b
+    )
+
+
+instance
+  ( Table context a, Table context b, Table context c
+  , Labelable context
+  ) => Table context (a, b, c)
+ where
+  type Columns (a, b, c) =
+    HTrio
+      (HLabel "fst" (Columns a))
+      (HLabel "snd" (Columns b))
+      (HLabel "trd" (Columns c))
+  type Context (a, b, c) = Context a
+
+  toColumns (a, b, c) = HTrio
+    { hfst = hlabel labeler $ toColumns a
+    , hsnd = hlabel labeler $ toColumns b
+    , htrd = hlabel labeler $ toColumns c
+    }
+  fromColumns (HTrio a b c) =
+    ( fromColumns $ hunlabel unlabeler a
+    , fromColumns $ hunlabel unlabeler b
+    , fromColumns $ hunlabel unlabeler c
+    )
+
+
+instance
+  ( Table context a, Table context b, Table context c, Table context d
+  , Labelable context
+  ) => Table context (a, b, c, d)
+ where
+  type Columns (a, b, c, d) =
+    HQuartet
+      (HLabel "fst" (Columns a))
+      (HLabel "snd" (Columns b))
+      (HLabel "trd" (Columns c))
+      (HLabel "frt" (Columns d))
+  type Context (a, b, c, d) = Context a
+
+  toColumns (a, b, c, d) = HQuartet
+    { hfst = hlabel labeler $ toColumns a
+    , hsnd = hlabel labeler $ toColumns b
+    , htrd = hlabel labeler $ toColumns c
+    , hfrt = hlabel labeler $ toColumns d
+    }
+  fromColumns (HQuartet a b c d) =
+    ( fromColumns $ hunlabel unlabeler a
+    , fromColumns $ hunlabel unlabeler b
+    , fromColumns $ hunlabel unlabeler c
+    , fromColumns $ hunlabel unlabeler d
+    )
+
+
+instance
+  ( Table context a, Table context b, Table context c, Table context d
+  , Table context e
+  , Labelable context
+  ) => Table context (a, b, c, d, e)
+ where
+  type Columns (a, b, c, d, e) =
+    HQuintet
+      (HLabel "fst" (Columns a))
+      (HLabel "snd" (Columns b))
+      (HLabel "trd" (Columns c))
+      (HLabel "frt" (Columns d))
+      (HLabel "fft" (Columns e))
+  type Context (a, b, c, d, e) = Context a
+
+  toColumns (a, b, c, d, e) = HQuintet
+    { hfst = hlabel labeler $ toColumns a
+    , hsnd = hlabel labeler $ toColumns b
+    , htrd = hlabel labeler $ toColumns c
+    , hfrt = hlabel labeler $ toColumns d
+    , hfft = hlabel labeler $ toColumns e
+    }
+  fromColumns (HQuintet a b c d e) =
+    ( fromColumns $ hunlabel unlabeler a
+    , fromColumns $ hunlabel unlabeler b
+    , fromColumns $ hunlabel unlabeler c
+    , fromColumns $ hunlabel unlabeler d
+    , fromColumns $ hunlabel unlabeler e
+    )
+
+
+instance Table DB Opaque where
+  type Columns Opaque = HType Opaque
+  type Context Opaque = DB
+
+  fromColumns = error "opaque"
+  toColumns = error "opaque"
+
+
+instance Table context (Opaque1 context a) where
+  type Columns (Opaque1 context a) = HType Opaque
+  type Context (Opaque1 context a) = context
+
+  fromColumns = error "opaque"
+  toColumns = error "opaque"
+
+
+type Congruent :: Type -> Type -> Constraint
+class Columns a ~ Columns b => Congruent a b
+instance Columns a ~ Columns b => Congruent a b

src/Rel8/Table/Aggregate.hs

@@ -0,0 +1,62 @@
+{-# language FlexibleContexts #-}
+{-# language NamedFieldPuns #-}
+{-# language ScopedTypeVariables #-}
+{-# language TypeApplications #-}
+{-# language TypeFamilies #-}
+{-# language ViewPatterns #-}
+
+module Rel8.Table.Aggregate
+  ( groupBy
+  , listAgg
+  , nonEmptyAgg
+  , runAggregation
+  )
+where
+
+-- base
+import Data.Functor.Identity ( Identity( Identity ) )
+import Prelude
+
+-- rel8
+import Rel8.Aggregate ( Aggregate )
+import Rel8.Expr.Aggregate ( listAggExpr, nonEmptyAggExpr, sgroupByExpr )
+import Rel8.Schema.Context ( Aggregation( Aggregation ), DB( DB ) )
+import Rel8.Schema.Dict ( Dict( Dict ) )
+import Rel8.Schema.HTable ( htabulate, hfield, hdicts, hspecs )
+import Rel8.Schema.HTable.Vectorize ( hvectorize )
+import Rel8.Schema.Spec ( SSpec(..) )
+import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
+import Rel8.Table ( Table, Columns, toColumns, fromColumns )
+import Rel8.Table.Eq ( EqTable )
+import Rel8.Table.List ( ListTable )
+import Rel8.Table.NonEmpty ( NonEmptyTable )
+import Rel8.Table.Recontextualize ( Aggregates )
+import Rel8.Type.Eq ( DBEq )
+
+
+groupBy :: forall exprs. EqTable exprs => exprs -> Aggregate exprs
+groupBy (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
+  case hfield dicts field of
+    Dict -> case hfield hspecs field of
+      SSpec {nullability} -> case hfield exprs field of
+        DB expr -> Aggregation $ sgroupByExpr nullability expr
+  where
+    dicts = hdicts @(Columns exprs) @(ConstrainDBType DBEq)
+
+
+listAgg :: Table DB exprs => exprs -> Aggregate (ListTable exprs)
+listAgg (toColumns -> exprs) = fromColumns $
+  hvectorize
+    (\_ (Identity (DB a)) -> Aggregation $ listAggExpr a)
+    (pure exprs)
+
+
+nonEmptyAgg :: Table DB exprs => exprs -> Aggregate (NonEmptyTable exprs)
+nonEmptyAgg (toColumns -> exprs) = fromColumns $
+  hvectorize
+    (\_ (Identity (DB a)) -> Aggregation $ nonEmptyAggExpr a)
+    (pure exprs)
+
+
+runAggregation :: Aggregates aggregates exprs => aggregates -> Aggregate exprs
+runAggregation = fromColumns . toColumns

src/Rel8/Table/Alternative.hs

@@ -0,0 +1,28 @@
+{-# language FlexibleContexts #-}
+{-# language StandaloneKindSignatures #-}
+{-# language TypeFamilies #-}
+
+module Rel8.Table.Alternative
+  ( AltTable ( (<|>:) )
+  , AlternativeTable ( emptyTable )
+  )
+where
+
+-- base
+import Data.Kind ( Constraint, Type )
+import Prelude ()
+
+-- rel8
+import Rel8.Schema.Context ( DB )
+import Rel8.Table ( Table )
+
+
+type AltTable :: (Type -> Type) -> Constraint
+class AltTable f where
+  (<|>:) :: Table DB a => f a -> f a -> f a
+  infixl 3 <|>:
+
+
+type AlternativeTable :: (Type -> Type) -> Constraint
+class AltTable f => AlternativeTable f where
+  emptyTable :: Table DB a => f a

src/Rel8/Table/Bool.hs

@@ -0,0 +1,35 @@
+{-# language FlexibleContexts #-}
+{-# language TypeFamilies #-}
+{-# language ViewPatterns #-}
+
+module Rel8.Table.Bool
+  ( bool
+  , case_
+  )
+where
+
+-- base
+import Prelude
+
+-- rel8
+import Rel8.Expr ( Expr )
+import Rel8.Expr.Bool ( boolExpr, caseExpr )
+import Rel8.Schema.Context ( DB( DB ), unDB )
+import Rel8.Schema.HTable ( htabulate, hfield )
+import Rel8.Table ( Table, fromColumns, toColumns )
+
+
+bool :: Table DB a => a -> a -> Expr Bool -> a
+bool (toColumns -> false) (toColumns -> true) condition =
+  fromColumns $ htabulate $ \field ->
+    case (hfield false field, hfield true field) of
+      (DB falseExpr, DB trueExpr) ->
+        DB (boolExpr falseExpr trueExpr condition)
+
+
+case_ :: Table DB a => [(Expr Bool, a)] -> a -> a
+case_ (map (fmap toColumns) -> branches) (toColumns -> fallback) =
+  fromColumns $ htabulate $ \field -> case hfield fallback field of
+    DB fallbackExpr ->
+      case map (fmap (unDB . (`hfield` field))) branches of
+        branchExprs -> DB (caseExpr branchExprs fallbackExpr)

src/Rel8/Table/Either.hs

@@ -0,0 +1,174 @@
+{-# language DataKinds #-}
+{-# language DeriveFunctor #-}
+{-# language DerivingStrategies #-}
+{-# language FlexibleContexts #-}
+{-# language FlexibleInstances #-}
+{-# language MultiParamTypeClasses #-}
+{-# language NamedFieldPuns #-}
+{-# language StandaloneKindSignatures #-}
+{-# language TypeFamilies #-}
+{-# language UndecidableInstances #-}
+
+module Rel8.Table.Either
+  ( EitherTable(..)
+  , eitherTable, leftTable, rightTable
+  , isLeftTable, isRightTable
+  )
+where
+
+-- base
+import Data.Bifunctor ( Bifunctor, bimap )
+import Data.Functor.Identity ( runIdentity )
+import Data.Kind ( Type )
+import Prelude hiding ( undefined )
+
+-- rel8
+import Rel8.Expr ( Expr )
+import Rel8.Expr.Serialize ( litExpr )
+import Rel8.Schema.Context ( DB )
+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
+import Rel8.Schema.Context.Nullify
+  ( Nullifiable, NullifiableEq
+  , encodeTag, decodeTag
+  , nullifier, unnullifier
+  )
+import Rel8.Schema.HTable.Either ( HEitherTable(..) )
+import Rel8.Schema.HTable.Identity ( HIdentity(..) )
+import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
+import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
+import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
+import Rel8.Table.Bool ( bool )
+import Rel8.Table.Lifted
+  ( Table1, Columns1, ConstrainContext1, fromColumns1, toColumns1
+  , Table2, Columns2, ConstrainContext2, fromColumns2, toColumns2
+  )
+import Rel8.Table.Recontextualize ( Recontextualize )
+import Rel8.Table.Undefined ( undefined )
+import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )
+
+-- semigroupoids
+import Data.Functor.Apply ( Apply, (<.>) )
+import Data.Functor.Bind ( Bind, (>>-) )
+
+
+type EitherTable :: Type -> Type -> Type
+data EitherTable a b = EitherTable
+  { tag :: Expr EitherTag
+  , left :: a
+  , right :: b
+  }
+  deriving stock (Show, Functor)
+
+
+instance Bifunctor EitherTable where
+  bimap f g (EitherTable tag a b) = EitherTable tag (f a) (g b)
+
+
+instance Table DB a => Apply (EitherTable a) where
+  EitherTable tag l1 f <.> EitherTable tag' l2 a =
+    EitherTable (tag <> tag') (bool l1 l2 (isLeft tag)) (f a)
+
+
+instance Table DB a => Applicative (EitherTable a) where
+  pure = rightTable
+  (<*>) = (<.>)
+
+
+instance Table DB a => Bind (EitherTable a) where
+  EitherTable tag l1 a >>- f = case f a of
+    EitherTable tag' l2 b ->
+      EitherTable (tag <> tag') (bool l1 l2 (isRight tag)) b
+
+
+instance Table DB a => Monad (EitherTable a) where
+  (>>=) = (>>-)
+
+
+instance (Table DB a, Table DB b) => Semigroup (EitherTable a b) where
+  a <> b = bool a b (isRightTable a)
+
+
+instance Table2 EitherTable where
+  type Columns2 EitherTable = HEitherTable
+  type ConstrainContext2 EitherTable = Nullifiable
+
+  toColumns2 f g EitherTable {tag, left, right} = HEitherTable
+    { htag
+    , hleft = hnullify (nullifier (isLeft tag)) $ f left
+    , hright = hnullify (nullifier (isRight tag)) $ g right
+    }
+    where
+      htag = HIdentity (encodeTag tag)
+
+  fromColumns2 f g HEitherTable {htag = htag, hleft, hright} =
+    EitherTable
+      { tag
+      , left = f $ runIdentity $
+          hunnullify (\a -> pure . unnullifier (isLeft tag) a) hleft
+      , right = g $ runIdentity $
+          hunnullify (\a -> pure . unnullifier (isRight tag) a) hright
+      }
+    where
+      tag = decodeTag $ unHIdentity htag
+
+  {-# INLINABLE fromColumns2 #-}
+  {-# INLINABLE toColumns2 #-}
+
+
+instance Table context a => Table1 (EitherTable a) where
+  type Columns1 (EitherTable a) = HEitherTable (Columns a)
+  type ConstrainContext1 (EitherTable a) = NullifiableEq (Context a)
+
+  toColumns1 = toColumns2 toColumns
+  fromColumns1 = fromColumns2 fromColumns
+
+
+instance
+  ( Table context a, Table context b
+  , Labelable context, Nullifiable context
+  ) =>
+  Table context (EitherTable a b)
+ where
+  type Columns (EitherTable a b) =
+    HEitherTable (HLabel "Left" (Columns a)) (HLabel "Right" (Columns b))
+  type Context (EitherTable a b) = Context a
+
+  toColumns =
+    toColumns2
+      (hlabel labeler . toColumns)
+      (hlabel labeler . toColumns)
+  fromColumns =
+    fromColumns2
+      (fromColumns . hunlabel unlabeler)
+      (fromColumns . hunlabel unlabeler)
+
+
+instance
+  ( Nullifiable from, Labelable from
+  , Nullifiable to, Labelable to
+  , Recontextualize from to a1 b1
+  , Recontextualize from to a2 b2
+  ) =>
+  Recontextualize from to (EitherTable a1 a2) (EitherTable b1 b2)
+
+
+isLeftTable :: EitherTable a b -> Expr Bool
+isLeftTable = isLeft . tag
+
+
+isRightTable :: EitherTable a b -> Expr Bool
+isRightTable = isRight . tag
+
+
+eitherTable :: Table DB c
+  => (a -> c) -> (b -> c) -> EitherTable a b -> c
+eitherTable f g EitherTable {tag, left, right} =
+  bool (f left) (g right) (isRight tag)
+
+
+leftTable :: Table DB b => a -> EitherTable a b
+leftTable a = EitherTable (litExpr IsLeft) a undefined
+
+
+rightTable :: Table DB a => b -> EitherTable a b
+rightTable = EitherTable (litExpr IsRight) undefined

src/Rel8/Table/Eq.hs

@@ -0,0 +1,82 @@
+{-# language DataKinds #-}
+{-# language FlexibleContexts #-}
+{-# language FlexibleInstances #-}
+{-# language NamedFieldPuns #-}
+{-# language ScopedTypeVariables #-}
+{-# language StandaloneKindSignatures #-}
+{-# language TypeApplications #-}
+{-# language TypeFamilies #-}
+{-# language UndecidableInstances #-}
+{-# language UndecidableSuperClasses #-}
+{-# language ViewPatterns #-}
+
+module Rel8.Table.Eq
+  ( EqTable, (==:), (/=:)
+  )
+where
+
+-- base
+import Data.Foldable ( foldl' )
+import Data.Functor.Const ( Const( Const ), getConst )
+import Data.Kind ( Constraint, Type )
+import Data.List.NonEmpty ( NonEmpty( (:|) ) )
+import Prelude hiding ( seq )
+
+-- rel8
+import Rel8.Expr ( Expr )
+import Rel8.Expr.Bool ( (||.), (&&.) )
+import Rel8.Expr.Eq ( seq, sne )
+import Rel8.Opaque ( Opaque )
+import Rel8.Schema.Context ( DB( DB ) )
+import Rel8.Schema.Dict ( Dict( Dict ) )
+import Rel8.Schema.HTable
+  ( HConstrainTable
+  , htabulateA, hfield
+  , hdicts, hspecs
+  )
+import Rel8.Schema.Spec ( SSpec(..) )
+import Rel8.Schema.Spec.ConstrainDBType ( ConstrainDBType )
+import Rel8.Table ( Table, Columns, toColumns )
+import Rel8.Type.Eq ( DBEq )
+
+
+type EqTable :: Type -> Constraint
+class
+  ( Table DB a
+  , HConstrainTable (Columns a) (ConstrainDBType DBEq)
+  ) => EqTable a
+instance
+  ( Table DB a
+  , HConstrainTable (Columns a) (ConstrainDBType DBEq)
+  ) => EqTable a
+instance {-# OVERLAPPING #-} EqTable Opaque
+
+
+(==:) :: forall a. EqTable a => a -> a -> Expr Bool
+(toColumns -> as) ==: (toColumns -> bs) =
+  foldl1' (&&.) $ getConst $ htabulateA $ \field ->
+    case (hfield as field, hfield bs field) of
+      (DB a, DB b) -> case hfield dicts field of
+        Dict -> case hfield specs field of
+          SSpec {nullability} -> Const (pure (seq nullability a b))
+  where
+    dicts = hdicts @(Columns a) @(ConstrainDBType DBEq)
+    specs = hspecs @(Columns a)
+infix 4 ==:
+
+
+(/=:) :: forall a. EqTable a => a -> a -> Expr Bool
+(toColumns -> as) /=: (toColumns -> bs) =
+  foldl1' (||.) $ getConst $ htabulateA $ \field ->
+    case (hfield as field, hfield bs field) of
+      (DB a, DB b) -> case hfield dicts field of
+        Dict -> case hfield specs field of
+          SSpec {nullability} -> Const (pure (sne nullability a b))
+  where
+    dicts = hdicts @(Columns a) @(ConstrainDBType DBEq)
+    specs = hspecs @(Columns a)
+infix 4 /=:
+
+
+foldl1' :: (a -> a -> a) -> NonEmpty a -> a
+foldl1' f (a :| as) = foldl' f a as

src/Rel8/Table/Insert.hs

@@ -0,0 +1,39 @@
+{-# language FlexibleContexts #-}
+{-# language NamedFieldPuns #-}
+{-# language TypeFamilies #-}
+{-# language ViewPatterns #-}
+
+module Rel8.Table.Insert
+  ( toInsert
+  , toInsertDefaults
+  )
+where
+
+-- base
+import Prelude
+
+-- rel8
+import Rel8.Kind.Necessity ( SNecessity( SOptional, SRequired ) )
+import Rel8.Schema.Context ( DB(..), Insertion(..) )
+import Rel8.Schema.HTable ( hfield, htabulate, hspecs )
+import Rel8.Schema.Spec ( SSpec(..) )
+import Rel8.Table ( fromColumns, toColumns )
+import Rel8.Table.Recontextualize ( Inserts )
+
+
+toInsert :: Inserts exprs inserts => exprs -> inserts
+toInsert (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
+  case hfield hspecs field of
+    SSpec {necessity} -> case hfield exprs field of
+      DB expr -> case necessity of
+        SRequired -> RequiredInsert expr
+        SOptional -> OptionalInsert (Just expr)
+
+
+toInsertDefaults :: Inserts exprs inserts => exprs -> inserts
+toInsertDefaults (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
+  case hfield hspecs field of
+    SSpec {necessity} -> case hfield exprs field of
+      DB expr -> case necessity of
+        SRequired -> RequiredInsert expr
+        SOptional -> OptionalInsert Nothing

src/Rel8/Table/Lifted.hs

@@ -0,0 +1,62 @@
+{-# language ConstrainedClassMethods #-}
+{-# language DataKinds #-}
+{-# language FlexibleContexts #-}
+{-# language FlexibleInstances #-}
+{-# language StandaloneKindSignatures #-}
+{-# language TypeFamilies #-}
+
+module Rel8.Table.Lifted
+  ( Table1( Columns1, ConstrainContext1, toColumns1, fromColumns1 )
+  , Table2( Columns2, ConstrainContext2, toColumns2, fromColumns2 )
+  )
+where
+
+-- base
+import Data.Kind ( Constraint, Type )
+import Prelude ()
+
+-- rel8
+import Rel8.Schema.HTable ( HTable )
+import Rel8.Schema.HTable.Context ( H, HKTable )
+import Rel8.Schema.Spec ( Context )
+
+
+type Table1 :: (Type -> Type) -> Constraint
+class Table1 f where
+  type Columns1 f :: HKTable -> HKTable
+  type ConstrainContext1 f :: Context -> Constraint
+  type ConstrainContext1 _ = DefaultConstrainContext
+
+  toColumns1 :: (ConstrainContext1 f context, HTable t)
+    => (a -> t (H context))
+    -> f a
+    -> Columns1 f t (H context)
+
+  fromColumns1 :: (ConstrainContext1 f context, HTable t)
+    => (t (H context) -> a)
+    -> Columns1 f t (H context)
+    -> f a
+
+
+type Table2 :: (Type -> Type -> Type) -> Constraint
+class Table2 p where
+  type Columns2 p :: HKTable -> HKTable -> HKTable
+  type ConstrainContext2 p :: Context -> Constraint
+  type ConstrainContext2 _ = DefaultConstrainContext
+
+  toColumns2 :: (ConstrainContext2 p context, HTable t, HTable u)
+    => (a -> t (H context))
+    -> (b -> u (H context))
+    -> p a b
+    -> Columns2 p t u (H context)
+
+  fromColumns2 :: (ConstrainContext2 p context, HTable t, HTable u)
+    => (t (H context) -> a)
+    -> (u (H context) -> b)
+    -> Columns2 p t u (H context)
+    -> p a b
+
+
+type DefaultConstrainContext :: Context -> Constraint
+class DefaultConstrainContext context
+instance DefaultConstrainContext context

src/Rel8/Table/List.hs

@@ -0,0 +1,62 @@
+{-# language FlexibleContexts #-}
+{-# language FlexibleInstances #-}
+{-# language MultiParamTypeClasses #-}
+{-# language StandaloneKindSignatures #-}
+{-# language TypeFamilies #-}
+{-# language UndecidableInstances #-}
+
+module Rel8.Table.List
+  ( ListTable(..)
+  )
+where
+
+-- base
+import Data.Kind ( Type )
+import Prelude
+
+-- rel8
+import Rel8.Expr.Array ( sappend, sempty )
+import Rel8.Schema.Context ( DB( DB ) )
+import Rel8.Schema.HTable.Context ( H )
+import Rel8.Schema.HTable.List ( HListTable )
+import Rel8.Schema.HTable.Vectorize ( happend, hempty )
+import Rel8.Table ( Table, Context, Columns, fromColumns, toColumns )
+import Rel8.Table.Alternative
+  ( AltTable, (<|>:)
+  , AlternativeTable, emptyTable
+  )
+import Rel8.Table.Recontextualize ( Recontextualize )
+
+
+type ListTable :: Type -> Type
+newtype ListTable a = ListTable (HListTable (Columns a) (H (Context a)))
+
+
+instance Table context a => Table context (ListTable a) where
+  type Columns (ListTable a) = HListTable (Columns a)
+  type Context (ListTable a) = Context a
+
+  fromColumns = ListTable
+  toColumns (ListTable a) = a
+
+
+instance Recontextualize from to a b =>
+  Recontextualize from to (ListTable a) (ListTable b)
+
+
+instance AltTable ListTable where
+  (<|>:) = (<>)
+
+
+instance AlternativeTable ListTable where
+  emptyTable = mempty
+
+
+instance Table DB a => Semigroup (ListTable a) where
+  ListTable as <> ListTable bs = ListTable $
+    happend (\_ _ (DB a) (DB b) -> DB (sappend a b)) as bs
+
+
+instance Table DB a => Monoid (ListTable a) where
+  mempty = ListTable $ hempty $ \nullability info ->
+    DB (sempty nullability info)

src/Rel8/Table/Maybe.hs

@@ -0,0 +1,180 @@
+{-# language DataKinds #-}
+{-# language DeriveFunctor #-}
+{-# language DerivingStrategies #-}
+{-# language FlexibleContexts #-}
+{-# language FlexibleInstances #-}
+{-# language MultiParamTypeClasses #-}
+{-# language NamedFieldPuns #-}
+{-# language ScopedTypeVariables #-}
+{-# language StandaloneKindSignatures #-}
+{-# language TypeApplications #-}
+{-# language TypeFamilies #-}
+{-# language UndecidableInstances #-}
+
+module Rel8.Table.Maybe
+  ( MaybeTable(..)
+  , maybeTable, nothingTable, justTable
+  , isNothingTable, isJustTable
+  , ($?)
+  )
+where
+
+-- base
+import Data.Functor.Identity ( runIdentity )
+import Data.Kind ( Type )
+import Prelude hiding ( null, repeat, undefined, zipWith )
+
+-- rel8
+import Rel8.Expr ( Expr )
+import Rel8.Expr.Bool ( boolExpr )
+import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )
+import Rel8.Expr.Serialize ( litExpr )
+import Rel8.Schema.Context ( DB )
+import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
+import Rel8.Schema.Context.Nullify
+  ( Nullifiable
+  , encodeTag, decodeTag
+  , nullifier, unnullifier
+  )
+import Rel8.Schema.HTable.Identity ( HIdentity(..) )
+import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
+import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) )
+import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
+import Rel8.Schema.Nullability
+  ( Nullability( Nullable, NonNullable )
+  , Nullabilizes, nullabilization
+  )
+import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
+import Rel8.Table.Alternative
+  ( AltTable, (<|>:)
+  , AlternativeTable, emptyTable
+  )
+import Rel8.Table.Bool ( bool )
+import Rel8.Table.Lifted
+  ( Table1, Columns1, ConstrainContext1, fromColumns1, toColumns1
+  )
+import Rel8.Table.Recontextualize ( Recontextualize )
+import Rel8.Table.Undefined ( undefined )
+import Rel8.Type ( DBType )
+import Rel8.Type.Tag ( MaybeTag( IsJust ) )
+
+-- semigroupoids
+import Data.Functor.Apply ( Apply, (<.>) )
+import Data.Functor.Bind ( Bind, (>>-) )
+
+
+type MaybeTable :: Type -> Type
+data MaybeTable a = MaybeTable
+  { tag :: Expr (Maybe MaybeTag)
+  , just :: a
+  }
+  deriving stock (Show, Functor)
+
+
+instance Apply MaybeTable where
+  MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f a)
+
+
+instance Applicative MaybeTable where
+  (<*>) = (<.>)
+  pure = justTable
+
+
+instance Bind MaybeTable where
+  MaybeTable tag a >>- f = case f a of
+    MaybeTable tag' b -> MaybeTable (tag <> tag') b
+
+
+instance Monad MaybeTable where
+  (>>=) = (>>-)
+
+
+instance AltTable MaybeTable where
+  ma@(MaybeTable tag a) <|>: MaybeTable tag' b = MaybeTable
+    { tag = boolExpr tag tag' condition
+    , just = bool a b condition
+    }
+    where
+      condition = isNothingTable ma
+
+
+instance AlternativeTable MaybeTable where
+  emptyTable = nothingTable
+
+
+instance (Table DB a, Semigroup a) => Semigroup (MaybeTable a) where
+  ma <> mb = maybeTable mb (\a -> maybeTable ma (justTable . (a <>)) mb) ma
+
+
+instance (Table DB a, Semigroup a) => Monoid (MaybeTable a) where
+  mempty = nothingTable
+
+
+instance Table1 MaybeTable where
+  type Columns1 MaybeTable = HMaybeTable
+  type ConstrainContext1 MaybeTable = Nullifiable
+
+  toColumns1 f MaybeTable {tag, just} = HMaybeTable
+    { htag
+    , hjust = hnullify (nullifier (isNonNull tag)) $ f just
+    }
+    where
+      htag = HIdentity (encodeTag tag)
+
+  fromColumns1 f HMaybeTable {htag = HIdentity htag, hjust} = MaybeTable
+    { tag
+    , just = f $ runIdentity $
+        hunnullify (\a -> pure . unnullifier (isNonNull tag) a) hjust
+    }
+    where
+      tag = decodeTag htag
+
+  {-# INLINABLE fromColumns1 #-}
+  {-# INLINABLE toColumns1 #-}
+
+
+instance
+  ( Table context a
+  , Labelable context, Nullifiable context
+  ) => Table context (MaybeTable a)
+ where
+  type Columns (MaybeTable a) = HMaybeTable (HLabel "Just" (Columns a))
+  type Context (MaybeTable a) = Context a
+
+  toColumns = toColumns1 (hlabel labeler . toColumns)
+  fromColumns = fromColumns1 (fromColumns . hunlabel unlabeler)
+
+
+instance
+  ( Labelable from, Nullifiable from
+  , Labelable to, Nullifiable to
+  , Recontextualize from to a b
+  ) => Recontextualize from to (MaybeTable a) (MaybeTable b)
+
+
+isNothingTable :: MaybeTable a -> Expr Bool
+isNothingTable (MaybeTable tag _) = isNull tag
+
+
+isJustTable :: MaybeTable a -> Expr Bool
+isJustTable (MaybeTable tag _) = isNonNull tag
+
+
+maybeTable :: Table DB b => b -> (a -> b) -> MaybeTable a -> b
+maybeTable b f ma@(MaybeTable _ a) = bool (f a) b (isNothingTable ma)
+
+
+nothingTable :: Table DB a => MaybeTable a
+nothingTable = MaybeTable null undefined
+
+
+justTable :: a -> MaybeTable a
+justTable = MaybeTable (nullify (litExpr IsJust))
+
+
+($?) :: forall a b db. (DBType db, Nullabilizes db b)
+  => (a -> Expr b) -> MaybeTable a -> Expr (Maybe db)
+f $? ma@(MaybeTable _ a) = case nullabilization @b of
+  Nullable -> boolExpr (f a) null (isNothingTable ma)
+  NonNullable -> boolExpr (nullify (f a)) null (isNothingTable ma)
+infixl 4 $?

src/Rel8/Table/Name.hs

@@ -0,0 +1,55 @@
+{-# language FlexibleContexts #-}
+{-# language NamedFieldPuns #-}
+{-# language ScopedTypeVariables #-}
+{-# language TypeApplications #-}
+{-# language TypeFamilies #-}
+{-# language ViewPatterns #-}
+
+module Rel8.Table.Name
+  ( namesFromLabels
+  , namesFromLabelsWith
+  , showLabels
+  , showNames
+  )
+where
+
+-- base
+import Data.Foldable ( fold )
+import Data.Functor.Const ( Const( Const ), getConst )
+import Data.List.NonEmpty ( NonEmpty, intersperse )
+import Prelude
+
+-- casing
+import Text.Casing ( quietSnake )
+
+-- rel8
+import Rel8.Kind.Labels ( renderLabels )
+import Rel8.Schema.Context ( Name( Name ) )
+import Rel8.Schema.HTable ( htabulate, htabulateA, hfield, hspecs )
+import Rel8.Schema.Spec ( SSpec(..) )
+import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
+
+
+namesFromLabels :: Table Name a => a
+namesFromLabels = namesFromLabelsWith go
+  where
+    go = fold . intersperse "/" . fmap quietSnake
+
+
+namesFromLabelsWith :: Table Name a
+  => (NonEmpty String -> String) -> a
+namesFromLabelsWith f = fromColumns $ htabulate $ \field ->
+  case hfield hspecs field of
+    SSpec {labels} -> Name (f (renderLabels labels))
+
+
+showLabels :: forall a. Table (Context a) a => a -> [NonEmpty String]
+showLabels _ = getConst $
+  htabulateA @(Columns a) $ \field -> case hfield hspecs field of
+    SSpec {labels} -> Const [renderLabels labels]
+
+
+showNames :: forall a. Table Name a => a -> [String]
+showNames (toColumns -> names) = getConst $
+  htabulateA @(Columns a) $ \field -> case hfield names field of
+    Name name -> Const [name]