mirror of
https://github.com/circuithub/rel8.git
synced 2024-08-16 19:30:26 +03:00
The beginning of rel8 1.0
Co-authored-by: Ollie Charles <ollie@ocharles.org.uk>
This commit is contained in:
commit
6360f10fb7
1
.gitignore
vendored
Normal file
1
.gitignore
vendored
Normal file
@ -0,0 +1 @@
|
||||
/dist-newstyle
|
33
Doctest.hs
Normal file
33
Doctest.hs
Normal file
@ -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
|
26
LICENSE
Normal file
26
LICENSE
Normal file
@ -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.
|
6
Setup.hs
Normal file
6
Setup.hs
Normal file
@ -0,0 +1,6 @@
|
||||
module Main where
|
||||
|
||||
import Distribution.Extra.Doctest (defaultMainWithDoctests)
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMainWithDoctests "doctests"
|
1
cabal.project
Normal file
1
cabal.project
Normal file
@ -0,0 +1 @@
|
||||
packages: .
|
29
default.nix
Normal file
29
default.nix
Normal file
@ -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"}"
|
||||
'';
|
||||
};
|
||||
}
|
||||
];
|
||||
}
|
5
jobs.nix
Normal file
5
jobs.nix
Normal file
@ -0,0 +1,5 @@
|
||||
let rel8 = (import ./.).hsPkgs.rel8;
|
||||
in {
|
||||
rel8 = rel8.components.library;
|
||||
tests = rel8.checks.tests;
|
||||
}
|
38
nix/sources.json
Normal file
38
nix/sources.json
Normal file
@ -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"
|
||||
}
|
||||
}
|
148
nix/sources.nix
Normal file
148
nix/sources.nix
Normal file
@ -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); }
|
204
rel8.cabal
Normal file
204
rel8.cabal
Normal file
@ -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
|
11
shell.nix
Normal file
11
shell.nix
Normal file
@ -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 ];
|
||||
}
|
68
src/Rel8/Aggregate.hs
Normal file
68
src/Rel8/Aggregate.hs
Normal file
@ -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)
|
84
src/Rel8/Expr.hs
Normal file
84
src/Rel8/Expr.hs
Normal file
@ -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
|
19
src/Rel8/Expr.hs-boot
Normal file
19
src/Rel8/Expr.hs-boot
Normal file
@ -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
|
158
src/Rel8/Expr/Aggregate.hs
Normal file
158
src/Rel8/Expr/Aggregate.hs
Normal file
@ -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
|
59
src/Rel8/Expr/Array.hs
Normal file
59
src/Rel8/Expr/Array.hs
Normal file
@ -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
|
68
src/Rel8/Expr/Bool.hs
Normal file
68
src/Rel8/Expr/Bool.hs
Normal file
@ -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)
|
93
src/Rel8/Expr/Eq.hs
Normal file
93
src/Rel8/Expr/Eq.hs
Normal file
@ -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
|
81
src/Rel8/Expr/Function.hs
Normal file
81
src/Rel8/Expr/Function.hs
Normal file
@ -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
|
87
src/Rel8/Expr/Null.hs
Normal file
87
src/Rel8/Expr/Null.hs
Normal file
@ -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))
|
80
src/Rel8/Expr/Num.hs
Normal file
80
src/Rel8/Expr/Num.hs
Normal file
@ -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"
|
145
src/Rel8/Expr/Opaleye.hs
Normal file
145
src/Rel8/Expr/Opaleye.hs
Normal file
@ -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
|
130
src/Rel8/Expr/Ord.hs
Normal file
130
src/Rel8/Expr/Ord.hs
Normal file
@ -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])
|
63
src/Rel8/Expr/Order.hs
Normal file
63
src/Rel8/Expr/Order.hs
Normal file
@ -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 }
|
47
src/Rel8/Expr/Serialize.hs
Normal file
47
src/Rel8/Expr/Serialize.hs
Normal file
@ -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
|
241
src/Rel8/Expr/Text.hs
Normal file
241
src/Rel8/Expr/Text.hs
Normal file
@ -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"
|
155
src/Rel8/Expr/Time.hs
Normal file
155
src/Rel8/Expr/Time.hs
Normal file
@ -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 ++ "'"
|
43
src/Rel8/Kind/Bool.hs
Normal file
43
src/Rel8/Kind/Bool.hs
Normal file
@ -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
|
61
src/Rel8/Kind/Labels.hs
Normal file
61
src/Rel8/Kind/Labels.hs
Normal file
@ -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)
|
38
src/Rel8/Kind/Necessity.hs
Normal file
38
src/Rel8/Kind/Necessity.hs
Normal file
@ -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
|
20
src/Rel8/Opaque.hs
Normal file
20
src/Rel8/Opaque.hs
Normal file
@ -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
|
24
src/Rel8/Order.hs
Normal file
24
src/Rel8/Order.hs
Normal file
@ -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)
|
36
src/Rel8/Query.hs
Normal file
36
src/Rel8/Query.hs
Normal file
@ -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 []
|
17
src/Rel8/Query.hs-boot
Normal file
17
src/Rel8/Query.hs-boot
Normal file
@ -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)
|
22
src/Rel8/Query/Aggregate.hs
Normal file
22
src/Rel8/Query/Aggregate.hs
Normal file
@ -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)
|
37
src/Rel8/Query/Distinct.hs
Normal file
37
src/Rel8/Query/Distinct.hs
Normal file
@ -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))
|
29
src/Rel8/Query/Each.hs
Normal file
29
src/Rel8/Query/Each.hs
Normal file
@ -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
|
64
src/Rel8/Query/Either.hs
Normal file
64
src/Rel8/Query/Either.hs
Normal file
@ -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
|
57
src/Rel8/Query/Exists.hs
Normal file
57
src/Rel8/Query/Exists.hs
Normal file
@ -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)
|
29
src/Rel8/Query/Filter.hs
Normal file
29
src/Rel8/Query/Filter.hs
Normal file
@ -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
|
23
src/Rel8/Query/Limit.hs
Normal file
23
src/Rel8/Query/Limit.hs
Normal file
@ -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
|
28
src/Rel8/Query/List.hs
Normal file
28
src/Rel8/Query/List.hs
Normal file
@ -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
|
60
src/Rel8/Query/Maybe.hs
Normal file
60
src/Rel8/Query/Maybe.hs
Normal file
@ -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
|
19
src/Rel8/Query/Null.hs
Normal file
19
src/Rel8/Query/Null.hs
Normal file
@ -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
|
34
src/Rel8/Query/Opaleye.hs
Normal file
34
src/Rel8/Query/Opaleye.hs
Normal file
@ -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)
|
200
src/Rel8/Query/Optimize.hs
Normal file
200
src/Rel8/Query/Optimize.hs
Normal file
@ -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)
|
19
src/Rel8/Query/Order.hs
Normal file
19
src/Rel8/Query/Order.hs
Normal file
@ -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)
|
72
src/Rel8/Query/SQL.hs
Normal file
72
src/Rel8/Query/SQL.hs
Normal file
@ -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))
|
46
src/Rel8/Query/Set.hs
Normal file
46
src/Rel8/Query/Set.hs
Normal file
@ -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)
|
129
src/Rel8/Query/These.hs
Normal file
129
src/Rel8/Query/These.hs
Normal file
@ -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
|
24
src/Rel8/Query/Values.hs
Normal file
24
src/Rel8/Query/Values.hs
Normal file
@ -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
|
141
src/Rel8/Schema/Column.hs
Normal file
141
src/Rel8/Schema/Column.hs
Normal file
@ -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
|
144
src/Rel8/Schema/Context.hs
Normal file
144
src/Rel8/Schema/Context.hs
Normal file
@ -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
|
67
src/Rel8/Schema/Context/Label.hs
Normal file
67
src/Rel8/Schema/Context/Label.hs
Normal file
@ -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
|
165
src/Rel8/Schema/Context/Nullify.hs
Normal file
165
src/Rel8/Schema/Context/Nullify.hs
Normal file
@ -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))
|
198
src/Rel8/Schema/Context/Result.hs
Normal file
198
src/Rel8/Schema/Context/Result.hs
Normal file
@ -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)
|
18
src/Rel8/Schema/Dict.hs
Normal file
18
src/Rel8/Schema/Dict.hs
Normal file
@ -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
|
41
src/Rel8/Schema/Field.hs
Normal file
41
src/Rel8/Schema/Field.hs
Normal file
@ -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
|
1021
src/Rel8/Schema/Generic.hs
Normal file
1021
src/Rel8/Schema/Generic.hs
Normal file
File diff suppressed because it is too large
Load Diff
79
src/Rel8/Schema/Generic/Test.hs
Normal file
79
src/Rel8/Schema/Generic/Test.hs
Normal file
@ -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
|
173
src/Rel8/Schema/HTable.hs
Normal file
173
src/Rel8/Schema/HTable.hs
Normal file
@ -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 #-}
|
26
src/Rel8/Schema/HTable/Context.hs
Normal file
26
src/Rel8/Schema/HTable/Context.hs
Normal file
@ -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
|
33
src/Rel8/Schema/HTable/Either.hs
Normal file
33
src/Rel8/Schema/HTable/Either.hs
Normal file
@ -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
|
44
src/Rel8/Schema/HTable/Identity.hs
Normal file
44
src/Rel8/Schema/HTable/Identity.hs
Normal file
@ -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
|
131
src/Rel8/Schema/HTable/Label.hs
Normal file
131
src/Rel8/Schema/HTable/Label.hs
Normal file
@ -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 #-}
|
18
src/Rel8/Schema/HTable/List.hs
Normal file
18
src/Rel8/Schema/HTable/List.hs
Normal file
@ -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 []
|
32
src/Rel8/Schema/HTable/Maybe.hs
Normal file
32
src/Rel8/Schema/HTable/Maybe.hs
Normal file
@ -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
|
19
src/Rel8/Schema/HTable/NonEmpty.hs
Normal file
19
src/Rel8/Schema/HTable/NonEmpty.hs
Normal file
@ -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
|
146
src/Rel8/Schema/HTable/Nullify.hs
Normal file
146
src/Rel8/Schema/HTable/Nullify.hs
Normal file
@ -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 #-}
|
20
src/Rel8/Schema/HTable/Pair.hs
Normal file
20
src/Rel8/Schema/HTable/Pair.hs
Normal file
@ -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
|
||||
}
|
29
src/Rel8/Schema/HTable/Quartet.hs
Normal file
29
src/Rel8/Schema/HTable/Quartet.hs
Normal file
@ -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
|
30
src/Rel8/Schema/HTable/Quintet.hs
Normal file
30
src/Rel8/Schema/HTable/Quintet.hs
Normal file
@ -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
|
34
src/Rel8/Schema/HTable/These.hs
Normal file
34
src/Rel8/Schema/HTable/These.hs
Normal file
@ -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
|
28
src/Rel8/Schema/HTable/Trio.hs
Normal file
28
src/Rel8/Schema/HTable/Trio.hs
Normal file
@ -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
|
60
src/Rel8/Schema/HTable/Type.hs
Normal file
60
src/Rel8/Schema/HTable/Type.hs
Normal file
@ -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
|
||||
}
|
220
src/Rel8/Schema/HTable/Vectorize.hs
Normal file
220
src/Rel8/Schema/HTable/Vectorize.hs
Normal file
@ -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)
|
86
src/Rel8/Schema/Nullability.hs
Normal file
86
src/Rel8/Schema/Nullability.hs
Normal file
@ -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'
|
75
src/Rel8/Schema/Spec.hs
Normal file
75
src/Rel8/Schema/Spec.hs
Normal file
@ -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
|
23
src/Rel8/Schema/Spec/ConstrainContext.hs
Normal file
23
src/Rel8/Schema/Spec/ConstrainContext.hs
Normal file
@ -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
|
34
src/Rel8/Schema/Spec/ConstrainDBType.hs
Normal file
34
src/Rel8/Schema/Spec/ConstrainDBType.hs
Normal file
@ -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
|
31
src/Rel8/Schema/Spec/ConstrainType.hs
Normal file
31
src/Rel8/Schema/Spec/ConstrainType.hs
Normal file
@ -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
|
53
src/Rel8/Schema/Structure.hs
Normal file
53
src/Rel8/Schema/Structure.hs
Normal file
@ -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
|
18
src/Rel8/Schema/Table.hs
Normal file
18
src/Rel8/Schema/Table.hs
Normal file
@ -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
|
87
src/Rel8/Statement/Delete.hs
Normal file
87
src/Rel8/Statement/Delete.hs
Normal file
@ -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)
|
105
src/Rel8/Statement/Insert.hs
Normal file
105
src/Rel8/Statement/Insert.hs
Normal file
@ -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)
|
24
src/Rel8/Statement/Returning.hs
Normal file
24
src/Rel8/Statement/Returning.hs
Normal file
@ -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]
|
61
src/Rel8/Statement/Select.hs
Normal file
61
src/Rel8/Statement/Select.hs
Normal file
@ -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
|
100
src/Rel8/Statement/Update.hs
Normal file
100
src/Rel8/Statement/Update.hs
Normal file
@ -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)
|
59
src/Rel8/Statement/View.hs
Normal file
59
src/Rel8/Statement/View.hs
Normal file
@ -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]
|
236
src/Rel8/Table.hs
Normal file
236
src/Rel8/Table.hs
Normal file
@ -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
|
62
src/Rel8/Table/Aggregate.hs
Normal file
62
src/Rel8/Table/Aggregate.hs
Normal file
@ -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
|
28
src/Rel8/Table/Alternative.hs
Normal file
28
src/Rel8/Table/Alternative.hs
Normal file
@ -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
|
35
src/Rel8/Table/Bool.hs
Normal file
35
src/Rel8/Table/Bool.hs
Normal file
@ -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)
|
174
src/Rel8/Table/Either.hs
Normal file
174
src/Rel8/Table/Either.hs
Normal file
@ -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
|
82
src/Rel8/Table/Eq.hs
Normal file
82
src/Rel8/Table/Eq.hs
Normal file
@ -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
|
39
src/Rel8/Table/Insert.hs
Normal file
39
src/Rel8/Table/Insert.hs
Normal file
@ -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
|
62
src/Rel8/Table/Lifted.hs
Normal file
62
src/Rel8/Table/Lifted.hs
Normal file
@ -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
|
62
src/Rel8/Table/List.hs
Normal file
62
src/Rel8/Table/List.hs
Normal file
@ -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)
|
180
src/Rel8/Table/Maybe.hs
Normal file
180
src/Rel8/Table/Maybe.hs
Normal file
@ -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 $?
|
55
src/Rel8/Table/Name.hs
Normal file
55
src/Rel8/Table/Name.hs
Normal file
@ -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]
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user