From 34cbe8fe609c807a845d83ec9ec3a4da33caa2b9 Mon Sep 17 00:00:00 2001 From: Ollie Charles Date: Fri, 7 Jul 2023 11:27:35 +0100 Subject: [PATCH] Format with fourmolu and ch-hs-imports --- default.nix | 5 +- fourmolu.yaml | 10 + nix/sources.json | 12 + nix/sources.nix | 107 +- rel8.cabal | 87 +- shell.nix | 32 +- src/Rel8.hs | 1263 ++++++++++++----------- src/Rel8/Aggregate.hs | 230 +++-- src/Rel8/Aggregate/Fold.hs | 31 +- src/Rel8/Column.hs | 29 +- src/Rel8/Column/ADT.hs | 18 +- src/Rel8/Column/Either.hs | 25 +- src/Rel8/Column/Lift.hs | 18 +- src/Rel8/Column/List.hs | 23 +- src/Rel8/Column/Maybe.hs | 25 +- src/Rel8/Column/NonEmpty.hs | 27 +- src/Rel8/Column/Null.hs | 25 +- src/Rel8/Column/These.hs | 27 +- src/Rel8/Expr.hs | 98 +- src/Rel8/Expr/Aggregate.hs | 209 ++-- src/Rel8/Expr/Array.hs | 46 +- src/Rel8/Expr/Bool.hs | 67 +- src/Rel8/Expr/Default.hs | 49 +- src/Rel8/Expr/Eq.hs | 129 ++- src/Rel8/Expr/Function.hs | 66 +- src/Rel8/Expr/Null.hs | 110 +- src/Rel8/Expr/Num.hs | 154 +-- src/Rel8/Expr/Opaleye.hs | 99 +- src/Rel8/Expr/Ord.hs | 126 ++- src/Rel8/Expr/Order.hs | 63 +- src/Rel8/Expr/Sequence.hs | 18 +- src/Rel8/Expr/Serialize.hs | 41 +- src/Rel8/Expr/Text.hs | 170 ++- src/Rel8/Expr/Time.hs | 77 +- src/Rel8/Expr/Window.hs | 66 +- src/Rel8/FCF.hs | 21 +- src/Rel8/Generic/Construction.hs | 368 ++++--- src/Rel8/Generic/Construction/ADT.hs | 574 +++++----- src/Rel8/Generic/Construction/Record.hs | 198 ++-- src/Rel8/Generic/Map.hs | 55 +- src/Rel8/Generic/Record.hs | 76 +- src/Rel8/Generic/Rel8able.hs | 334 +++--- src/Rel8/Generic/Table.hs | 137 +-- src/Rel8/Generic/Table/ADT.hs | 276 +++-- src/Rel8/Generic/Table/Record.hs | 227 ++-- src/Rel8/Kind/Algebra.hs | 22 +- src/Rel8/Kind/Context.hs | 30 +- src/Rel8/Order.hs | 31 +- src/Rel8/Query.hs | 279 ++--- src/Rel8/Query/Aggregate.hs | 66 +- src/Rel8/Query/Distinct.hs | 39 +- src/Rel8/Query/Each.hs | 37 +- src/Rel8/Query/Either.hs | 79 +- src/Rel8/Query/Evaluate.hs | 64 +- src/Rel8/Query/Exists.hs | 50 +- src/Rel8/Query/Filter.hs | 34 +- src/Rel8/Query/Indexed.hs | 20 +- src/Rel8/Query/Limit.hs | 22 +- src/Rel8/Query/List.hs | 138 +-- src/Rel8/Query/Loop.hs | 33 +- src/Rel8/Query/Materialize.hs | 54 +- src/Rel8/Query/Maybe.hs | 73 +- src/Rel8/Query/Null.hs | 44 +- src/Rel8/Query/Opaleye.hs | 52 +- src/Rel8/Query/Order.hs | 14 +- src/Rel8/Query/Rebind.hs | 31 +- src/Rel8/Query/SQL.hs | 18 +- src/Rel8/Query/Set.hs | 59 +- src/Rel8/Query/These.hs | 90 +- src/Rel8/Query/Values.hs | 27 +- src/Rel8/Query/Window.hs | 27 +- src/Rel8/Schema/Context/Nullify.hs | 116 ++- src/Rel8/Schema/Dict.hs | 16 +- src/Rel8/Schema/Field.hs | 51 +- src/Rel8/Schema/HTable.hs | 231 +++-- src/Rel8/Schema/HTable/Either.hs | 32 +- src/Rel8/Schema/HTable/Identity.hs | 45 +- src/Rel8/Schema/HTable/Label.hs | 73 +- src/Rel8/Schema/HTable/List.hs | 12 +- src/Rel8/Schema/HTable/MapTable.hs | 108 +- src/Rel8/Schema/HTable/Maybe.hs | 32 +- src/Rel8/Schema/HTable/NonEmpty.hs | 14 +- src/Rel8/Schema/HTable/Nullify.hs | 162 +-- src/Rel8/Schema/HTable/Product.hs | 10 +- src/Rel8/Schema/HTable/These.hs | 32 +- src/Rel8/Schema/HTable/Vectorize.hs | 203 ++-- src/Rel8/Schema/Kind.hs | 14 +- src/Rel8/Schema/Name.hs | 93 +- src/Rel8/Schema/Null.hs | 82 +- src/Rel8/Schema/Result.hs | 48 +- src/Rel8/Schema/Spec.hs | 33 +- src/Rel8/Schema/Table.hs | 59 +- src/Rel8/Statement/Delete.hs | 79 +- src/Rel8/Statement/Insert.hs | 91 +- src/Rel8/Statement/OnConflict.hs | 169 +-- src/Rel8/Statement/Returning.hs | 120 ++- src/Rel8/Statement/SQL.hs | 16 +- src/Rel8/Statement/Select.hs | 101 +- src/Rel8/Statement/Set.hs | 29 +- src/Rel8/Statement/Update.hs | 85 +- src/Rel8/Statement/Using.hs | 18 +- src/Rel8/Statement/View.hs | 86 +- src/Rel8/Statement/Where.hs | 27 +- src/Rel8/Table.hs | 251 +++-- src/Rel8/Table/ADT.hs | 161 +-- src/Rel8/Table/Aggregate.hs | 219 ++-- src/Rel8/Table/Alternative.hs | 40 +- src/Rel8/Table/Bool.hs | 46 +- src/Rel8/Table/Cols.hs | 41 +- src/Rel8/Table/Either.hs | 298 +++--- src/Rel8/Table/Eq.hs | 123 ++- src/Rel8/Table/HKD.hs | 239 +++-- src/Rel8/Table/List.hs | 216 ++-- src/Rel8/Table/Maybe.hs | 299 +++--- src/Rel8/Table/Name.hs | 102 +- src/Rel8/Table/NonEmpty.hs | 226 ++-- src/Rel8/Table/Null.hs | 149 +-- src/Rel8/Table/Nullify.hs | 178 ++-- src/Rel8/Table/Opaleye.hs | 153 +-- src/Rel8/Table/Ord.hs | 141 ++- src/Rel8/Table/Order.hs | 82 +- src/Rel8/Table/Projection.hs | 92 +- src/Rel8/Table/Rel8able.hs | 111 +- src/Rel8/Table/Serialize.hs | 107 +- src/Rel8/Table/These.hs | 468 +++++---- src/Rel8/Table/Transpose.hs | 47 +- src/Rel8/Table/Undefined.hs | 28 +- src/Rel8/Table/Window.hs | 8 +- src/Rel8/Tabulate.hs | 791 +++++++------- src/Rel8/Type.hs | 375 ++++--- src/Rel8/Type/Array.hs | 89 +- src/Rel8/Type/Composite.hs | 141 +-- src/Rel8/Type/Enum.hs | 141 +-- src/Rel8/Type/Eq.hs | 57 +- src/Rel8/Type/Information.hs | 79 +- src/Rel8/Type/JSONBEncoded.hs | 31 +- src/Rel8/Type/JSONEncoded.hs | 23 +- src/Rel8/Type/Monoid.hs | 57 +- src/Rel8/Type/Num.hs | 55 +- src/Rel8/Type/Ord.hs | 64 +- src/Rel8/Type/ReadShow.hs | 31 +- src/Rel8/Type/Semigroup.hs | 57 +- src/Rel8/Type/String.hs | 39 +- src/Rel8/Type/Sum.hs | 34 +- src/Rel8/Type/Tag.hs | 61 +- src/Rel8/Window.hs | 113 +- tests/Main.hs | 585 ++++++----- tests/Rel8/Generic/Rel8able/Test.hs | 130 +-- treefmt.toml | 24 + 149 files changed, 9114 insertions(+), 7256 deletions(-) create mode 100644 fourmolu.yaml create mode 100644 treefmt.toml diff --git a/default.nix b/default.nix index d20577b6..4ec3c7ad 100644 --- a/default.nix +++ b/default.nix @@ -1,5 +1,5 @@ let - haskellNix = import (import ./nix/sources.nix)."haskell.nix" {}; + haskellNix = import (import ./nix/sources.nix)."haskell.nix" { }; nixpkgsSrc = haskellNix.sources.nixpkgs-unstable; @@ -21,7 +21,8 @@ pkgs.haskell-nix.project { }; modules = [ - { packages.rel8 = { + { + packages.rel8 = { preCheck = '' export PATH="${pkgs.postgresql}/bin:${"$PATH"}" ''; diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 00000000..aeb9f5e8 --- /dev/null +++ b/fourmolu.yaml @@ -0,0 +1,10 @@ +indentation: 2 +comma-style: leading +import-export-style: diff-friendly +indent-wheres: true +record-brace-space: false +respectful: true +haddock-style: multi-line +newlines-between-decls: 2 +fixities: [] +single-constraint-parens: auto diff --git a/nix/sources.json b/nix/sources.json index 48ef1d16..84e6e76f 100644 --- a/nix/sources.json +++ b/nix/sources.json @@ -1,4 +1,16 @@ { + "ch-hs-imports": { + "branch": "master", + "description": null, + "homepage": null, + "owner": "circuithub", + "repo": "ch-hs-imports", + "rev": "e3dc32bb2e945334261b6d72dc5c3df490cebc2b", + "sha256": "08z7hishpp1j7nxwhap4c0ggwhpm15i5swy91r96jh70ql20j3yi", + "type": "tarball", + "url": "https://github.com/circuithub/ch-hs-imports/archive/e3dc32bb2e945334261b6d72dc5c3df490cebc2b.tar.gz", + "url_template": "https://github.com///archive/.tar.gz" + }, "haskell.nix": { "branch": "master", "description": "Alternative Haskell Infrastructure for Nixpkgs", diff --git a/nix/sources.nix b/nix/sources.nix index 9a01c8ac..23ab29b0 100644 --- a/nix/sources.nix +++ b/nix/sources.nix @@ -10,27 +10,27 @@ let let name' = sanitizeName name + "-src"; in - if spec.builtin or true then - builtins_fetchurl { inherit (spec) url sha256; name = name'; } - else - pkgs.fetchurl { inherit (spec) url sha256; name = name'; }; + if spec.builtin or true then + builtins_fetchurl { inherit (spec) url sha256; name = name'; } + else + pkgs.fetchurl { inherit (spec) url sha256; name = name'; }; fetch_tarball = pkgs: name: spec: let name' = sanitizeName 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; }; + 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 = name: spec: let ref = if spec ? ref then spec.ref else - if spec ? branch then "refs/heads/${spec.branch}" else - if spec ? tag then "refs/tags/${spec.tag}" else - abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!"; + if spec ? branch then "refs/heads/${spec.branch}" else + if spec ? tag then "refs/tags/${spec.tag}" else + abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!"; submodules = if spec ? submodules then spec.submodules else false; submoduleArg = let @@ -44,15 +44,15 @@ let + "but your nix's (${builtins.nixVersion}) builtins.fetchGit " + "does not support them" ) - {} - else {}; + { } + else { }; in - if nixSupportsSubmodules - then { inherit submodules; } - else emptyArgWithWarning; + if nixSupportsSubmodules + then { inherit submodules; } + else emptyArgWithWarning; in - builtins.fetchGit - ({ url = spec.repo; inherit (spec) rev; inherit ref; } // submoduleArg); + builtins.fetchGit + ({ url = spec.repo; inherit (spec) rev; inherit ref; } // submoduleArg); fetch_local = spec: spec.path; @@ -86,16 +86,16 @@ let hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath; hasThisAsNixpkgsPath = == ./.; in - if builtins.hasAttr "nixpkgs" sources - then sourcesNixpkgs - else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then - import {} - else - abort - '' - Please specify either (through -I or NIX_PATH=nixpkgs=...) or - add a package called "nixpkgs" to your sources.json. - ''; + if builtins.hasAttr "nixpkgs" sources + then sourcesNixpkgs + else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then + import { } + else + abort + '' + Please specify either (through -I or NIX_PATH=nixpkgs=...) or + add a package called "nixpkgs" to your sources.json. + ''; # The actual fetching function. fetch = pkgs: name: spec: @@ -118,10 +118,10 @@ 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 - # this turns the string into an actual Nix path (for both absolute and - # relative paths) - if builtins.substring 0 1 ersatz == "/" then /. + ersatz else /. + builtins.getEnv "PWD" + "/${ersatz}"; + if ersatz == "" then drv else + # this turns the string into an actual Nix path (for both absolute and + # relative paths) + if builtins.substring 0 1 ersatz == "/" then /. + ersatz else /. + builtins.getEnv "PWD" + "/${ersatz}"; # Ports of functions for older nix versions @@ -132,7 +132,7 @@ let ); # 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); + 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)); @@ -143,43 +143,46 @@ let concatStrings = builtins.concatStringsSep ""; # https://github.com/NixOS/nixpkgs/blob/8a9f58a375c401b96da862d969f66429def1d118/lib/attrsets.nix#L331 - optionalAttrs = cond: as: if cond then as else {}; + optionalAttrs = cond: as: if cond then as else { }; # fetchTarball version that is compatible between all the versions of Nix builtins_fetchTarball = { url, name ? null, sha256 }@attrs: let inherit (builtins) lessThan nixVersion fetchTarball; in - if lessThan nixVersion "1.12" then - fetchTarball ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; })) - else - fetchTarball attrs; + if lessThan nixVersion "1.12" then + fetchTarball ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; })) + else + fetchTarball attrs; # fetchurl version that is compatible between all the versions of Nix builtins_fetchurl = { url, name ? null, sha256 }@attrs: let inherit (builtins) lessThan nixVersion fetchurl; in - if lessThan nixVersion "1.12" then - fetchurl ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; })) - else - fetchurl attrs; + if lessThan nixVersion "1.12" then + fetchurl ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; })) + 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; + 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) + , sources ? if isNull sourcesFile then { } else builtins.fromJSON (builtins.readFile sourcesFile) , system ? builtins.currentSystem , pkgs ? mkPkgs sources system }: rec { @@ -191,4 +194,4 @@ let }; in -mkSources (mkConfig {}) // { __functor = _: settings: mkSources (mkConfig settings); } +mkSources (mkConfig { }) // { __functor = _: settings: mkSources (mkConfig settings); } diff --git a/rel8.cabal b/rel8.cabal index 2e92c086..2c26e286 100644 --- a/rel8.cabal +++ b/rel8.cabal @@ -1,37 +1,38 @@ -cabal-version: 2.0 -name: rel8 -version: 1.4.1.0 -synopsis: Hey! Hey! Can u rel8? -license: BSD3 -license-file: LICENSE -author: Oliver Charles -maintainer: ollie@ocharles.org.uk -homepage: https://github.com/circuithub/rel8 -bug-reports: https://github.com/circuithub/rel8/issues -build-type: Simple +cabal-version: 2.0 +name: rel8 +version: 1.4.1.0 +synopsis: Hey! Hey! Can u rel8? +license: BSD3 +license-file: LICENSE +author: Oliver Charles +maintainer: ollie@ocharles.org.uk +homepage: https://github.com/circuithub/rel8 +bug-reports: https://github.com/circuithub/rel8/issues +build-type: Simple extra-doc-files: - README.md - Changelog.md + Changelog.md + README.md source-repository head - type: git - location: https://github.com/circuithub/rel8 + type: git + location: https://github.com/circuithub/rel8 library build-depends: aeson - , base ^>= 4.14 || ^>=4.15 || ^>=4.16 || ^>=4.17 + , base >=4.14 && <4.17 || ^>=4.17 + , base-compat , bifunctors , bytestring , case-insensitive , comonad , contravariant - , hasql ^>= 1.6.1.2 + , hasql ^>=1.6.1.2 , network-ip - , opaleye ^>= 0.9.6.1 + , opaleye ^>=0.9.6.1 , pretty - , profunctors , product-profunctors + , profunctors , scientific , semialign , semigroupoids @@ -39,17 +40,16 @@ library , these , time , uuid - default-language: - Haskell2010 + + default-language: Haskell2010 ghc-options: - -Werror=missing-methods -Werror=incomplete-patterns -Werror=missing-fields - -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 - -Wno-missing-kind-signatures - hs-source-dirs: - src + -Werror=missing-methods -Werror=incomplete-patterns + -Werror=missing-fields -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 -Wno-missing-kind-signatures + + hs-source-dirs: src exposed-modules: Rel8 Rel8.Expr.Num @@ -60,7 +60,6 @@ library other-modules: Rel8.Aggregate Rel8.Aggregate.Fold - Rel8.Column Rel8.Column.ADT Rel8.Column.Either @@ -70,7 +69,6 @@ library Rel8.Column.NonEmpty Rel8.Column.Null Rel8.Column.These - Rel8.Expr Rel8.Expr.Aggregate Rel8.Expr.Array @@ -87,12 +85,7 @@ library Rel8.Expr.Sequence Rel8.Expr.Serialize Rel8.Expr.Window - Rel8.FCF - - Rel8.Kind.Algebra - Rel8.Kind.Context - Rel8.Generic.Construction Rel8.Generic.Construction.ADT Rel8.Generic.Construction.Record @@ -102,9 +95,9 @@ library Rel8.Generic.Table Rel8.Generic.Table.ADT Rel8.Generic.Table.Record - + Rel8.Kind.Algebra + Rel8.Kind.Context Rel8.Order - Rel8.Query Rel8.Query.Aggregate Rel8.Query.Distinct @@ -128,7 +121,6 @@ library Rel8.Query.These Rel8.Query.Values Rel8.Query.Window - Rel8.Schema.Context.Nullify Rel8.Schema.Dict Rel8.Schema.Field @@ -150,7 +142,6 @@ library Rel8.Schema.Result Rel8.Schema.Spec Rel8.Schema.Table - Rel8.Statement.Delete Rel8.Statement.Insert Rel8.Statement.OnConflict @@ -162,7 +153,6 @@ library Rel8.Statement.Using Rel8.Statement.View Rel8.Statement.Where - Rel8.Table Rel8.Table.ADT Rel8.Table.Aggregate @@ -188,15 +178,14 @@ library Rel8.Table.Transpose Rel8.Table.Undefined Rel8.Table.Window - Rel8.Type Rel8.Type.Array Rel8.Type.Composite - Rel8.Type.Eq Rel8.Type.Enum + Rel8.Type.Eq Rel8.Type.Information - Rel8.Type.JSONEncoded Rel8.Type.JSONBEncoded + Rel8.Type.JSONEncoded Rel8.Type.Monoid Rel8.Type.Num Rel8.Type.Ord @@ -205,10 +194,8 @@ library Rel8.Type.String Rel8.Type.Sum Rel8.Type.Tag - Rel8.Window - test-suite tests type: exitcode-stdio-1.0 build-depends: @@ -219,7 +206,7 @@ test-suite tests , data-dword , hasql , hasql-transaction - , hedgehog ^>= 1.0 || ^>= 1.1 + , hedgehog >=1.0 && <1.1 || ^>=1.1 , mmorph , network-ip , rel8 @@ -228,13 +215,11 @@ test-suite tests , tasty-hedgehog , text , time - , tmp-postgres ^>=1.34.1.0 + , tmp-postgres ^>=1.34.1.0 , transformers , uuid - other-modules: - Rel8.Generic.Rel8able.Test - + other-modules: Rel8.Generic.Rel8able.Test main-is: Main.hs hs-source-dirs: tests default-language: Haskell2010 diff --git a/shell.nix b/shell.nix index 8cfc342c..0cd169b7 100644 --- a/shell.nix +++ b/shell.nix @@ -1,11 +1,29 @@ let sources = import ./nix/sources.nix; - pkgs = import sources.nixpkgs {overlays = [];}; + hsPkgs = import ./default.nix; + + haskellNix = import sources."haskell.nix" { }; + nixpkgsSrc = haskellNix.sources.nixpkgs-unstable; + nixpkgsArgs = haskellNix.nixpkgsArgs; + compiler-nix-name = "ghc943"; + + haskell-nix = (import nixpkgsSrc nixpkgsArgs).haskell-nix; + + ch-hs-imports = + let + project = haskell-nix.project { + src = sources.ch-hs-imports; + inherit compiler-nix-name; + }; + in + project.hsPkgs.ch-hs-imports.components.exes.ch-hs-imports; + + pkgs = import sources.nixpkgs { overlays = [ ]; }; in - hsPkgs.shellFor { - withHoogle = false; - tools = { cabal = "latest"; }; - exactDeps = false; - buildInputs = [ pkgs.postgresql pkgs.pythonPackages.sphinx ]; - } +hsPkgs.shellFor { + withHoogle = false; + tools = { cabal = "latest"; }; + exactDeps = false; + buildInputs = [ pkgs.postgresql pkgs.pythonPackages.sphinx ]; +} diff --git a/src/Rel8.hs b/src/Rel8.hs index 64b3c79c..40084b6b 100644 --- a/src/Rel8.hs +++ b/src/Rel8.hs @@ -1,364 +1,459 @@ -{-# language DuplicateRecordFields #-} - -module Rel8 - ( -- * Database types - -- ** @DBType@ - DBType(..) - - -- *** Deriving-via helpers - -- **** @JSONEncoded@ - , JSONEncoded(..) - , JSONBEncoded(..) - - -- **** @ReadShow@ - , ReadShow(..) - - -- **** Generic - , Composite(..), DBComposite(..), compose, decompose - , Enum(..), DBEnum(..), Enumable - - -- *** @TypeInformation@ - , TypeInformation(..) - , mapTypeInformation - , parseTypeInformation - - -- ** The @DBType@ hierarchy - , DBSemigroup(..) - , DBMonoid(..) - , DBNum - , DBIntegral - , DBFractional - , DBFloating - - -- * Tables and higher-kinded tables - , Rel8able, KRel8able - , Column - , HADT - , HEither - , HMaybe - , HList - , HNonEmpty - , HNull - , HThese - , Lift - - , Table(..) - , HTable - , Transposes - , AltTable((<|>:)) - , AlternativeTable( emptyTable ) - , EqTable(..), (==:), (/=:) - , OrdTable(..), (<:), (<=:), (>:), (>=:), ascTable, descTable, greatest, least - , lit - , bool - , case_ - , castTable - - -- ** @MaybeTable@ - , MaybeTable - , maybeTable, ($?), nothingTable, justTable - , isNothingTable, isJustTable - , fromMaybeTable - , optional - , catMaybeTable - , traverseMaybeTable - , aggregateMaybeTable - , nameMaybeTable - - -- ** @EitherTable@ - , EitherTable - , eitherTable, leftTable, rightTable - , isLeftTable, isRightTable - , keepLeftTable - , keepRightTable - , bitraverseEitherTable - , aggregateEitherTable - , nameEitherTable - - -- ** @TheseTable@ - , TheseTable - , theseTable, thisTable, thatTable, thoseTable - , isThisTable, isThatTable, isThoseTable - , hasHereTable, hasThereTable - , justHereTable, justThereTable - , alignMaybeTable - , alignBy - , keepHereTable, loseHereTable - , keepThereTable, loseThereTable - , keepThisTable, loseThisTable - , keepThatTable, loseThatTable - , keepThoseTable, loseThoseTable - , bitraverseTheseTable - , aggregateTheseTable - , nameTheseTable - - -- ** @ListTable@ - , ListTable - , listTable, ($*) - , nameListTable - , many - , manyExpr - , catListTable - , catList - , head - , headExpr - , last - , lastExpr - - -- ** @NonEmptyTable@ - , NonEmptyTable - , nonEmptyTable, ($+) - , nameNonEmptyTable - , some - , someExpr - , catNonEmptyTable - , catNonEmpty - , head1 - , head1Expr - , last1 - , last1Expr - - -- ** @NullTable@ - , NullTable - , nullableTable, nullTable, nullifyTable - , isNullTable, isNonNullTable - , catNullTable - , nameNullTable - , toNullTable, toMaybeTable - - -- ** Algebraic data types / sum types - -- $adts - - -- *** Naming of ADTs - -- $naming - , NameADT, nameADT - , ADT, ADTable - - -- *** Deconstruction of ADTs - -- $deconstruction - , DeconstructADT, deconstructADT - - -- *** Construction of ADTs - -- $construction - , BuildADT, buildADT - , ConstructADT, constructADT - - -- *** Miscellaneous notes - -- $misc-notes - - -- ** @HKD@ - , HKD, HKDable - , BuildHKD, buildHKD - , ConstructHKD, constructHKD - , DeconstructHKD, deconstructHKD - , NameHKD, nameHKD - - -- ** Table schemas - , TableSchema(..) - , Name - , namesFromLabels - , namesFromLabelsWith - - -- * Expressions - , Expr - , Sql - , litExpr - , unsafeCastExpr - , unsafeLiteral - - -- ** @null@ - , NotNull - , Nullable - , Homonullable - , null - , nullify - , nullable - , isNull - , isNonNull - , mapNull - , liftOpNull - , catNull - , coalesce - - -- ** Boolean operations - , DBEq - , true, false, not_ - , (&&.), and_ - , (||.), or_ - , (==.), (/=.), (==?), (/=?) - , in_ - , boolExpr, caseExpr - , like, ilike - - -- ** Ordering - , DBOrd - , (<.), (<=.), (>.), (>=.) - , (?), (>=?) - , leastExpr, greatestExpr - - -- ** Functions - , Function - , function - , nullaryFunction - , binaryOperator - - -- * Queries - , Query - , showQuery - - -- ** Projection - , Projection - , Projectable( project ) - , Biprojectable( biproject ) - , Projecting - , Field - - -- ** Selecting rows - , Selects - , each - , values - - -- ** Filtering - , filter - , where_ - , present - , absent - , distinct - , distinctOn - , distinctOnBy - - -- ** @LIMIT@/@OFFSET@ - , limit - , offset - - -- ** @UNION@ - , union - , unionAll - - -- ** @INTERSECT@ - , intersect - , intersectAll - - -- ** @EXCEPT@ - , except - , exceptAll - - -- ** @EXISTS@ - , exists - , with - , withBy - , without - , withoutBy - - -- ** @WITH@ - , materialize - - -- ** @WITH RECURSIVE@ - , loop - - -- ** Aggregation - , Aggregator - , Aggregator1 - , Aggregator' - , Fold (Semi, Full) - , toAggregator - , toAggregator1 - , aggregate - , aggregate1 - , filterWhere - , filterWhereOptional - , distinctAggregate - , orderAggregateBy - , optionalAggregate - , countRows - , groupBy, groupByOn - , listAgg, listAggOn, listAggExpr, listAggExprOn - , mode - , nonEmptyAgg, nonEmptyAggOn, nonEmptyAggExpr, nonEmptyAggExprOn - , DBMax, max, maxOn - , DBMin, min, minOn - , DBSum, sum, sumOn, sumWhere, avg, avgOn - , DBString, stringAgg - , count, countOn - , countStar - , countDistinct, countDistinctOn - , countWhere, countWhereOn - , and, andOn - , or, orOn - - -- ** Ordering - , orderBy - , Order - , asc - , desc - , nullsFirst - , nullsLast - - -- ** Window functions - , Window - , window - , Partition - , over - , partitionBy - , orderPartitionBy - , cumulative - , currentRow - , rowNumber - , rank - , denseRank - , percentRank - , cumeDist - , ntile - , lag, lagOn - , lead, leadOn - , firstValue, firstValueOn - , lastValue, lastValueOn - , nthValue, nthValueOn - , indexed - - -- ** Bindings - , rebind - - -- * IO - , Serializable - , ToExprs - , Result - - -- * Running statements - -- $running - - -- ** @SELECT@ - , select - - -- ** @INSERT@ - , Insert(..) - , OnConflict(..) - , Upsert(..) - , insert - , unsafeDefault - , showInsert - - -- ** @DELETE@ - , Delete(..) - , delete - , showDelete - - -- ** @UPDATE@ - , Update(..) - , update - , showUpdate - - -- ** @.. RETURNING@ - , Returning(..) - - -- ** @CREATE VIEW@ - , createView - , createOrReplaceView - - -- ** Sequences - , nextval - , evaluate - ) where +{-# LANGUAGE DuplicateRecordFields #-} + +module Rel8 ( + -- * Database types + + -- ** @DBType@ + DBType (..), + + -- *** Deriving-via helpers + + -- **** @JSONEncoded@ + JSONEncoded (..), + JSONBEncoded (..), + + -- **** @ReadShow@ + ReadShow (..), + + -- **** Generic + Composite (..), + DBComposite (..), + compose, + decompose, + Enum (..), + DBEnum (..), + Enumable, + + -- *** @TypeInformation@ + TypeInformation (..), + mapTypeInformation, + parseTypeInformation, + + -- ** The @DBType@ hierarchy + DBSemigroup (..), + DBMonoid (..), + DBNum, + DBIntegral, + DBFractional, + DBFloating, + + -- * Tables and higher-kinded tables + Rel8able, + KRel8able, + Column, + HADT, + HEither, + HMaybe, + HList, + HNonEmpty, + HNull, + HThese, + Lift, + Table (..), + HTable, + Transposes, + AltTable ((<|>:)), + AlternativeTable (emptyTable), + EqTable (..), + (==:), + (/=:), + OrdTable (..), + (<:), + (<=:), + (>:), + (>=:), + ascTable, + descTable, + greatest, + least, + lit, + bool, + case_, + castTable, + + -- ** @MaybeTable@ + MaybeTable, + maybeTable, + ($?), + nothingTable, + justTable, + isNothingTable, + isJustTable, + fromMaybeTable, + optional, + catMaybeTable, + traverseMaybeTable, + aggregateMaybeTable, + nameMaybeTable, + + -- ** @EitherTable@ + EitherTable, + eitherTable, + leftTable, + rightTable, + isLeftTable, + isRightTable, + keepLeftTable, + keepRightTable, + bitraverseEitherTable, + aggregateEitherTable, + nameEitherTable, + + -- ** @TheseTable@ + TheseTable, + theseTable, + thisTable, + thatTable, + thoseTable, + isThisTable, + isThatTable, + isThoseTable, + hasHereTable, + hasThereTable, + justHereTable, + justThereTable, + alignMaybeTable, + alignBy, + keepHereTable, + loseHereTable, + keepThereTable, + loseThereTable, + keepThisTable, + loseThisTable, + keepThatTable, + loseThatTable, + keepThoseTable, + loseThoseTable, + bitraverseTheseTable, + aggregateTheseTable, + nameTheseTable, + + -- ** @ListTable@ + ListTable, + listTable, + ($*), + nameListTable, + many, + manyExpr, + catListTable, + catList, + head, + headExpr, + last, + lastExpr, + + -- ** @NonEmptyTable@ + NonEmptyTable, + nonEmptyTable, + ($+), + nameNonEmptyTable, + some, + someExpr, + catNonEmptyTable, + catNonEmpty, + head1, + head1Expr, + last1, + last1Expr, + + -- ** @NullTable@ + NullTable, + nullableTable, + nullTable, + nullifyTable, + isNullTable, + isNonNullTable, + catNullTable, + nameNullTable, + toNullTable, + toMaybeTable, + + -- ** Algebraic data types / sum types + -- $adts + + -- *** Naming of ADTs + -- $naming + NameADT, + nameADT, + ADT, + ADTable, + + -- *** Deconstruction of ADTs + -- $deconstruction + DeconstructADT, + deconstructADT, + + -- *** Construction of ADTs + -- $construction + BuildADT, + buildADT, + ConstructADT, + constructADT, + + -- *** Miscellaneous notes + -- $misc-notes + + -- ** @HKD@ + HKD, + HKDable, + BuildHKD, + buildHKD, + ConstructHKD, + constructHKD, + DeconstructHKD, + deconstructHKD, + NameHKD, + nameHKD, + + -- ** Table schemas + TableSchema (..), + Name, + namesFromLabels, + namesFromLabelsWith, + + -- * Expressions + Expr, + Sql, + litExpr, + unsafeCastExpr, + unsafeLiteral, + + -- ** @null@ + NotNull, + Nullable, + Homonullable, + null, + nullify, + nullable, + isNull, + isNonNull, + mapNull, + liftOpNull, + catNull, + coalesce, + + -- ** Boolean operations + DBEq, + true, + false, + not_, + (&&.), + and_, + (||.), + or_, + (==.), + (/=.), + (==?), + (/=?), + in_, + boolExpr, + caseExpr, + like, + ilike, + + -- ** Ordering + DBOrd, + (<.), + (<=.), + (>.), + (>=.), + (?), + (>=?), + leastExpr, + greatestExpr, + + -- ** Functions + Function, + function, + nullaryFunction, + binaryOperator, + + -- * Queries + Query, + showQuery, + + -- ** Projection + Projection, + Projectable (project), + Biprojectable (biproject), + Projecting, + Field, + + -- ** Selecting rows + Selects, + each, + values, + + -- ** Filtering + filter, + where_, + present, + absent, + distinct, + distinctOn, + distinctOnBy, + + -- ** @LIMIT@/@OFFSET@ + limit, + offset, + + -- ** @UNION@ + union, + unionAll, + + -- ** @INTERSECT@ + intersect, + intersectAll, + + -- ** @EXCEPT@ + except, + exceptAll, + + -- ** @EXISTS@ + exists, + with, + withBy, + without, + withoutBy, + + -- ** @WITH@ + materialize, + + -- ** @WITH RECURSIVE@ + loop, + + -- ** Aggregation + Aggregator, + Aggregator1, + Aggregator', + Fold (Semi, Full), + toAggregator, + toAggregator1, + aggregate, + aggregate1, + filterWhere, + filterWhereOptional, + distinctAggregate, + orderAggregateBy, + optionalAggregate, + countRows, + groupBy, + groupByOn, + listAgg, + listAggOn, + listAggExpr, + listAggExprOn, + mode, + nonEmptyAgg, + nonEmptyAggOn, + nonEmptyAggExpr, + nonEmptyAggExprOn, + DBMax, + max, + maxOn, + DBMin, + min, + minOn, + DBSum, + sum, + sumOn, + sumWhere, + avg, + avgOn, + DBString, + stringAgg, + count, + countOn, + countStar, + countDistinct, + countDistinctOn, + countWhere, + countWhereOn, + and, + andOn, + or, + orOn, + + -- ** Ordering + orderBy, + Order, + asc, + desc, + nullsFirst, + nullsLast, + + -- ** Window functions + Window, + window, + Partition, + over, + partitionBy, + orderPartitionBy, + cumulative, + currentRow, + rowNumber, + rank, + denseRank, + percentRank, + cumeDist, + ntile, + lag, + lagOn, + lead, + leadOn, + firstValue, + firstValueOn, + lastValue, + lastValueOn, + nthValue, + nthValueOn, + indexed, + + -- ** Bindings + rebind, + + -- * IO + Serializable, + ToExprs, + Result, + + -- * Running statements + -- $running + + -- ** @SELECT@ + select, + + -- ** @INSERT@ + Insert (..), + OnConflict (..), + Upsert (..), + insert, + unsafeDefault, + showInsert, + + -- ** @DELETE@ + Delete (..), + delete, + showDelete, + + -- ** @UPDATE@ + Update (..), + update, + showUpdate, + + -- ** @.. RETURNING@ + Returning (..), + + -- ** @CREATE VIEW@ + createView, + createOrReplaceView, + + -- ** Sequences + nextval, + evaluate, +) where -- base import Prelude () @@ -387,11 +482,11 @@ import Rel8.Expr.Null import Rel8.Expr.Opaleye (unsafeCastExpr, unsafeLiteral) import Rel8.Expr.Ord import Rel8.Expr.Order -import Rel8.Expr.Serialize import Rel8.Expr.Sequence -import Rel8.Expr.Text ( like, ilike ) +import Rel8.Expr.Serialize +import Rel8.Expr.Text (ilike, like) import Rel8.Expr.Window -import Rel8.Generic.Rel8able ( KRel8able, Rel8able ) +import Rel8.Generic.Rel8able (KRel8able, Rel8able) import Rel8.Order import Rel8.Query import Rel8.Query.Aggregate @@ -418,15 +513,15 @@ import Rel8.Query.Window import Rel8.Schema.Field import Rel8.Schema.HTable import Rel8.Schema.Name -import Rel8.Schema.Null hiding ( nullable ) -import Rel8.Schema.Result ( Result ) +import Rel8.Schema.Null hiding (nullable) +import Rel8.Schema.Result (Result) import Rel8.Schema.Table import Rel8.Statement.Delete import Rel8.Statement.Insert import Rel8.Statement.OnConflict import Rel8.Statement.Returning -import Rel8.Statement.Select import Rel8.Statement.SQL +import Rel8.Statement.Select import Rel8.Statement.Update import Rel8.Statement.View import Rel8.Table @@ -442,7 +537,7 @@ import Rel8.Table.Maybe import Rel8.Table.Name import Rel8.Table.NonEmpty import Rel8.Table.Null -import Rel8.Table.Opaleye ( castTable ) +import Rel8.Table.Opaleye (castTable) import Rel8.Table.Ord import Rel8.Table.Order import Rel8.Table.Projection @@ -453,8 +548,8 @@ import Rel8.Table.Transpose import Rel8.Table.Window import Rel8.Type import Rel8.Type.Composite -import Rel8.Type.Eq import Rel8.Type.Enum +import Rel8.Type.Eq import Rel8.Type.Information import Rel8.Type.JSONBEncoded import Rel8.Type.JSONEncoded @@ -468,213 +563,223 @@ import Rel8.Type.Sum import Rel8.Window --- $running --- To run queries and otherwise interact with a PostgreSQL database, Rel8 --- provides 'select', 'insert', 'update' and 'delete' functions. Note that --- 'insert', 'update' and 'delete' will generally need the --- `DuplicateRecordFields` language extension enabled. - --- $adts --- Algebraic data types can be modelled between Haskell and SQL. --- --- * Your SQL table needs a certain text field that tags which Haskell constructor is in use. --- * You have to use a few combinators to specify the sum type's individual constructors. --- * If you want to do case analysis at the @Expr@ (SQL) level, you can use 'maybe'/'either'-like eliminators. --- --- The documentation in this section will assume a set of database types like this: --- --- @ --- data Thing f = ThingEmployer (Employer f) | ThingPotato (Potato f) | Nullary --- deriving stock Generic --- --- data Employer f = Employer { employerId :: f Int32, employerName :: f Text} --- deriving stock Generic --- deriving anyclass Rel8able --- --- data Potato f = Potato { size :: f Int32, grower :: f Text } --- deriving stock Generic --- deriving anyclass Rel8able --- @ - --- $naming --- --- First, in your 'TableSchema', name your type like this: --- --- @ --- thingSchema :: TableSchema (ADT Thing Name) --- thingSchema = --- TableSchema --- { schema = Nothing, --- name = \"thing\", --- columns = --- nameADT @Thing --- \"tag\" --- Employer --- { employerName = \"name\", --- employerId = \"id\" --- } --- Potato {size = \"size\", grower = \"Mary\"} --- } --- @ --- --- Note that @nameADT \@Thing "tag"@ is variadic: it accepts one --- argument per constructor, except the nullary ones (Nullary) because --- there's nothing to do for them. - --- $deconstruction --- --- To deconstruct sum types at the SQL level, use 'deconstructADT', --- which is also variadic, and has one argument for each --- constructor. Similar to 'maybe'. --- --- @ --- query :: Query (ADT Thing Expr) --- query = do --- thingExpr <- each thingSchema --- where_ $ --- deconstructADT @Thing --- (\employer -> employerName employer ==. lit \"Mary\") --- (\potato -> grower potato ==. lit \"Mary\") --- (lit False) -- Nullary case --- thingExpr --- pure thingExpr --- @ --- --- SQL output: --- --- @ --- SELECT --- CAST("tag0_1" AS text) as "tag", --- CAST("id1_1" AS int4) as "ThingEmployer/_1/employerId", --- CAST("name2_1" AS text) as "ThingEmployer/_1/employerName", --- CAST("size3_1" AS int4) as "ThingPotato/_1/size", --- CAST("Mary4_1" AS text) as "ThingPotato/_1/grower" --- FROM (SELECT --- * --- FROM (SELECT --- "tag" as "tag0_1", --- "id" as "id1_1", --- "name" as "name2_1", --- "size" as "size3_1", --- "Mary" as "Mary4_1" --- FROM "thing" as "T1") as "T1" --- WHERE (CASE WHEN ("tag0_1") = (CAST(E'ThingPotato' AS text)) THEN ("Mary4_1") = (CAST(E'Mary' AS text)) --- WHEN ("tag0_1") = (CAST(E'Nullary' AS text)) THEN CAST(FALSE AS bool) ELSE ("name2_1") = (CAST(E'Mary' AS text)) END)) as "T1" --- @ - --- $construction --- --- To construct an ADT, you can use 'buildADT' or 'constructADT'. Consider the following type: --- --- @ --- data Task f = Pending | Complete (CompletedTask f) --- @ --- --- 'buildADT' is for constructing values of 'Task' in the 'Expr' --- context. 'buildADT' needs two type-level arguments before its type --- makes any sense. The first argument is the type of the "ADT", which --- in our case is 'Task'. The second is the name of the constructor we --- want to use. So that means we have the following possible --- instantiations of 'buildADT' for 'Task': --- --- @ --- > :t buildADT @Task @\"Pending\" --- buildADT @Task @\"Pending\" :: ADT Task Expr --- > :t buildADT @Task @\"Complete\" --- buildADT @Task @\"Complete\" :: CompletedTask Expr -> ADT Task Expr --- @ --- --- Note that as the "Pending" constructor has no fields, @buildADT --- \@Task \@"Pending"@ is equivalent to @lit Pending@. But @buildADT --- \@Task \@"Complete"@ is not the same as @lit . Complete@: --- --- @ --- > :t lit . Complete --- lit . Complete :: CompletedTask Result -> ADT Task Expr --- @ --- --- --- Note that the former takes a @CompletedTask Expr@ while the latter --- takes a @CompletedTask Result@. The former is more powerful because --- you can construct @Task@s using dynamic values coming a database --- query. --- --- To show what this can look like in SQL, consider: --- --- @ --- > :{ --- showQuery $ values --- [ buildADT @Task @\"Pending\" --- , buildADT @Task @\"Complete\" CompletedTask {date = Rel8.Expr.Time.now} --- ] --- :} --- @ --- --- This produces the following SQL: --- --- @ --- SELECT --- CAST(\"values0_1\" AS text) as \"tag\", --- CAST(\"values1_1\" AS timestamptz) as \"Complete/_1/date\" --- FROM (SELECT --- * --- FROM (SELECT \"column1\" as \"values0_1\", --- \"column2\" as \"values1_1\" --- FROM --- (VALUES --- (CAST(E'Pending' AS text),CAST(NULL AS timestamptz)), --- (CAST(E'Complete' AS text),CAST(now() AS timestamptz))) as \"V\") as \"T1\") as \"T1\" --- @ --- --- This is what you get if you run it in @psql@: --- --- --- @ --- tag | Complete/_1/date --- ----------+------------------------------- --- Pending | --- Complete | 2022-05-19 21:28:23.969065+00 --- (2 rows) --- @ --- --- "constructADT" is less convenient but more general alternative to --- "buildADT". It requires only one type-level argument for its type --- to make sense: --- --- @ --- > :t constructADT @Task --- constructADT @Task --- :: (forall r. r -> (CompletedTask Expr -> r) -> r) -> ADT Task Expr --- @ --- --- This might still seem a bit opaque, but basically it gives you a --- Church-encoded constructor for arbitrary algebraic data types. You --- might use it as follows: --- --- @ --- let --- pending :: ADT Task Expr --- pending = constructADT @Task $ \pending _complete -> pending --- --- complete :: ADT Task Expr --- complete = constructADT @Task $ \_pending complete -> complete CompletedTask {date = Rel8.Expr.Time.now} --- @ --- --- These values are otherwise identical to the ones we saw above with --- @buildADT@, it's just a different style of constructing them. --- - --- $misc-notes --- --- 1. Note that the order of the arguments for all of these functions --- is determined by the order of the constructors in the data --- definition. If it were @data Task = Complete (CompletedTask f) | --- Pending@ then the order of all the invocations of @constructADT@ --- and @deconstructADT@ would need to change. --- --- 2. Maybe this is obvious, but just to spell it out: once you're in --- the @Result@ context, you can of course construct @Task@ values --- normally and use standard Haskell pattern-matching. @constructADT@ --- and @deconstructADT@ are specifically only needed in the @Expr@ --- context, and they allow you to do the equivalent of pattern --- matching in PostgreSQL. +{- $running +To run queries and otherwise interact with a PostgreSQL database, Rel8 +provides 'select', 'insert', 'update' and 'delete' functions. Note that +'insert', 'update' and 'delete' will generally need the +`DuplicateRecordFields` language extension enabled. +-} + + +{- $adts +Algebraic data types can be modelled between Haskell and SQL. + +* Your SQL table needs a certain text field that tags which Haskell constructor is in use. +* You have to use a few combinators to specify the sum type's individual constructors. +* If you want to do case analysis at the @Expr@ (SQL) level, you can use 'maybe'/'either'-like eliminators. + +The documentation in this section will assume a set of database types like this: + +@ +data Thing f = ThingEmployer (Employer f) | ThingPotato (Potato f) | Nullary + deriving stock Generic + +data Employer f = Employer { employerId :: f Int32, employerName :: f Text} + deriving stock Generic + deriving anyclass Rel8able + +data Potato f = Potato { size :: f Int32, grower :: f Text } + deriving stock Generic + deriving anyclass Rel8able +@ +-} + + +{- $naming + +First, in your 'TableSchema', name your type like this: + +@ +thingSchema :: TableSchema (ADT Thing Name) +thingSchema = + TableSchema + { schema = Nothing, + name = \"thing\", + columns = + nameADT @Thing + \"tag\" + Employer + { employerName = \"name\", + employerId = \"id\" + } + Potato {size = \"size\", grower = \"Mary\"} + } +@ + +Note that @nameADT \@Thing "tag"@ is variadic: it accepts one +argument per constructor, except the nullary ones (Nullary) because +there's nothing to do for them. +-} + + +{- $deconstruction + +To deconstruct sum types at the SQL level, use 'deconstructADT', +which is also variadic, and has one argument for each +constructor. Similar to 'maybe'. + +@ +query :: Query (ADT Thing Expr) +query = do + thingExpr <- each thingSchema + where_ $ + deconstructADT @Thing + (\employer -> employerName employer ==. lit \"Mary\") + (\potato -> grower potato ==. lit \"Mary\") + (lit False) -- Nullary case + thingExpr + pure thingExpr +@ + +SQL output: + +@ +SELECT +CAST("tag0_1" AS text) as "tag", +CAST("id1_1" AS int4) as "ThingEmployer/_1/employerId", +CAST("name2_1" AS text) as "ThingEmployer/_1/employerName", +CAST("size3_1" AS int4) as "ThingPotato/_1/size", +CAST("Mary4_1" AS text) as "ThingPotato/_1/grower" +FROM (SELECT + * + FROM (SELECT + "tag" as "tag0_1", + "id" as "id1_1", + "name" as "name2_1", + "size" as "size3_1", + "Mary" as "Mary4_1" + FROM "thing" as "T1") as "T1" + WHERE (CASE WHEN ("tag0_1") = (CAST(E'ThingPotato' AS text)) THEN ("Mary4_1") = (CAST(E'Mary' AS text)) + WHEN ("tag0_1") = (CAST(E'Nullary' AS text)) THEN CAST(FALSE AS bool) ELSE ("name2_1") = (CAST(E'Mary' AS text)) END)) as "T1" +@ +-} + + +{- $construction + +To construct an ADT, you can use 'buildADT' or 'constructADT'. Consider the following type: + +@ +data Task f = Pending | Complete (CompletedTask f) +@ + +'buildADT' is for constructing values of 'Task' in the 'Expr' +context. 'buildADT' needs two type-level arguments before its type +makes any sense. The first argument is the type of the "ADT", which +in our case is 'Task'. The second is the name of the constructor we +want to use. So that means we have the following possible +instantiations of 'buildADT' for 'Task': + +@ +> :t buildADT @Task @\"Pending\" +buildADT @Task @\"Pending\" :: ADT Task Expr +> :t buildADT @Task @\"Complete\" +buildADT @Task @\"Complete\" :: CompletedTask Expr -> ADT Task Expr +@ + +Note that as the "Pending" constructor has no fields, @buildADT +\@Task \@"Pending"@ is equivalent to @lit Pending@. But @buildADT +\@Task \@"Complete"@ is not the same as @lit . Complete@: + +@ +> :t lit . Complete +lit . Complete :: CompletedTask Result -> ADT Task Expr +@ + + +Note that the former takes a @CompletedTask Expr@ while the latter +takes a @CompletedTask Result@. The former is more powerful because +you can construct @Task@s using dynamic values coming a database +query. + +To show what this can look like in SQL, consider: + +@ +> :{ +showQuery $ values + [ buildADT @Task @\"Pending\" + , buildADT @Task @\"Complete\" CompletedTask {date = Rel8.Expr.Time.now} + ] +:} +@ + +This produces the following SQL: + +@ +SELECT +CAST(\"values0_1\" AS text) as \"tag\", +CAST(\"values1_1\" AS timestamptz) as \"Complete/_1/date\" +FROM (SELECT + * + FROM (SELECT \"column1\" as \"values0_1\", + \"column2\" as \"values1_1\" + FROM + (VALUES + (CAST(E'Pending' AS text),CAST(NULL AS timestamptz)), + (CAST(E'Complete' AS text),CAST(now() AS timestamptz))) as \"V\") as \"T1\") as \"T1\" +@ + +This is what you get if you run it in @psql@: + + +@ + tag | Complete/_1/date +----------+------------------------------- + Pending | + Complete | 2022-05-19 21:28:23.969065+00 +(2 rows) +@ + +"constructADT" is less convenient but more general alternative to +"buildADT". It requires only one type-level argument for its type +to make sense: + +@ +> :t constructADT @Task +constructADT @Task + :: (forall r. r -> (CompletedTask Expr -> r) -> r) -> ADT Task Expr +@ + +This might still seem a bit opaque, but basically it gives you a +Church-encoded constructor for arbitrary algebraic data types. You +might use it as follows: + +@ +let + pending :: ADT Task Expr + pending = constructADT @Task $ \pending _complete -> pending + + complete :: ADT Task Expr + complete = constructADT @Task $ \_pending complete -> complete CompletedTask {date = Rel8.Expr.Time.now} +@ + +These values are otherwise identical to the ones we saw above with +@buildADT@, it's just a different style of constructing them. +-} + + +{- $misc-notes + +1. Note that the order of the arguments for all of these functions +is determined by the order of the constructors in the data +definition. If it were @data Task = Complete (CompletedTask f) | +Pending@ then the order of all the invocations of @constructADT@ +and @deconstructADT@ would need to change. + +2. Maybe this is obvious, but just to spell it out: once you're in +the @Result@ context, you can of course construct @Task@ values +normally and use standard Haskell pattern-matching. @constructADT@ +and @deconstructADT@ are specifically only needed in the @Expr@ +context, and they allow you to do the equivalent of pattern +matching in PostgreSQL. +-} diff --git a/src/Rel8/Aggregate.hs b/src/Rel8/Aggregate.hs index 546ad84b..7e590a51 100644 --- a/src/Rel8/Aggregate.hs +++ b/src/Rel8/Aggregate.hs @@ -1,18 +1,18 @@ -{-# language DataKinds #-} -{-# language GADTs #-} -{-# language KindSignatures #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} - -module Rel8.Aggregate - ( Aggregator' (Aggregator) - , Aggregator - , Aggregator1 - , toAggregator - , toAggregator1 - , filterWhereExplicit - , unsafeMakeAggregator - ) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} + +module Rel8.Aggregate ( + Aggregator' (Aggregator), + Aggregator, + Aggregator1, + toAggregator, + toAggregator1, + filterWhereExplicit, + unsafeMakeAggregator, +) where -- base @@ -25,84 +25,88 @@ import qualified Opaleye.Aggregate as Opaleye import qualified Opaleye.Internal.MaybeFields as Opaleye import qualified Opaleye.Internal.Operators as Opaleye --- product-profunctor -import Data.Profunctor.Product - ( ProductProfunctor, purePP, (****) - , SumProfunctor, (+++!) - ) +-- product-profunctors +import Data.Profunctor.Product ( + ProductProfunctor, + SumProfunctor, + purePP, + (****), + (+++!), + ) -- profunctors import Data.Profunctor (Profunctor, dimap) -- rel8 -import Rel8.Expr (Expr) -import Rel8.Expr.Opaleye (toPrimExpr, toColumn) import Rel8.Aggregate.Fold (Fallback (Empty, Fallback), Fold (Full, Semi)) +import Rel8.Expr (Expr) +import Rel8.Expr.Opaleye (toColumn, toPrimExpr) -- semigroupoids import Data.Functor.Apply (Apply, liftF2) --- | 'Aggregator'' is the most general form of \"aggregator\", of which --- 'Aggregator' and 'Aggregator1' are special cases. 'Aggregator''s are --- comprised of aggregation functions and/or @GROUP BY@ clauses. --- --- Aggregation functions operating on individual 'Rel8.Expr's such as --- 'Rel8.sum' can be combined into 'Aggregator's operating on larger types --- using the 'Applicative', 'Profunctor' and 'ProductProfunctor' interfaces. --- Working with 'Profunctor's can sometimes be awkward so for every 'Rel8.sum' --- we also provide a 'Rel8.sumOn' which bundles an 'Data.Profunctor.lmap'. For --- complex aggregations, we recommend using these functions along with --- @ApplicativeDo@, @BlockArguments@, @OverloadedRecordDot@ and --- @RecordWildCards@: --- --- @ --- --- data Input f = Input --- { orderId :: Column f OrderId --- , customerId :: Column f CustomerId --- , productId :: Column f ProductId --- , quantity :: Column f Int64 --- , price :: Column f Scientific --- } --- deriving (Generic, Rel8able) --- --- --- totalPrice :: Input Expr -> Expr Scientific --- totalPrice input = fromIntegral input.quantity * input.price --- --- --- data Result f = Result --- { customerId :: Column f CustomerId --- , totalOrders :: Column f Int64 --- , productsOrdered :: Column f Int64 --- , totalPrice :: Column Scientific --- } --- deriving (Generic, Rel8able) --- --- --- allResults :: Query (Result Expr) --- allResults = --- aggregate --- do --- customerId <- groupByOn (.customerId) --- totalOrders <- countDistinctOn (.orderId) --- productsOrdered <- countDistinctOn (.productId) --- totalPrice <- sumOn totalPrice --- pure Result {..} --- do --- order <- each orderSchema --- orderLine <- each orderLineSchema --- where_ $ order.id ==. orderLine.orderId --- pure --- Input --- { orderId = order.id --- , customerId = order.customerId --- , productId = orderLine.productId --- , quantity = orderLine.quantity --- , price = orderLine.price --- } --- @ +{- | 'Aggregator'' is the most general form of \"aggregator\", of which +'Aggregator' and 'Aggregator1' are special cases. 'Aggregator''s are +comprised of aggregation functions and/or @GROUP BY@ clauses. + +Aggregation functions operating on individual 'Rel8.Expr's such as +'Rel8.sum' can be combined into 'Aggregator's operating on larger types +using the 'Applicative', 'Profunctor' and 'ProductProfunctor' interfaces. +Working with 'Profunctor's can sometimes be awkward so for every 'Rel8.sum' +we also provide a 'Rel8.sumOn' which bundles an 'Data.Profunctor.lmap'. For +complex aggregations, we recommend using these functions along with +@ApplicativeDo@, @BlockArguments@, @OverloadedRecordDot@ and +@RecordWildCards@: + +@ + +data Input f = Input + { orderId :: Column f OrderId + , customerId :: Column f CustomerId + , productId :: Column f ProductId + , quantity :: Column f Int64 + , price :: Column f Scientific + } + deriving (Generic, Rel8able) + + +totalPrice :: Input Expr -> Expr Scientific +totalPrice input = fromIntegral input.quantity * input.price + + +data Result f = Result + { customerId :: Column f CustomerId + , totalOrders :: Column f Int64 + , productsOrdered :: Column f Int64 + , totalPrice :: Column Scientific + } + deriving (Generic, Rel8able) + + +allResults :: Query (Result Expr) +allResults = + aggregate + do + customerId <- groupByOn (.customerId) + totalOrders <- countDistinctOn (.orderId) + productsOrdered <- countDistinctOn (.productId) + totalPrice <- sumOn totalPrice + pure Result {..} + do + order <- each orderSchema + orderLine <- each orderLineSchema + where_ $ order.id ==. orderLine.orderId + pure + Input + { orderId = order.id + , customerId = order.customerId + , productId = orderLine.productId + , quantity = orderLine.quantity + , price = orderLine.price + } +@ +-} type Aggregator' :: Fold -> Type -> Type -> Type data Aggregator' fold i a = Aggregator !(Fallback fold a) !(Opaleye.Aggregator i a) @@ -140,25 +144,27 @@ instance Applicative (Aggregator' fold i) where liftA2 = liftF2 --- | An 'Aggregator' takes a 'Rel8.Query' producing a collection of rows of --- type @a@ and transforms it into a 'Rel8.Query' producing a single row of --- type @b@. If the given 'Rel8.Query' produces an empty collection of rows, --- then the single row in the resulting 'Rel8.Query' contains the identity --- values of the aggregation functions comprising the 'Aggregator' (i.e., --- @0@ for 'Rel8.sum', 'Rel8.false' for 'Rel8.or', etc.). --- --- 'Aggregator' is a special form of 'Aggregator'' parameterised by 'Full'. +{- | An 'Aggregator' takes a 'Rel8.Query' producing a collection of rows of +type @a@ and transforms it into a 'Rel8.Query' producing a single row of +type @b@. If the given 'Rel8.Query' produces an empty collection of rows, +then the single row in the resulting 'Rel8.Query' contains the identity +values of the aggregation functions comprising the 'Aggregator' (i.e., +@0@ for 'Rel8.sum', 'Rel8.false' for 'Rel8.or', etc.). + +'Aggregator' is a special form of 'Aggregator'' parameterised by 'Full'. +-} type Aggregator :: Type -> Type -> Type type Aggregator = Aggregator' 'Full --- | An 'Aggregator1' takes a collection of rows of type @a@, groups them, and --- transforms each group into a single row of type @b@. This corresponds to --- aggregators using @GROUP BY@ in SQL. If given an empty collection of rows, --- 'Aggregator1' will have no groups and will therefore also return an empty --- collection of rows. --- --- 'Aggregator1' is a special form of 'Aggregator'' parameterised by 'Semi'. +{- | An 'Aggregator1' takes a collection of rows of type @a@, groups them, and +transforms each group into a single row of type @b@. This corresponds to +aggregators using @GROUP BY@ in SQL. If given an empty collection of rows, +'Aggregator1' will have no groups and will therefore also return an empty +collection of rows. + +'Aggregator1' is a special form of 'Aggregator'' parameterised by 'Semi'. +-} type Aggregator1 :: Type -> Type -> Type type Aggregator1 = Aggregator' 'Semi @@ -168,17 +174,19 @@ toAggregator1 :: Aggregator' fold i a -> Aggregator1 i a toAggregator1 (Aggregator _ a) = Aggregator Empty a --- | Given a value to fall back on if given an empty collection of rows, --- 'toAggregator' turns an 'Aggregator1' into an 'Aggregator'. +{- | Given a value to fall back on if given an empty collection of rows, +'toAggregator' turns an 'Aggregator1' into an 'Aggregator'. +-} toAggregator :: a -> Aggregator' fold i a -> Aggregator' fold' i a toAggregator fallback (Aggregator _ a) = Aggregator (Fallback fallback) a -filterWhereExplicit :: () - => Opaleye.IfPP a a - -> (i -> Expr Bool) - -> Aggregator i a - -> Aggregator' fold i a +filterWhereExplicit :: + () => + Opaleye.IfPP a a -> + (i -> Expr Bool) -> + Aggregator i a -> + Aggregator' fold i a filterWhereExplicit ifPP f (Aggregator (Fallback fallback) aggregator) = Aggregator (Fallback fallback) aggregator' where @@ -187,11 +195,13 @@ filterWhereExplicit ifPP f (Aggregator (Fallback fallback) aggregator) = <$> Opaleye.filterWhere (toColumn . toPrimExpr . f) aggregator -unsafeMakeAggregator :: forall (i :: Type) (o :: Type) (fold :: Fold) i' o'. () - => (i -> i') - -> (o' -> o) - -> Fallback fold o - -> Opaleye.Aggregator i' o' - -> Aggregator' fold i o +unsafeMakeAggregator :: + forall (i :: Type) (o :: Type) (fold :: Fold) i' o'. + () => + (i -> i') -> + (o' -> o) -> + Fallback fold o -> + Opaleye.Aggregator i' o' -> + Aggregator' fold i o unsafeMakeAggregator input output fallback = Aggregator fallback . dimap input output diff --git a/src/Rel8/Aggregate/Fold.hs b/src/Rel8/Aggregate/Fold.hs index 8cedca4b..03204424 100644 --- a/src/Rel8/Aggregate/Fold.hs +++ b/src/Rel8/Aggregate/Fold.hs @@ -1,12 +1,12 @@ -{-# language DataKinds #-} -{-# language GADTs #-} -{-# language LambdaCase #-} -{-# language StandaloneKindSignatures #-} - -module Rel8.Aggregate.Fold - ( Fallback (Empty, Fallback) - , Fold (Semi, Full) - ) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE StandaloneKindSignatures #-} + +module Rel8.Aggregate.Fold ( + Fallback (Empty, Fallback), + Fold (Semi, Full), +) where -- base @@ -18,12 +18,13 @@ import Prelude import Data.Functor.Apply (Apply, liftF2) --- | 'Fold' is a kind that parameterises aggregations. Aggregations --- parameterised by 'Semi' are analogous to 'Data.Semigroup.Foldable.foldMap1' --- (i.e, they can only produce results on a non-empty 'Rel8.Query') whereas --- aggregations parameterised by 'Full' are analagous to 'foldMap' (given a --- non-empty) query, they return the identity values of the aggregation --- functions. +{- | 'Fold' is a kind that parameterises aggregations. Aggregations +parameterised by 'Semi' are analogous to 'Data.Semigroup.Foldable.foldMap1' +(i.e, they can only produce results on a non-empty 'Rel8.Query') whereas +aggregations parameterised by 'Full' are analagous to 'foldMap' (given a +non-empty) query, they return the identity values of the aggregation +functions. +-} type Fold :: Type data Fold = Semi | Full diff --git a/src/Rel8/Column.hs b/src/Rel8/Column.hs index 730f1d54..528b9b41 100644 --- a/src/Rel8/Column.hs +++ b/src/Rel8/Column.hs @@ -1,29 +1,30 @@ -{-# language DataKinds #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} -module Rel8.Column - ( Column - , TColumn - ) +module Rel8.Column ( + Column, + TColumn, +) where -- base -import Data.Kind ( Type ) +import Data.Kind (Type) import Prelude () -- rel8 -import Rel8.FCF ( Eval, Exp ) +import Rel8.FCF (Eval, Exp) import qualified Rel8.Schema.Kind as K -import Rel8.Schema.Result ( Result ) +import Rel8.Schema.Result (Result) --- | This type family is used to specify columns in 'Rel8able's. In @Column f --- a@, @f@ is the context of the column (which should be left polymorphic in --- 'Rel8able' definitions), and @a@ is the type of the column. +{- | This type family is used to specify columns in 'Rel8able's. In @Column f +a@, @f@ is the context of the column (which should be left polymorphic in +'Rel8able' definitions), and @a@ is the type of the column. +-} type Column :: K.Context -> Type -> Type type family Column context a where - Column Result a = a + Column Result a = a Column context a = context a diff --git a/src/Rel8/Column/ADT.hs b/src/Rel8/Column/ADT.hs index 3b3ceb66..e43732b9 100644 --- a/src/Rel8/Column/ADT.hs +++ b/src/Rel8/Column/ADT.hs @@ -1,20 +1,20 @@ -{-# language DataKinds #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} -module Rel8.Column.ADT - ( HADT - ) +module Rel8.Column.ADT ( + HADT, +) where -- base -import Data.Kind ( Type ) +import Data.Kind (Type) import Prelude () -- rel8 import qualified Rel8.Schema.Kind as K -import Rel8.Schema.Result ( Result ) -import Rel8.Table.ADT ( ADT ) +import Rel8.Schema.Result (Result) +import Rel8.Table.ADT (ADT) type HADT :: K.Context -> K.Rel8able -> Type diff --git a/src/Rel8/Column/Either.hs b/src/Rel8/Column/Either.hs index 140539e4..7fa8adfa 100644 --- a/src/Rel8/Column/Either.hs +++ b/src/Rel8/Column/Either.hs @@ -1,25 +1,26 @@ -{-# language DataKinds #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeFamilyDependencies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilyDependencies #-} -module Rel8.Column.Either - ( HEither - ) +module Rel8.Column.Either ( + HEither, +) where -- base -import Data.Kind ( Type ) +import Data.Kind (Type) import Prelude -- rel8 import qualified Rel8.Schema.Kind as K -import Rel8.Schema.Result ( Result ) -import Rel8.Table.Either ( EitherTable ) +import Rel8.Schema.Result (Result) +import Rel8.Table.Either (EitherTable) --- | Nest an 'Either' value within a 'Rel8able'. @HEither f a b@ will produce a --- 'EitherTable' @a b@ in the 'Expr' context, and a 'Either' @a b@ in the --- 'Result' context. +{- | Nest an 'Either' value within a 'Rel8able'. @HEither f a b@ will produce a +'EitherTable' @a b@ in the 'Expr' context, and a 'Either' @a b@ in the +'Result' context. +-} type HEither :: K.Context -> Type -> Type -> Type type family HEither context = either | either -> context where HEither Result = Either diff --git a/src/Rel8/Column/Lift.hs b/src/Rel8/Column/Lift.hs index 9dc25b00..0a9a5acd 100644 --- a/src/Rel8/Column/Lift.hs +++ b/src/Rel8/Column/Lift.hs @@ -1,20 +1,20 @@ -{-# language DataKinds #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} -module Rel8.Column.Lift - ( Lift - ) +module Rel8.Column.Lift ( + Lift, +) where -- base -import Data.Kind ( Type ) +import Data.Kind (Type) import Prelude () -- rel8 import qualified Rel8.Schema.Kind as K -import Rel8.Schema.Result ( Result ) -import Rel8.Table.HKD ( HKD ) +import Rel8.Schema.Result (Result) +import Rel8.Table.HKD (HKD) type Lift :: K.Context -> Type -> Type diff --git a/src/Rel8/Column/List.hs b/src/Rel8/Column/List.hs index f0024fea..10df340f 100644 --- a/src/Rel8/Column/List.hs +++ b/src/Rel8/Column/List.hs @@ -1,24 +1,25 @@ -{-# language DataKinds #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeFamilyDependencies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilyDependencies #-} -module Rel8.Column.List - ( HList - ) +module Rel8.Column.List ( + HList, +) where -- base -import Data.Kind ( Type ) +import Data.Kind (Type) import Prelude () -- rel8 import qualified Rel8.Schema.Kind as K -import Rel8.Schema.Result ( Result ) -import Rel8.Table.List ( ListTable ) +import Rel8.Schema.Result (Result) +import Rel8.Table.List (ListTable) --- | Nest a list within a 'Rel8able'. @HList f a@ will produce a 'ListTable' --- @a@ in the 'Expr' context, and a @[a]@ in the 'Result' context. +{- | Nest a list within a 'Rel8able'. @HList f a@ will produce a 'ListTable' +@a@ in the 'Expr' context, and a @[a]@ in the 'Result' context. +-} type HList :: K.Context -> Type -> Type type family HList context = list | list -> context where HList Result = [] diff --git a/src/Rel8/Column/Maybe.hs b/src/Rel8/Column/Maybe.hs index 6955cc81..df6eacf7 100644 --- a/src/Rel8/Column/Maybe.hs +++ b/src/Rel8/Column/Maybe.hs @@ -1,25 +1,26 @@ -{-# language DataKinds #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeFamilyDependencies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilyDependencies #-} -module Rel8.Column.Maybe - ( HMaybe - ) +module Rel8.Column.Maybe ( + HMaybe, +) where -- base -import Data.Kind ( Type ) +import Data.Kind (Type) import Prelude -- rel8 import qualified Rel8.Schema.Kind as K -import Rel8.Schema.Result ( Result ) -import Rel8.Table.Maybe ( MaybeTable ) +import Rel8.Schema.Result (Result) +import Rel8.Table.Maybe (MaybeTable) --- | Nest a 'Maybe' value within a 'Rel8able'. @HMaybe f a@ will produce a --- 'MaybeTable' @a@ in the 'Expr' context, and a 'Maybe' @a@ in the 'Result' --- context. +{- | Nest a 'Maybe' value within a 'Rel8able'. @HMaybe f a@ will produce a +'MaybeTable' @a@ in the 'Expr' context, and a 'Maybe' @a@ in the 'Result' +context. +-} type HMaybe :: K.Context -> Type -> Type type family HMaybe context = maybe | maybe -> context where HMaybe Result = Maybe diff --git a/src/Rel8/Column/NonEmpty.hs b/src/Rel8/Column/NonEmpty.hs index 5029b801..6166cb04 100644 --- a/src/Rel8/Column/NonEmpty.hs +++ b/src/Rel8/Column/NonEmpty.hs @@ -1,26 +1,27 @@ -{-# language DataKinds #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeFamilyDependencies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilyDependencies #-} -module Rel8.Column.NonEmpty - ( HNonEmpty - ) +module Rel8.Column.NonEmpty ( + HNonEmpty, +) where -- base -import Data.Kind ( Type ) -import Data.List.NonEmpty ( NonEmpty ) +import Data.Kind (Type) +import Data.List.NonEmpty (NonEmpty) import Prelude () -- rel8 import qualified Rel8.Schema.Kind as K -import Rel8.Schema.Result ( Result ) -import Rel8.Table.NonEmpty ( NonEmptyTable ) +import Rel8.Schema.Result (Result) +import Rel8.Table.NonEmpty (NonEmptyTable) --- | Nest a 'NonEmpty' list within a 'Rel8able'. @HNonEmpty f a@ will produce a --- 'NonEmptyTable' @a@ in the 'Expr' context, and a 'NonEmpty' @a@ in the --- 'Result' context. +{- | Nest a 'NonEmpty' list within a 'Rel8able'. @HNonEmpty f a@ will produce a +'NonEmptyTable' @a@ in the 'Expr' context, and a 'NonEmpty' @a@ in the +'Result' context. +-} type HNonEmpty :: K.Context -> Type -> Type type family HNonEmpty context = nonEmpty | nonEmpty -> context where HNonEmpty Result = NonEmpty diff --git a/src/Rel8/Column/Null.hs b/src/Rel8/Column/Null.hs index 43c75420..6873e6cf 100644 --- a/src/Rel8/Column/Null.hs +++ b/src/Rel8/Column/Null.hs @@ -1,25 +1,26 @@ -{-# language DataKinds #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeFamilyDependencies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilyDependencies #-} -module Rel8.Column.Null - ( HNull - ) +module Rel8.Column.Null ( + HNull, +) where -- base -import Data.Kind ( Type ) +import Data.Kind (Type) import Prelude -- rel8 import qualified Rel8.Schema.Kind as K -import Rel8.Schema.Result ( Result ) -import Rel8.Table.Null ( NullTable ) +import Rel8.Schema.Result (Result) +import Rel8.Table.Null (NullTable) --- | Nest a 'Null' value within a 'Rel8able'. @HNull f a@ will produce a --- 'NullTable' @a@ in the 'Expr' context, and a @'Maybe' a@ in the 'Result' --- context. +{- | Nest a 'Null' value within a 'Rel8able'. @HNull f a@ will produce a +'NullTable' @a@ in the 'Expr' context, and a @'Maybe' a@ in the 'Result' +context. +-} type HNull :: K.Context -> Type -> Type type family HNull context = maybe | maybe -> context where HNull Result = Maybe diff --git a/src/Rel8/Column/These.hs b/src/Rel8/Column/These.hs index c6a46316..899f207f 100644 --- a/src/Rel8/Column/These.hs +++ b/src/Rel8/Column/These.hs @@ -1,28 +1,29 @@ -{-# language DataKinds #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeFamilyDependencies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilyDependencies #-} -module Rel8.Column.These - ( HThese - ) +module Rel8.Column.These ( + HThese, +) where -- base -import Data.Kind ( Type ) +import Data.Kind (Type) import Prelude () -- rel8 import qualified Rel8.Schema.Kind as K -import Rel8.Schema.Result ( Result ) -import Rel8.Table.These ( TheseTable ) +import Rel8.Schema.Result (Result) +import Rel8.Table.These (TheseTable) -- these -import Data.These ( These ) +import Data.These (These) --- | Nest an 'These' value within a 'Rel8able'. @HThese f a b@ will produce a --- 'TheseTable' @a b@ in the 'Expr' context, and a 'These' @a b@ in the --- 'Result' context. +{- | Nest an 'These' value within a 'Rel8able'. @HThese f a b@ will produce a +'TheseTable' @a b@ in the 'Expr' context, and a 'These' @a b@ in the +'Result' context. +-} type HThese :: K.Context -> Type -> Type -> Type type family HThese context = these | these -> context where HThese Result = These diff --git a/src/Rel8/Expr.hs b/src/Rel8/Expr.hs index 7a06a599..1dc8b1f2 100644 --- a/src/Rel8/Expr.hs +++ b/src/Rel8/Expr.hs @@ -1,75 +1,82 @@ -{-# language DataKinds #-} -{-# language DerivingStrategies #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language MultiParamTypeClasses #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeApplications #-} -{-# language TypeFamilies #-} -{-# language UndecidableInstances #-} - -module Rel8.Expr - ( Expr(..) - ) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Rel8.Expr ( + Expr (..), +) where -- base -import Data.Functor.Identity ( Identity( Identity ) ) -import Data.String ( IsString, fromString ) -import Prelude hiding ( null ) +import Data.Functor.Identity (Identity (Identity)) +import Data.String (IsString, fromString) +import Prelude hiding (null) -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye -- rel8 -import Rel8.Expr.Function ( function, nullaryFunction ) -import Rel8.Expr.Null ( liftOpNull, nullify ) -import Rel8.Expr.Opaleye - ( castExpr - , fromPrimExpr - , mapPrimExpr - , zipPrimExprsWith - ) -import Rel8.Expr.Serialize ( litExpr ) -import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) ) +import Rel8.Expr.Function (function, nullaryFunction) +import Rel8.Expr.Null (liftOpNull, nullify) +import Rel8.Expr.Opaleye ( + castExpr, + fromPrimExpr, + mapPrimExpr, + zipPrimExprsWith, + ) +import Rel8.Expr.Serialize (litExpr) +import Rel8.Schema.HTable.Identity (HIdentity (HIdentity)) import qualified Rel8.Schema.Kind as K -import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable ) -import Rel8.Table - ( Table, Columns, Context, fromColumns, toColumns - , FromExprs, fromResult, toResult - , Transpose - ) -import Rel8.Type ( DBType ) -import Rel8.Type.Monoid ( DBMonoid, memptyExpr ) -import Rel8.Type.Num ( DBFloating, DBFractional, DBNum ) -import Rel8.Type.Semigroup ( DBSemigroup, (<>.) ) +import Rel8.Schema.Null (Nullity (NotNull, Null), Sql, nullable) +import Rel8.Table ( + Columns, + Context, + FromExprs, + Table, + Transpose, + fromColumns, + fromResult, + toColumns, + toResult, + ) +import Rel8.Type (DBType) +import Rel8.Type.Monoid (DBMonoid, memptyExpr) +import Rel8.Type.Num (DBFloating, DBFractional, DBNum) +import Rel8.Type.Semigroup (DBSemigroup, (<>.)) -- | Typed SQL expressions. type Expr :: K.Context newtype Expr a = Expr Opaleye.PrimExpr - deriving stock Show + deriving stock (Show) instance Sql DBSemigroup a => Semigroup (Expr a) where (<>) = case nullable @a of Null -> liftOpNull (<>.) NotNull -> (<>.) - {-# INLINABLE (<>) #-} + {-# INLINEABLE (<>) #-} instance Sql DBMonoid a => Monoid (Expr a) where mempty = case nullable @a of Null -> nullify memptyExpr NotNull -> memptyExpr - {-# INLINABLE mempty #-} + {-# INLINEABLE mempty #-} instance (Sql IsString a, Sql DBType a) => IsString (Expr a) where - fromString = litExpr . case nullable @a of - Null -> Just . fromString - NotNull -> fromString + fromString = + litExpr . case nullable @a of + Null -> Just . fromString + NotNull -> fromString instance Sql DBNum a => Num (Expr a) where @@ -77,17 +84,21 @@ instance Sql DBNum a => Num (Expr a) where (*) = 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 . fromPrimExpr . Opaleye.ConstExpr . Opaleye.IntegerLit instance Sql DBFractional a => Fractional (Expr a) where (/) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:/)) + fromRational = castExpr . Expr . Opaleye.ConstExpr . Opaleye.NumericLit . realToFrac @@ -119,6 +130,7 @@ instance Sql DBType a => Table Expr (Expr a) where type FromExprs (Expr a) = a type Transpose to (Expr a) = to a + toColumns a = HIdentity a fromColumns (HIdentity a) = a toResult a = HIdentity (Identity a) diff --git a/src/Rel8/Expr/Aggregate.hs b/src/Rel8/Expr/Aggregate.hs index 5b87fdb7..544d05f7 100644 --- a/src/Rel8/Expr/Aggregate.hs +++ b/src/Rel8/Expr/Aggregate.hs @@ -1,33 +1,51 @@ -{-# language DataKinds #-} -{-# language FlexibleContexts #-} -{-# language OverloadedStrings #-} -{-# language ScopedTypeVariables #-} -{-# language TypeFamilies #-} - -{-# options_ghc -fno-warn-redundant-constraints #-} - -module Rel8.Expr.Aggregate - ( count, countOn, countStar - , countDistinct, countDistinctOn - , countWhere, countWhereOn - , and, andOn, or, orOn - , min, minOn, max, maxOn - , sum, sumOn, sumWhere - , avg, avgOn - , stringAgg, stringAggOn - , groupByExpr, groupByExprOn - , distinctAggregate - , filterWhereExplicit - , listAggExpr, listAggExprOn, nonEmptyAggExpr, nonEmptyAggExprOn - , slistAggExpr, snonEmptyAggExpr - ) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + +module Rel8.Expr.Aggregate ( + count, + countOn, + countStar, + countDistinct, + countDistinctOn, + countWhere, + countWhereOn, + and, + andOn, + or, + orOn, + min, + minOn, + max, + maxOn, + sum, + sumOn, + sumWhere, + avg, + avgOn, + stringAgg, + stringAggOn, + groupByExpr, + groupByExprOn, + distinctAggregate, + filterWhereExplicit, + listAggExpr, + listAggExprOn, + nonEmptyAggExpr, + nonEmptyAggExprOn, + slistAggExpr, + snonEmptyAggExpr, +) where -- base -import Data.Int ( Int64 ) -import Data.List.NonEmpty ( NonEmpty ) +import Data.Int (Int64) +import Data.List.NonEmpty (NonEmpty) import Data.String (IsString) -import Prelude hiding ( and, max, min, null, or, sum ) +import Prelude hiding (and, max, min, null, or, sum) -- opaleye import qualified Opaleye.Aggregate as Opaleye @@ -38,32 +56,32 @@ import qualified Opaleye.Internal.Operators as Opaleye import Data.Profunctor (dimap, lmap) -- rel8 -import Rel8.Aggregate - ( Aggregator' (Aggregator) - , Aggregator1 - , filterWhereExplicit - , unsafeMakeAggregator - ) +import Rel8.Aggregate ( + Aggregator' (Aggregator), + Aggregator1, + filterWhereExplicit, + unsafeMakeAggregator, + ) import Rel8.Aggregate.Fold (Fallback (Empty, Fallback)) -import Rel8.Expr ( Expr ) +import Rel8.Expr (Expr) import Rel8.Expr.Array (sempty) import Rel8.Expr.Bool (false, true) -import Rel8.Expr.Opaleye - ( castExpr - , fromColumn - , fromPrimExpr - , toColumn - , toPrimExpr - ) -import Rel8.Schema.Null ( Sql, Unnullify ) -import Rel8.Type ( DBType, typeInformation ) -import Rel8.Type.Array ( encodeArrayElement ) -import Rel8.Type.Eq ( DBEq ) -import Rel8.Type.Information ( TypeInformation ) -import Rel8.Type.Num ( DBNum ) -import Rel8.Type.Ord ( DBMax, DBMin ) -import Rel8.Type.String ( DBString ) -import Rel8.Type.Sum ( DBSum ) +import Rel8.Expr.Opaleye ( + castExpr, + fromColumn, + fromPrimExpr, + toColumn, + toPrimExpr, + ) +import Rel8.Schema.Null (Sql, Unnullify) +import Rel8.Type (DBType, typeInformation) +import Rel8.Type.Array (encodeArrayElement) +import Rel8.Type.Eq (DBEq) +import Rel8.Type.Information (TypeInformation) +import Rel8.Type.Num (DBNum) +import Rel8.Type.Ord (DBMax, DBMin) +import Rel8.Type.String (DBString) +import Rel8.Type.Sum (DBSum) -- | Count the occurances of a single column. Corresponds to @COUNT(a)@ @@ -81,16 +99,20 @@ countOn :: (i -> Expr a) -> Aggregator' fold i (Expr Int64) countOn f = lmap f count --- | Count the number of distinct occurrences of a single column. Corresponds to --- @COUNT(DISTINCT a)@ -countDistinct :: Sql DBEq a - => Aggregator' fold (Expr a) (Expr Int64) +{- | Count the number of distinct occurrences of a single column. Corresponds to +@COUNT(DISTINCT a)@ +-} +countDistinct :: + Sql DBEq a => + Aggregator' fold (Expr a) (Expr Int64) countDistinct = distinctAggregate count -- | Applies 'countDistinct' to the column selected by the given function. -countDistinctOn :: Sql DBEq a - => (i -> Expr a) -> Aggregator' fold i (Expr Int64) +countDistinctOn :: + Sql DBEq a => + (i -> Expr a) -> + Aggregator' fold i (Expr Int64) countDistinctOn f = lmap f countDistinct @@ -169,11 +191,12 @@ minOn :: Sql DBMin a => (i -> Expr a) -> Aggregator1 i (Expr a) minOn f = lmap f min --- | Corresponds to @sum@. Note that in SQL, @sum@ is type changing - for --- example the @sum@ of @integer@ returns a @bigint@. Rel8 doesn't support --- this, and will add explicit casts back to the original input type. This can --- lead to overflows, and if you anticipate very large sums, you should upcast --- your input. +{- | Corresponds to @sum@. Note that in SQL, @sum@ is type changing - for +example the @sum@ of @integer@ returns a @bigint@. Rel8 doesn't support +this, and will add explicit casts back to the original input type. This can +lead to overflows, and if you anticipate very large sums, you should upcast +your input. +-} sum :: (Sql DBNum a, Sql DBSum a) => Aggregator' fold (Expr a) (Expr a) sum = unsafeMakeAggregator @@ -184,22 +207,28 @@ sum = -- | Applies 'sum' to the column selected by the given fucntion. -sumOn :: (Sql DBNum a, Sql DBSum a) - => (i -> Expr a) -> Aggregator' fold i (Expr a) +sumOn :: + (Sql DBNum a, Sql DBSum a) => + (i -> Expr a) -> + Aggregator' fold i (Expr a) sumOn f = lmap f sum -- | 'sumWhere' is a combination of 'Rel8.filterWhere' and 'sumOn'. -sumWhere :: (Sql DBNum a, Sql DBSum a) - => (i -> Expr Bool) -> (i -> Expr a) -> Aggregator' fold i (Expr a) +sumWhere :: + (Sql DBNum a, Sql DBSum a) => + (i -> Expr Bool) -> + (i -> Expr a) -> + Aggregator' fold i (Expr a) sumWhere condition = filterWhereExplicit ifPP condition . sumOn --- | Corresponds to @avg@. Note that in SQL, @avg@ is type changing - for --- example, the @avg@ of @integer@ returns a @numeric@. Rel8 doesn't support --- this, and will add explicit casts back to the original input type. If you --- need a fractional result on an integral column, you should cast your input --- to 'Double' or 'Data.Scientific.Scientific' before calling 'avg'. +{- | Corresponds to @avg@. Note that in SQL, @avg@ is type changing - for +example, the @avg@ of @integer@ returns a @numeric@. Rel8 doesn't support +this, and will add explicit casts back to the original input type. If you +need a fractional result on an integral column, you should cast your input +to 'Double' or 'Data.Scientific.Scientific' before calling 'avg'. +-} avg :: Sql DBSum a => Aggregator1 (Expr a) (Expr a) avg = unsafeMakeAggregator @@ -215,8 +244,10 @@ avgOn f = lmap f avg -- | Corresponds to @string_agg()@. -stringAgg :: (Sql IsString a, Sql DBString a) - => Expr a -> Aggregator' fold (Expr a) (Expr a) +stringAgg :: + (Sql IsString a, Sql DBString a) => + Expr a -> + Aggregator' fold (Expr a) (Expr a) stringAgg delimiter = unsafeMakeAggregator (toColumn . toPrimExpr) @@ -226,8 +257,11 @@ stringAgg delimiter = -- | Applies 'stringAgg' to the column selected by the given function. -stringAggOn :: (Sql IsString a, Sql DBString a) - => Expr a -> (i -> Expr a) -> Aggregator' fold i (Expr a) +stringAggOn :: + (Sql IsString a, Sql DBString a) => + Expr a -> + (i -> Expr a) -> + Aggregator' fold i (Expr a) stringAggOn delimiter f = lmap f (stringAgg delimiter) @@ -262,21 +296,28 @@ nonEmptyAggExpr = snonEmptyAggExpr typeInformation -- | Applies 'nonEmptyAggExpr' to the column selected by the given function. -nonEmptyAggExprOn :: Sql DBType a - => (i -> Expr a) -> Aggregator1 i (Expr (NonEmpty a)) +nonEmptyAggExprOn :: + Sql DBType a => + (i -> Expr a) -> + Aggregator1 i (Expr (NonEmpty a)) nonEmptyAggExprOn f = lmap f nonEmptyAggExpr --- | 'distinctAggregate' modifies an 'Aggregator' to consider only distinct --- values of a particular column. -distinctAggregate :: Sql DBEq a - => Aggregator' fold i (Expr a) -> Aggregator' fold i (Expr a) +{- | 'distinctAggregate' modifies an 'Aggregator' to consider only distinct +values of a particular column. +-} +distinctAggregate :: + Sql DBEq a => + Aggregator' fold i (Expr a) -> + Aggregator' fold i (Expr a) distinctAggregate (Aggregator fallback a) = Aggregator fallback (Opaleye.distinctAggregator a) -slistAggExpr :: () - => TypeInformation (Unnullify a) -> Aggregator' fold (Expr a) (Expr [a]) +slistAggExpr :: + () => + TypeInformation (Unnullify a) -> + Aggregator' fold (Expr a) (Expr [a]) slistAggExpr info = unsafeMakeAggregator (toColumn . encodeArrayElement info . toPrimExpr) @@ -285,8 +326,10 @@ slistAggExpr info = Opaleye.arrayAgg -snonEmptyAggExpr :: () - => TypeInformation (Unnullify a) -> Aggregator1 (Expr a) (Expr (NonEmpty a)) +snonEmptyAggExpr :: + () => + TypeInformation (Unnullify a) -> + Aggregator1 (Expr a) (Expr (NonEmpty a)) snonEmptyAggExpr info = unsafeMakeAggregator (toColumn . encodeArrayElement info . toPrimExpr) diff --git a/src/Rel8/Expr/Array.hs b/src/Rel8/Expr/Array.hs index c039302d..97db6a2c 100644 --- a/src/Rel8/Expr/Array.hs +++ b/src/Rel8/Expr/Array.hs @@ -1,33 +1,37 @@ -{-# language DataKinds #-} -{-# language FlexibleContexts #-} -{-# language TypeFamilies #-} - -{-# options_ghc -fno-warn-redundant-constraints #-} - -module Rel8.Expr.Array - ( listOf, nonEmptyOf - , slistOf, snonEmptyOf - , sappend, sappend1, sempty - ) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + +module Rel8.Expr.Array ( + listOf, + nonEmptyOf, + slistOf, + snonEmptyOf, + sappend, + sappend1, + sempty, +) where -- base -import Data.List.NonEmpty ( NonEmpty ) +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 - ( fromPrimExpr, toPrimExpr - , zipPrimExprsWith - ) -import Rel8.Type ( DBType, typeInformation ) -import Rel8.Type.Array ( array ) -import Rel8.Type.Information ( TypeInformation(..) ) -import Rel8.Schema.Null ( Unnullify, Sql ) +import {-# SOURCE #-} Rel8.Expr (Expr) +import Rel8.Expr.Opaleye ( + fromPrimExpr, + toPrimExpr, + zipPrimExprsWith, + ) +import Rel8.Schema.Null (Sql, Unnullify) +import Rel8.Type (DBType, typeInformation) +import Rel8.Type.Array (array) +import Rel8.Type.Information (TypeInformation (..)) sappend :: Expr [a] -> Expr [a] -> Expr [a] diff --git a/src/Rel8/Expr/Bool.hs b/src/Rel8/Expr/Bool.hs index 00e80ea1..de8d8217 100644 --- a/src/Rel8/Expr/Bool.hs +++ b/src/Rel8/Expr/Bool.hs @@ -1,26 +1,30 @@ -{-# language GADTs #-} - -module Rel8.Expr.Bool - ( false, true - , (&&.), (||.), not_ - , and_, or_ - , boolExpr - , caseExpr - , coalesce - ) +{-# LANGUAGE GADTs #-} + +module Rel8.Expr.Bool ( + false, + true, + (&&.), + (||.), + not_, + and_, + or_, + boolExpr, + caseExpr, + coalesce, +) where -- base -import Data.Foldable ( foldl' ) -import Prelude hiding ( null ) +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, toPrimExpr, zipPrimExprsWith ) -import Rel8.Expr.Serialize ( litExpr ) +import {-# SOURCE #-} Rel8.Expr (Expr (Expr)) +import Rel8.Expr.Opaleye (mapPrimExpr, toPrimExpr, zipPrimExprsWith) +import Rel8.Expr.Serialize (litExpr) -- | The SQL @false@ literal. @@ -36,12 +40,16 @@ true = litExpr True -- | The SQL @AND@ operator. (&&.) :: Expr Bool -> Expr Bool -> Expr Bool (&&.) = zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpAnd) + + infixr 3 &&. -- | The SQL @OR@ operator. (||.) :: Expr Bool -> Expr Bool -> Expr Bool (||.) = zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpOr) + + infixr 2 ||. @@ -60,19 +68,21 @@ or_ :: Foldable f => f (Expr Bool) -> Expr Bool or_ = foldl' (||.) false --- | Eliminate a boolean-valued expression. --- --- Corresponds to 'Data.Bool.bool'. +{- | Eliminate a boolean-valued expression. + +Corresponds to 'Data.Bool.bool'. +-} boolExpr :: Expr a -> Expr a -> Expr Bool -> Expr a boolExpr ifFalse ifTrue condition = caseExpr [(condition, ifTrue)] ifFalse --- | A multi-way if/then/else statement. The first argument to @caseExpr@ is a --- list of alternatives. The first alternative that is of the form @(true, x)@ --- will be returned. If no such alternative is found, a fallback expression is --- returned. --- --- Corresponds to a @CASE@ expression in SQL. +{- | A multi-way if/then/else statement. The first argument to @caseExpr@ is a +list of alternatives. The first alternative that is of the form @(true, x)@ +will be returned. If no such alternative is found, a fallback expression is +returned. + +Corresponds to a @CASE@ expression in SQL. +-} caseExpr :: [(Expr Bool, Expr a)] -> Expr a -> Expr a caseExpr branches (Expr fallback) = Expr $ Opaleye.CaseExpr (map go branches) fallback @@ -80,10 +90,11 @@ caseExpr branches (Expr fallback) = go (condition, value) = (toPrimExpr condition, toPrimExpr value) --- | Convert a @Expr (Maybe Bool)@ to a @Expr Bool@ by treating @Nothing@ as --- @False@. This can be useful when combined with 'Rel8.where_', which expects --- a @Bool@, and produces expressions that optimize better than general case --- analysis. +{- | Convert a @Expr (Maybe Bool)@ to a @Expr Bool@ by treating @Nothing@ as +@False@. This can be useful when combined with 'Rel8.where_', which expects +a @Bool@, and produces expressions that optimize better than general case +analysis. +-} coalesce :: Expr (Maybe Bool) -> Expr Bool coalesce (Expr a) = Expr a &&. Expr (Opaleye.FunExpr "COALESCE" [a, untrue]) where diff --git a/src/Rel8/Expr/Default.hs b/src/Rel8/Expr/Default.hs index 6aa6d3f1..0e43f96a 100644 --- a/src/Rel8/Expr/Default.hs +++ b/src/Rel8/Expr/Default.hs @@ -1,6 +1,6 @@ -module Rel8.Expr.Default - ( unsafeDefault - ) +module Rel8.Expr.Default ( + unsafeDefault, +) where -- base @@ -10,26 +10,27 @@ import Prelude () import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Expr.Opaleye ( fromPrimExpr ) - - --- | Corresponds to the SQL @DEFAULT@ expression. --- --- This 'Expr' is unsafe for numerous reasons, and should be used with care: --- --- 1. This 'Expr' only makes sense in an @INSERT@ or @UPDATE@ statement. --- --- 2. Rel8 is not able to verify that a particular column actually has a --- @DEFAULT@ value. Trying to use @unsafeDefault@ where there is no default --- will cause a runtime crash --- --- 3. @DEFAULT@ values can not be transformed. For example, the innocuous Rel8 --- code @unsafeDefault + 1@ will crash, despite type checking. --- --- Given all these caveats, we suggest avoiding the use of default values where --- possible, instead being explicit. A common scenario where default values are --- used is with auto-incrementing identifier columns. In this case, we suggest --- using 'Rel8.nextval' instead. +import Rel8.Expr (Expr) +import Rel8.Expr.Opaleye (fromPrimExpr) + + +{- | Corresponds to the SQL @DEFAULT@ expression. + +This 'Expr' is unsafe for numerous reasons, and should be used with care: + +1. This 'Expr' only makes sense in an @INSERT@ or @UPDATE@ statement. + +2. Rel8 is not able to verify that a particular column actually has a +@DEFAULT@ value. Trying to use @unsafeDefault@ where there is no default +will cause a runtime crash + +3. @DEFAULT@ values can not be transformed. For example, the innocuous Rel8 +code @unsafeDefault + 1@ will crash, despite type checking. + +Given all these caveats, we suggest avoiding the use of default values where +possible, instead being explicit. A common scenario where default values are +used is with auto-incrementing identifier columns. In this case, we suggest +using 'Rel8.nextval' instead. +-} unsafeDefault :: Expr a unsafeDefault = fromPrimExpr Opaleye.DefaultInsertExpr diff --git a/src/Rel8/Expr/Eq.hs b/src/Rel8/Expr/Eq.hs index 4878e454..dbe911e9 100644 --- a/src/Rel8/Expr/Eq.hs +++ b/src/Rel8/Expr/Eq.hs @@ -1,33 +1,34 @@ -{-# language FlexibleContexts #-} -{-# language GADTs #-} -{-# language ScopedTypeVariables #-} -{-# language TypeApplications #-} -{-# language ViewPatterns #-} - -{-# options_ghc -fno-warn-redundant-constraints #-} - -module Rel8.Expr.Eq - ( (==.), (/=.) - , (==?), (/=?) - , in_ - ) +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + +module Rel8.Expr.Eq ( + (==.), + (/=.), + (==?), + (/=?), + in_, +) where -- base -import Data.Foldable ( toList ) -import Data.List.NonEmpty ( nonEmpty ) +import Data.Foldable (toList) +import Data.List.NonEmpty (nonEmpty) import Prelude -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Expr.Bool ( (&&.), (||.), false, or_, coalesce ) -import Rel8.Expr.Null ( isNull, unsafeLiftOpNull ) -import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr, zipPrimExprsWith ) -import Rel8.Schema.Null ( Nullity( NotNull, Null ), Sql, nullable ) -import Rel8.Type.Eq ( DBEq ) +import Rel8.Expr (Expr) +import Rel8.Expr.Bool (coalesce, false, or_, (&&.), (||.)) +import Rel8.Expr.Null (isNull, unsafeLiftOpNull) +import Rel8.Expr.Opaleye (fromPrimExpr, toPrimExpr, zipPrimExprsWith) +import Rel8.Schema.Null (Nullity (NotNull, Null), Sql, nullable) +import Rel8.Type.Eq (DBEq) eq :: DBEq a => Expr a -> Expr a -> Expr Bool @@ -38,64 +39,82 @@ ne :: DBEq a => Expr a -> Expr a -> Expr Bool ne = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:<>)) --- | Compare two expressions for equality. --- --- This corresponds to the SQL @IS NOT DISTINCT FROM@ operator, and will equate --- @null@ values as @true@. This differs from @=@ which would return @null@. --- This operator matches Haskell's '==' operator. For an operator identical to --- SQL @=@, see '==?'. +{- | Compare two expressions for equality. + +This corresponds to the SQL @IS NOT DISTINCT FROM@ operator, and will equate +@null@ values as @true@. This differs from @=@ which would return @null@. +This operator matches Haskell's '==' operator. For an operator identical to +SQL @=@, see '==?'. +-} (==.) :: forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool (==.) = case nullable @a of Null -> \ma mb -> isNull ma &&. isNull mb ||. ma ==? mb NotNull -> eq + + infix 4 ==. -{-# INLINABLE (==.) #-} +{-# INLINEABLE (==.) #-} --- | Test if two expressions are different (not equal). --- --- This corresponds to the SQL @IS DISTINCT FROM@ operator, and will return --- @false@ when comparing two @null@ values. This differs from ordinary @=@ --- which would return @null@. This operator is closer to Haskell's '==' --- operator. For an operator identical to SQL @=@, see '/=?'. +{- | Test if two expressions are different (not equal). + +This corresponds to the SQL @IS DISTINCT FROM@ operator, and will return +@false@ when comparing two @null@ values. This differs from ordinary @=@ +which would return @null@. This operator is closer to Haskell's '==' +operator. For an operator identical to SQL @=@, see '/=?'. +-} (/=.) :: forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool (/=.) = case nullable @a of Null -> \ma mb -> isNull ma `ne` isNull mb ||. ma /=? mb NotNull -> ne + + infix 4 /=. -{-# INLINABLE (/=.) #-} +{-# INLINEABLE (/=.) #-} --- | Test if two expressions are equal. This operator is usually the best --- choice when forming join conditions, as PostgreSQL has a much harder time --- optimizing a join that has multiple 'True' conditions. --- --- This corresponds to the SQL @=@ operator, though it will always return a --- 'Bool'. +{- | Test if two expressions are equal. This operator is usually the best +choice when forming join conditions, as PostgreSQL has a much harder time +optimizing a join that has multiple 'True' conditions. + +This corresponds to the SQL @=@ operator, though it will always return a +'Bool'. +-} (==?) :: DBEq a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool a ==? b = coalesce $ unsafeLiftOpNull eq a b + + infix 4 ==? --- | Test if two expressions are different. --- --- This corresponds to the SQL @<>@ operator, though it will always return a --- 'Bool'. +{- | Test if two expressions are different. + +This corresponds to the SQL @<>@ operator, though it will always return a +'Bool'. +-} (/=?) :: DBEq a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool a /=? b = coalesce $ unsafeLiftOpNull ne a b + + infix 4 /=? --- | Like the SQL @IN@ operator, but implemented by folding over a list with --- '==.' and '||.'. -in_ :: forall a f. (Sql DBEq a, Foldable f) - => Expr a -> f (Expr a) -> Expr Bool +{- | Like the SQL @IN@ operator, but implemented by folding over a list with +'==.' and '||.'. +-} +in_ :: + forall a f. + (Sql DBEq a, Foldable f) => + Expr a -> + f (Expr a) -> + Expr Bool in_ a (toList -> as) = case nullable @a of Null -> or_ $ map (a ==.) as NotNull -> case nonEmpty as of - Nothing -> false - Just xs -> - fromPrimExpr $ - Opaleye.BinExpr Opaleye.OpIn - (toPrimExpr a) - (Opaleye.ListExpr (toPrimExpr <$> xs)) + Nothing -> false + Just xs -> + fromPrimExpr $ + Opaleye.BinExpr + Opaleye.OpIn + (toPrimExpr a) + (Opaleye.ListExpr (toPrimExpr <$> xs)) diff --git a/src/Rel8/Expr/Function.hs b/src/Rel8/Expr/Function.hs index d5634106..bb291940 100644 --- a/src/Rel8/Expr/Function.hs +++ b/src/Rel8/Expr/Function.hs @@ -1,38 +1,42 @@ -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language MultiParamTypeClasses #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeFamilies #-} -{-# language TypeOperators #-} -{-# language UndecidableInstances #-} - -module Rel8.Expr.Function - ( Function, function - , nullaryFunction - , binaryOperator - ) +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Rel8.Expr.Function ( + Function, + function, + nullaryFunction, + binaryOperator, +) where -- base -import Data.Kind ( Constraint, Type ) +import Data.Kind (Constraint, Type) import Prelude -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye -- rel8 -import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) ) -import Rel8.Expr.Opaleye - ( castExpr - , fromPrimExpr, toPrimExpr, zipPrimExprsWith - ) -import Rel8.Schema.Null ( Sql ) -import Rel8.Type ( DBType ) - - --- | This type class exists to allow 'function' to have arbitrary arity. It's --- mostly an implementation detail, and typical uses of 'Function' shouldn't --- need this to be specified. +import {-# SOURCE #-} Rel8.Expr (Expr (Expr)) +import Rel8.Expr.Opaleye ( + castExpr, + fromPrimExpr, + toPrimExpr, + zipPrimExprsWith, + ) +import Rel8.Schema.Null (Sql) +import Rel8.Type (DBType) + + +{- | This type class exists to allow 'function' to have arbitrary arity. It's +mostly an implementation detail, and typical uses of 'Function' shouldn't +need this to be specified. +-} type Function :: Type -> Type -> Constraint class Function arg res where applyArgument :: ([Opaleye.PrimExpr] -> Opaleye.PrimExpr) -> arg -> res @@ -46,8 +50,9 @@ instance (arg ~ Expr a, Function args res) => Function arg (args -> res) where applyArgument f a = applyArgument (f . (toPrimExpr a :)) --- | Construct an n-ary function that produces an 'Expr' that when called runs --- a SQL function. +{- | Construct an n-ary function that produces an 'Expr' that when called runs +a SQL function. +-} function :: Function args result => String -> args -> result function = applyArgument . Opaleye.FunExpr @@ -57,8 +62,9 @@ nullaryFunction :: Sql DBType a => String -> Expr a nullaryFunction name = castExpr $ Expr (Opaleye.FunExpr name []) --- | Construct an expression by applying an infix binary operator to two --- operands. +{- | Construct an expression by applying an infix binary operator to two +operands. +-} binaryOperator :: Sql DBType c => String -> Expr a -> Expr b -> Expr c binaryOperator operator a b = castExpr $ zipPrimExprsWith (Opaleye.BinExpr (Opaleye.OpOther operator)) a b diff --git a/src/Rel8/Expr/Null.hs b/src/Rel8/Expr/Null.hs index 1f1430fd..6ab4712a 100644 --- a/src/Rel8/Expr/Null.hs +++ b/src/Rel8/Expr/Null.hs @@ -1,36 +1,44 @@ -{-# language DataKinds #-} -{-# language FlexibleContexts #-} -{-# language TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} {-# options -fno-warn-redundant-constraints #-} -module Rel8.Expr.Null - ( null, snull, nullableExpr, nullableOf - , isNull, isNonNull - , nullify, unsafeUnnullify - , mapNull, liftOpNull - , unsafeMapNull, unsafeLiftOpNull - ) +module Rel8.Expr.Null ( + null, + snull, + nullableExpr, + nullableOf, + isNull, + isNonNull, + nullify, + unsafeUnnullify, + mapNull, + liftOpNull, + unsafeMapNull, + unsafeLiftOpNull, +) where -- base -import Prelude hiding ( null ) +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, mapPrimExpr ) -import Rel8.Schema.Null ( NotNull ) -import Rel8.Type ( DBType, typeInformation ) -import Rel8.Type.Information ( TypeInformation ) - - --- | Lift an expression that can't be @null@ to a type that might be @null@. --- This is an identity operation in terms of any generated query, and just --- modifies the query's type. +import {-# SOURCE #-} Rel8.Expr (Expr (Expr)) +import Rel8.Expr.Bool (boolExpr, (||.)) +import Rel8.Expr.Opaleye (mapPrimExpr, scastExpr) +import Rel8.Schema.Null (NotNull) +import Rel8.Type (DBType, typeInformation) +import Rel8.Type.Information (TypeInformation) + + +{- | Lift an expression that can't be @null@ to a type that might be @null@. +This is an identity operation in terms of any generated query, and just +modifies the query's type. +-} nullify :: NotNull a => Expr a -> Expr (Maybe a) nullify (Expr a) = Expr a @@ -58,27 +66,37 @@ isNonNull :: Expr (Maybe a) -> Expr Bool isNonNull = mapPrimExpr (Opaleye.UnExpr Opaleye.OpIsNotNull) --- | Lift an operation on non-@null@ values to an operation on possibly @null@ --- values. When given @null@, @mapNull f@ returns @null@. --- --- This is like 'fmap' for 'Maybe'. -mapNull :: DBType b - => (Expr a -> Expr b) -> Expr (Maybe a) -> Expr (Maybe b) +{- | Lift an operation on non-@null@ values to an operation on possibly @null@ +values. When given @null@, @mapNull f@ returns @null@. + +This is like 'fmap' for 'Maybe'. +-} +mapNull :: + DBType b => + (Expr a -> Expr b) -> + Expr (Maybe a) -> + Expr (Maybe b) mapNull f ma = boolExpr (unsafeMapNull f ma) null (isNull ma) --- | Lift a binary operation on non-@null@ expressions to an equivalent binary --- operator on possibly @null@ expressions. If either of the final arguments --- are @null@, @liftOpNull@ returns @null@. --- --- This is like 'liftA2' for 'Maybe'. -liftOpNull :: DBType c - => (Expr a -> Expr b -> Expr c) - -> Expr (Maybe a) -> Expr (Maybe b) -> Expr (Maybe c) +{- | Lift a binary operation on non-@null@ expressions to an equivalent binary +operator on possibly @null@ expressions. If either of the final arguments +are @null@, @liftOpNull@ returns @null@. + +This is like 'liftA2' for 'Maybe'. +-} +liftOpNull :: + DBType c => + (Expr a -> Expr b -> Expr c) -> + Expr (Maybe a) -> + Expr (Maybe b) -> + Expr (Maybe c) liftOpNull f ma mb = - boolExpr (unsafeLiftOpNull f ma mb) null + boolExpr + (unsafeLiftOpNull f ma mb) + null (isNull ma ||. isNull mb) -{-# INLINABLE liftOpNull #-} +{-# INLINEABLE liftOpNull #-} snull :: TypeInformation a -> Expr (Maybe a) @@ -90,13 +108,19 @@ null :: DBType a => Expr (Maybe a) null = snull typeInformation -unsafeMapNull :: NotNull b - => (Expr a -> Expr b) -> Expr (Maybe a) -> Expr (Maybe b) +unsafeMapNull :: + NotNull b => + (Expr a -> Expr b) -> + Expr (Maybe a) -> + Expr (Maybe b) unsafeMapNull f ma = nullify (f (unsafeUnnullify ma)) -unsafeLiftOpNull :: NotNull c - => (Expr a -> Expr b -> Expr c) - -> Expr (Maybe a) -> Expr (Maybe b) -> Expr (Maybe c) +unsafeLiftOpNull :: + NotNull c => + (Expr a -> Expr b -> Expr c) -> + Expr (Maybe a) -> + Expr (Maybe b) -> + Expr (Maybe c) unsafeLiftOpNull f ma mb = nullify (f (unsafeUnnullify ma) (unsafeUnnullify mb)) diff --git a/src/Rel8/Expr/Num.hs b/src/Rel8/Expr/Num.hs index 6b560e29..1d263645 100644 --- a/src/Rel8/Expr/Num.hs +++ b/src/Rel8/Expr/Num.hs @@ -1,61 +1,78 @@ -{-# language FlexibleContexts #-} -{-# language TypeFamilies #-} - -{-# options_ghc -fno-warn-redundant-constraints #-} - -module Rel8.Expr.Num - ( fromIntegral - , realToFrac - , div, mod, divMod - , quot, rem, quotRem - , ceiling, floor, round, truncate - ) +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + +module Rel8.Expr.Num ( + fromIntegral, + realToFrac, + div, + mod, + divMod, + quot, + rem, + quotRem, + ceiling, + floor, + round, + truncate, +) where -- base -import Prelude ( (+), (-), fst, negate, signum, snd ) - --- rel -import Rel8.Expr ( Expr( Expr ) ) -import Rel8.Expr.Eq ( (==.) ) -import Rel8.Expr.Function ( function ) -import Rel8.Expr.Opaleye ( castExpr ) -import Rel8.Schema.Null ( Homonullable, Sql ) -import Rel8.Table.Bool ( bool ) -import Rel8.Type.Num ( DBFractional, DBIntegral, DBNum ) - - --- | Cast 'DBIntegral' types to 'DBNum' types. For example, this can be useful --- if you need to turn an @Expr Int32@ into an @Expr Double@. -fromIntegral :: (Sql DBIntegral a, Sql DBNum b, Homonullable a b) - => Expr a -> Expr b +import Prelude (fst, negate, signum, snd, (+), (-)) + +-- rel8 +import Rel8.Expr (Expr (Expr)) +import Rel8.Expr.Eq ((==.)) +import Rel8.Expr.Function (function) +import Rel8.Expr.Opaleye (castExpr) +import Rel8.Schema.Null (Homonullable, Sql) +import Rel8.Table.Bool (bool) +import Rel8.Type.Num (DBFractional, DBIntegral, DBNum) + + +{- | Cast 'DBIntegral' types to 'DBNum' types. For example, this can be useful +if you need to turn an @Expr Int32@ into an @Expr Double@. +-} +fromIntegral :: + (Sql DBIntegral a, Sql DBNum b, Homonullable a b) => + Expr a -> + Expr b fromIntegral (Expr a) = castExpr (Expr a) --- | Cast 'DBNum' types to 'DBFractional' types. For example, his can be useful --- to convert @Expr Float@ to @Expr Double@. -realToFrac :: (Sql DBNum a, Sql DBFractional b, Homonullable a b) - => Expr a -> Expr b +{- | Cast 'DBNum' types to 'DBFractional' types. For example, his can be useful +to convert @Expr Float@ to @Expr Double@. +-} +realToFrac :: + (Sql DBNum a, Sql DBFractional b, Homonullable a b) => + Expr a -> + Expr b realToFrac (Expr a) = castExpr (Expr a) --- | Round a 'DBFractional' to a 'DBIntegral' by rounding to the nearest larger --- integer. --- --- Corresponds to the @ceiling()@ function. -ceiling :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b) - => Expr a -> Expr b +{- | Round a 'DBFractional' to a 'DBIntegral' by rounding to the nearest larger +integer. + +Corresponds to the @ceiling()@ function. +-} +ceiling :: + (Sql DBFractional a, Sql DBIntegral b, Homonullable a b) => + Expr a -> + Expr b ceiling = function "ceiling" --- | Emulates the behaviour of the Haskell function 'Prelude.div' in --- PostgreSQL. +{- | Emulates the behaviour of the Haskell function 'Prelude.div' in +PostgreSQL. +-} div :: Sql DBIntegral a => Expr a -> Expr a -> Expr a div n d = fst (divMod n d) --- | Emulates the behaviour of the Haskell function 'Prelude.mod' in --- PostgreSQL. +{- | Emulates the behaviour of the Haskell function 'Prelude.mod' in +PostgreSQL. +-} mod :: Sql DBIntegral a => Expr a -> Expr a -> Expr a mod n d = snd (divMod n d) @@ -67,15 +84,17 @@ divMod n d = bool qr (q - 1, r + d) (signum r ==. negate (signum d)) qr@(q, r) = quotRem n d --- | Perform integral division. Corresponds to the @div()@ function in --- PostgreSQL, which behaves like Haskell's 'Prelude.quot' rather than --- 'Prelude.div'. +{- | Perform integral division. Corresponds to the @div()@ function in +PostgreSQL, which behaves like Haskell's 'Prelude.quot' rather than +'Prelude.div'. +-} quot :: Sql DBIntegral a => Expr a -> Expr a -> Expr a quot = function "div" --- | Corresponds to the @mod()@ function in PostgreSQL, which behaves like --- Haskell's 'Prelude.rem' rather than 'Prelude.mod'. +{- | Corresponds to the @mod()@ function in PostgreSQL, which behaves like +Haskell's 'Prelude.rem' rather than 'Prelude.mod'. +-} rem :: Sql DBIntegral a => Expr a -> Expr a -> Expr a rem = function "mod" @@ -85,26 +104,35 @@ quotRem :: Sql DBIntegral a => Expr a -> Expr a -> (Expr a, Expr a) quotRem n d = (quot n d, rem n d) --- | Round a 'DFractional' to a 'DBIntegral' by rounding to the nearest smaller --- integer. --- --- Corresponds to the @floor()@ function. -floor :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b) - => Expr a -> Expr b +{- | Round a 'DFractional' to a 'DBIntegral' by rounding to the nearest smaller +integer. + +Corresponds to the @floor()@ function. +-} +floor :: + (Sql DBFractional a, Sql DBIntegral b, Homonullable a b) => + Expr a -> + Expr b floor = function "floor" --- | Round a 'DBFractional' to a 'DBIntegral' by rounding to the nearest --- integer. --- --- Corresponds to the @round()@ function. -round :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b) - => Expr a -> Expr b +{- | Round a 'DBFractional' to a 'DBIntegral' by rounding to the nearest +integer. + +Corresponds to the @round()@ function. +-} +round :: + (Sql DBFractional a, Sql DBIntegral b, Homonullable a b) => + Expr a -> + Expr b round = function "round" --- | Round a 'DBFractional' to a 'DBIntegral' by rounding to the nearest --- integer towards zero. -truncate :: (Sql DBFractional a, Sql DBIntegral b, Homonullable a b) - => Expr a -> Expr b +{- | Round a 'DBFractional' to a 'DBIntegral' by rounding to the nearest +integer towards zero. +-} +truncate :: + (Sql DBFractional a, Sql DBIntegral b, Homonullable a b) => + Expr a -> + Expr b truncate = function "trunc" diff --git a/src/Rel8/Expr/Opaleye.hs b/src/Rel8/Expr/Opaleye.hs index ab5578c6..2e2b7065 100644 --- a/src/Rel8/Expr/Opaleye.hs +++ b/src/Rel8/Expr/Opaleye.hs @@ -1,17 +1,24 @@ -{-# language FlexibleContexts #-} -{-# language NamedFieldPuns #-} -{-# language ScopedTypeVariables #-} -{-# language TypeFamilies #-} - -{-# options_ghc -fno-warn-redundant-constraints #-} - -module Rel8.Expr.Opaleye - ( castExpr, unsafeCastExpr - , scastExpr, sunsafeCastExpr - , unsafeLiteral - , fromPrimExpr, toPrimExpr, mapPrimExpr, zipPrimExprsWith, traversePrimExpr - , toColumn, fromColumn, traverseFieldP - ) +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + +module Rel8.Expr.Opaleye ( + castExpr, + unsafeCastExpr, + scastExpr, + sunsafeCastExpr, + unsafeLiteral, + fromPrimExpr, + toPrimExpr, + mapPrimExpr, + zipPrimExprsWith, + traversePrimExpr, + toColumn, + fromColumn, + traverseFieldP, +) where -- base @@ -21,22 +28,23 @@ import Prelude import qualified Opaleye.Internal.Column as Opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye --- rel8 -import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) ) -import Rel8.Schema.Null ( Unnullify, Sql ) -import Rel8.Type ( DBType, typeInformation ) -import Rel8.Type.Information ( TypeInformation(..) ) - -- profunctors -import Data.Profunctor ( Profunctor, dimap ) +import Data.Profunctor (Profunctor, dimap) + +-- rel8 +import {-# SOURCE #-} Rel8.Expr (Expr (Expr)) +import Rel8.Schema.Null (Sql, Unnullify) +import Rel8.Type (DBType, typeInformation) +import Rel8.Type.Information (TypeInformation (..)) castExpr :: Sql DBType a => Expr a -> Expr a castExpr = scastExpr typeInformation --- | Cast an expression to a different type. Corresponds to a @CAST()@ function --- call. +{- | Cast an expression to a different type. Corresponds to a @CAST()@ function +call. +-} unsafeCastExpr :: Sql DBType b => Expr a -> Expr b unsafeCastExpr = sunsafeCastExpr typeInformation @@ -45,17 +53,21 @@ scastExpr :: TypeInformation (Unnullify a) -> Expr a -> Expr a scastExpr = sunsafeCastExpr -sunsafeCastExpr :: () - => TypeInformation (Unnullify b) -> Expr a -> Expr b -sunsafeCastExpr TypeInformation {typeName} = +sunsafeCastExpr :: + () => + TypeInformation (Unnullify b) -> + Expr a -> + Expr b +sunsafeCastExpr TypeInformation{typeName} = fromPrimExpr . Opaleye.CastExpr typeName . toPrimExpr --- | Unsafely construct an expression from literal SQL. --- --- This is an escape hatch, and can be used if Rel8 can not adequately express --- the query you need. If you find yourself using this function, please let us --- know, as it may indicate that something is missing from Rel8! +{- | Unsafely construct an expression from literal SQL. + +This is an escape hatch, and can be used if Rel8 can not adequately express +the query you need. If you find yourself using this function, please let us +know, as it may indicate that something is missing from Rel8! +-} unsafeLiteral :: String -> Expr a unsafeLiteral = Expr . Opaleye.ConstExpr . Opaleye.OtherLit @@ -72,21 +84,28 @@ mapPrimExpr :: (Opaleye.PrimExpr -> Opaleye.PrimExpr) -> Expr a -> Expr b mapPrimExpr f = fromPrimExpr . f . toPrimExpr -zipPrimExprsWith :: () - => (Opaleye.PrimExpr -> Opaleye.PrimExpr -> Opaleye.PrimExpr) - -> Expr a -> Expr b -> Expr c +zipPrimExprsWith :: + () => + (Opaleye.PrimExpr -> Opaleye.PrimExpr -> Opaleye.PrimExpr) -> + Expr a -> + Expr b -> + Expr c zipPrimExprsWith f a b = fromPrimExpr (f (toPrimExpr a) (toPrimExpr b)) -traversePrimExpr :: Functor f - => (Opaleye.PrimExpr -> f Opaleye.PrimExpr) -> Expr a -> f (Expr b) +traversePrimExpr :: + Functor f => + (Opaleye.PrimExpr -> f Opaleye.PrimExpr) -> + Expr a -> + f (Expr b) traversePrimExpr f = fmap fromPrimExpr . f . toPrimExpr -traverseFieldP :: Profunctor p - => p (Opaleye.Field_ n x) (Opaleye.Field_ m y) - -> p (Expr a) (Expr b) -traverseFieldP = dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) +traverseFieldP :: + Profunctor p => + p (Opaleye.Field_ n x) (Opaleye.Field_ m y) -> + p (Expr a) (Expr b) +traverseFieldP = dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) toColumn :: Opaleye.PrimExpr -> Opaleye.Field_ n b diff --git a/src/Rel8/Expr/Ord.hs b/src/Rel8/Expr/Ord.hs index df436f27..8ad7dcd8 100644 --- a/src/Rel8/Expr/Ord.hs +++ b/src/Rel8/Expr/Ord.hs @@ -1,16 +1,22 @@ -{-# language DataKinds #-} -{-# language FlexibleContexts #-} -{-# language GADTs #-} -{-# language ScopedTypeVariables #-} -{-# language TypeApplications #-} - -{-# options_ghc -fno-warn-redundant-constraints #-} - -module Rel8.Expr.Ord - ( (<.), (<=.), (>.), (>=.) - , (?), (>=?) - , leastExpr, greatestExpr - ) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + +module Rel8.Expr.Ord ( + (<.), + (<=.), + (>.), + (>=.), + (?), + (>=?), + leastExpr, + greatestExpr, +) where -- base @@ -20,12 +26,12 @@ import Prelude import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye -- rel8 -import Rel8.Expr ( Expr( Expr ) ) -import Rel8.Expr.Bool ( (&&.), (||.), coalesce ) -import Rel8.Expr.Null ( isNull, isNonNull, nullableExpr, unsafeLiftOpNull ) -import Rel8.Expr.Opaleye ( toPrimExpr, zipPrimExprsWith ) -import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable ) -import Rel8.Type.Ord ( DBOrd ) +import Rel8.Expr (Expr (Expr)) +import Rel8.Expr.Bool (coalesce, (&&.), (||.)) +import Rel8.Expr.Null (isNonNull, isNull, nullableExpr, unsafeLiftOpNull) +import Rel8.Expr.Opaleye (toPrimExpr, zipPrimExprsWith) +import Rel8.Schema.Null (Nullity (NotNull, Null), Sql, nullable) +import Rel8.Type.Ord (DBOrd) lt :: DBOrd a => Expr a -> Expr a -> Expr Bool @@ -44,78 +50,103 @@ ge :: DBOrd a => Expr a -> Expr a -> Expr Bool ge = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:>=)) --- | Corresponds to the SQL @<@ operator. Note that this differs from SQL @<@ --- as @null@ will sort below any other value. For a version of @<@ that exactly --- matches SQL, see '( Expr a -> Expr a -> Expr Bool (<.) = case nullable @a of Null -> \ma mb -> isNull ma &&. isNonNull mb ||. ma lt + + infix 4 <. --- | Corresponds to the SQL @<=@ operator. Note that this differs from SQL @<=@ --- as @null@ will sort below any other value. For a version of @<=@ that exactly --- matches SQL, see '(<=?)'. +{- | Corresponds to the SQL @<=@ operator. Note that this differs from SQL @<=@ +as @null@ will sort below any other value. For a version of @<=@ that exactly +matches SQL, see '(<=?)'. +-} (<=.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool (<=.) = case nullable @a of Null -> \ma mb -> isNull ma ||. ma <=? mb NotNull -> le + + infix 4 <=. --- | Corresponds to the SQL @>@ operator. Note that this differs from SQL @>@ --- as @null@ will sort below any other value. For a version of @>@ that exactly --- matches SQL, see '(>?)'. +{- | Corresponds to the SQL @>@ operator. Note that this differs from SQL @>@ +as @null@ will sort below any other value. For a version of @>@ that exactly +matches SQL, see '(>?)'. +-} (>.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool (>.) = case nullable @a of Null -> \ma mb -> isNonNull ma &&. isNull mb ||. ma >? mb NotNull -> gt + + infix 4 >. --- | Corresponds to the SQL @>=@ operator. Note that this differs from SQL @>@ --- as @null@ will sort below any other value. For a version of @>=@ that --- exactly matches SQL, see '(>=?)'. +{- | Corresponds to the SQL @>=@ operator. Note that this differs from SQL @>@ +as @null@ will sort below any other value. For a version of @>=@ that +exactly matches SQL, see '(>=?)'. +-} (>=.) :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool (>=.) = case nullable @a of Null -> \ma mb -> isNull mb ||. ma >=? mb NotNull -> ge + + infix 4 >=. --- | Corresponds to the SQL @<@ operator. Returns @null@ if either arguments --- are @null@. +{- | Corresponds to the SQL @<@ operator. Returns @null@ if either arguments +are @null@. +-} ( Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool a Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool a <=? b = coalesce $ unsafeLiftOpNull le a b + + infix 4 <=? --- | Corresponds to the SQL @>@ operator. Returns @null@ if either arguments --- are @null@. +{- | Corresponds to the SQL @>@ operator. Returns @null@ if either arguments +are @null@. +-} (>?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool a >? b = coalesce $ unsafeLiftOpNull gt a b + + infix 4 >? --- | Corresponds to the SQL @>=@ operator. Returns @null@ if either arguments --- are @null@. +{- | Corresponds to the SQL @>=@ operator. Returns @null@ if either arguments +are @null@. +-} (>=?) :: DBOrd a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool a >=? b = coalesce $ unsafeLiftOpNull ge a b + + infix 4 >=? --- | Given two expressions, return the expression that sorts less than the --- other. --- --- Corresponds to the SQL @least()@ function. +{- | Given two expressions, return the expression that sorts less than the +other. + +Corresponds to the SQL @least()@ function. +-} leastExpr :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr a leastExpr ma mb = case nullable @a of Null -> nullableExpr ma (\a -> nullableExpr mb (least_ a) mb) ma @@ -124,10 +155,11 @@ leastExpr ma mb = case nullable @a of least_ a b = Expr (Opaleye.FunExpr "LEAST" [toPrimExpr a, toPrimExpr b]) --- | Given two expressions, return the expression that sorts greater than the --- other. --- --- Corresponds to the SQL @greatest()@ function. +{- | Given two expressions, return the expression that sorts greater than the +other. + +Corresponds to the SQL @greatest()@ function. +-} greatestExpr :: forall a. Sql DBOrd a => Expr a -> Expr a -> Expr a greatestExpr ma mb = case nullable @a of Null -> nullableExpr mb (\a -> nullableExpr ma (greatest_ a) mb) ma diff --git a/src/Rel8/Expr/Order.hs b/src/Rel8/Expr/Order.hs index 1333fb82..fb25d40b 100644 --- a/src/Rel8/Expr/Order.hs +++ b/src/Rel8/Expr/Order.hs @@ -1,30 +1,29 @@ -{-# language DataKinds #-} +{-# LANGUAGE DataKinds #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -{-# options_ghc -fno-warn-redundant-constraints #-} - -module Rel8.Expr.Order - ( asc - , desc - , nullsFirst - , nullsLast - ) +module Rel8.Expr.Order ( + asc, + desc, + nullsFirst, + nullsLast, +) where -- base -import Data.Bifunctor ( first ) +import Data.Bifunctor (first) import Prelude -- opaleye -import Opaleye.Internal.HaskellDB.PrimQuery ( OrderOp( orderDirection, orderNulls ) ) +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 ( toPrimExpr ) -import Rel8.Order ( Order( Order ) ) -import Rel8.Type.Ord ( DBOrd ) +import Rel8.Expr (Expr) +import Rel8.Expr.Null (unsafeUnnullify) +import Rel8.Expr.Opaleye (toPrimExpr) +import Rel8.Order (Order (Order)) +import Rel8.Type.Ord (DBOrd) -- | Sort a column in ascending order. @@ -32,10 +31,11 @@ asc :: DBOrd a => Order (Expr a) asc = Order $ Opaleye.Order (\expr -> [(orderOp, toPrimExpr expr)]) where orderOp :: Opaleye.OrderOp - orderOp = Opaleye.OrderOp - { orderDirection = Opaleye.OpAsc - , orderNulls = Opaleye.NullsLast - } + orderOp = + Opaleye.OrderOp + { orderDirection = Opaleye.OpAsc + , orderNulls = Opaleye.NullsLast + } -- | Sort a column in descending order. @@ -43,27 +43,30 @@ desc :: DBOrd a => Order (Expr a) desc = Order $ Opaleye.Order (\expr -> [(orderOp, toPrimExpr expr)]) where orderOp :: Opaleye.OrderOp - orderOp = Opaleye.OrderOp - { orderDirection = Opaleye.OpDesc - , orderNulls = Opaleye.NullsFirst - } + orderOp = + Opaleye.OrderOp + { orderDirection = Opaleye.OpDesc + , orderNulls = Opaleye.NullsFirst + } --- | Transform an ordering so that @null@ values appear first. This corresponds --- to @NULLS FIRST@ in SQL. +{- | Transform an ordering so that @null@ values appear first. This corresponds +to @NULLS FIRST@ in SQL. +-} 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 } + g orderOp = orderOp{Opaleye.orderNulls = Opaleye.NullsFirst} --- | Transform an ordering so that @null@ values appear first. This corresponds --- to @NULLS LAST@ in SQL. +{- | Transform an ordering so that @null@ values appear first. This corresponds +to @NULLS LAST@ in SQL. +-} 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 } + g orderOp = orderOp{Opaleye.orderNulls = Opaleye.NullsLast} diff --git a/src/Rel8/Expr/Sequence.hs b/src/Rel8/Expr/Sequence.hs index 66e437f1..16117f89 100644 --- a/src/Rel8/Expr/Sequence.hs +++ b/src/Rel8/Expr/Sequence.hs @@ -1,20 +1,20 @@ -module Rel8.Expr.Sequence - ( nextval - ) +module Rel8.Expr.Sequence ( + nextval, +) where -- base -import Data.Int ( Int64 ) +import Data.Int (Int64) import Prelude -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Expr.Function ( function ) -import Rel8.Expr.Serialize ( litExpr ) -import Rel8.Expr.Text ( quoteIdent ) +import Rel8.Expr (Expr) +import Rel8.Expr.Function (function) +import Rel8.Expr.Serialize (litExpr) +import Rel8.Expr.Text (quoteIdent) -- text -import Data.Text ( pack ) +import Data.Text (pack) -- | See https://www.postgresql.org/docs/current/functions-sequence.html diff --git a/src/Rel8/Expr/Serialize.hs b/src/Rel8/Expr/Serialize.hs index a2c66578..613db2e3 100644 --- a/src/Rel8/Expr/Serialize.hs +++ b/src/Rel8/Expr/Serialize.hs @@ -1,12 +1,12 @@ -{-# language FlexibleContexts #-} -{-# language NamedFieldPuns #-} -{-# language TypeFamilies #-} - -module Rel8.Expr.Serialize - ( litExpr - , slitExpr - , sparseValue - ) +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} + +module Rel8.Expr.Serialize ( + litExpr, + slitExpr, + sparseValue, +) where -- base @@ -19,23 +19,24 @@ import qualified Hasql.Decoders as Hasql import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye -- rel8 -import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) ) -import Rel8.Expr.Opaleye ( scastExpr ) -import Rel8.Schema.Null ( Unnullify, Nullity( Null, NotNull ), Sql, nullable ) -import Rel8.Type ( DBType, typeInformation ) -import Rel8.Type.Information ( TypeInformation(..) ) +import {-# SOURCE #-} Rel8.Expr (Expr (Expr)) +import Rel8.Expr.Opaleye (scastExpr) +import Rel8.Schema.Null (Nullity (NotNull, Null), Sql, Unnullify, nullable) +import Rel8.Type (DBType, typeInformation) +import Rel8.Type.Information (TypeInformation (..)) --- | Produce an expression from a literal. --- --- Note that you can usually use 'Rel8.lit', but @litExpr@ can solve problems --- of inference in polymorphic code. +{- | Produce an expression from a literal. + +Note that you can usually use 'Rel8.lit', but @litExpr@ can solve problems +of inference in polymorphic code. +-} litExpr :: Sql DBType a => a -> Expr a litExpr = slitExpr nullable typeInformation slitExpr :: Nullity a -> TypeInformation (Unnullify a) -> a -> Expr a -slitExpr nullity info@TypeInformation {encode} = +slitExpr nullity info@TypeInformation{encode} = scastExpr info . Expr . encoder where encoder = case nullity of @@ -44,6 +45,6 @@ slitExpr nullity info@TypeInformation {encode} = sparseValue :: Nullity a -> TypeInformation (Unnullify a) -> Hasql.Row a -sparseValue nullity TypeInformation {decode} = case nullity of +sparseValue nullity TypeInformation{decode} = case nullity of Null -> Hasql.column $ Hasql.nullable decode NotNull -> Hasql.column $ Hasql.nonNullable decode diff --git a/src/Rel8/Expr/Text.hs b/src/Rel8/Expr/Text.hs index f2a21039..302db27f 100644 --- a/src/Rel8/Expr/Text.hs +++ b/src/Rel8/Expr/Text.hs @@ -1,40 +1,73 @@ -{-# 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, translate - - -- * @LIKE@ and @ILIKE@ - , like, ilike - ) +{-# 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, + translate, + + -- * @LIKE@ and @ILIKE@ + like, + ilike, +) where -- base -import Data.Bool ( Bool ) -import Data.Int ( Int32 ) -import Data.Maybe ( Maybe( Nothing, Just ) ) -import Prelude ( flip ) +import Data.Bool (Bool) +import Data.Int (Int32) +import Data.Maybe (Maybe (Just, Nothing)) +import Prelude (flip) -- bytestring -import Data.ByteString ( ByteString ) +import Data.ByteString (ByteString) -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Expr.Function ( binaryOperator, function, nullaryFunction ) +import Rel8.Expr (Expr) +import Rel8.Expr.Function (binaryOperator, function, nullaryFunction) -- text import Data.Text (Text) @@ -43,43 +76,57 @@ 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 --- | Matches regular expression, case sensitive --- --- Corresponds to the @~.@ operator. +Corresponds to the @~.@ operator. +-} (~.) :: Expr Text -> Expr Text -> Expr Bool (~.) = binaryOperator "~." + + infix 2 ~. --- | Matches regular expression, case insensitive --- --- Corresponds to the @~*@ operator. +{- | Matches regular expression, case insensitive + +Corresponds to the @~*@ operator. +-} (~*) :: Expr Text -> Expr Text -> Expr Bool (~*) = binaryOperator "~*" + + infix 2 ~* --- | Does not match regular expression, case sensitive --- --- Corresponds to the @!~@ operator. +{- | Does not match regular expression, case sensitive + +Corresponds to the @!~@ operator. +-} (!~) :: Expr Text -> Expr Text -> Expr Bool (!~) = binaryOperator "!~" + + infix 2 !~ --- | Does not match regular expression, case insensitive --- --- Corresponds to the @!~*@ operator. +{- | Does not match regular expression, case insensitive + +Corresponds to the @!~*@ operator. +-} (!~*) :: Expr Text -> Expr Text -> Expr Bool (!~*) = binaryOperator "!~*" + + infix 2 !~* @@ -212,15 +259,24 @@ quoteNullable = function "quote_nullable" -- | Corresponds to the @regexp_replace@ function. -regexpReplace :: () - => Expr Text -> Expr Text -> Expr Text -> Maybe (Expr Text) -> Expr Text +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 -- | Corresponds to the @regexp_split_to_array@ function. -regexpSplitToArray :: () - => Expr Text -> Expr Text -> Maybe (Expr Text) -> Expr [Text] +regexpSplitToArray :: + () => + Expr Text -> + Expr Text -> + Maybe (Expr Text) -> + Expr [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 @@ -278,19 +334,21 @@ translate :: Expr Text -> Expr Text -> Expr Text -> Expr Text translate = function "translate" --- | @like x y@ corresponds to the expression @y LIKE x@. --- --- Note that the arguments to @like@ are swapped. This is to aid currying, so --- you can write expressions like --- @filter (like "Rel%" . packageName) =<< each haskellPackages@ +{- | @like x y@ corresponds to the expression @y LIKE x@. + +Note that the arguments to @like@ are swapped. This is to aid currying, so +you can write expressions like +@filter (like "Rel%" . packageName) =<< each haskellPackages@ +-} like :: Expr Text -> Expr Text -> Expr Bool like = flip (binaryOperator "LIKE") --- | @ilike x y@ corresponds to the expression @y ILIKE x@. --- --- Note that the arguments to @ilike@ are swapped. This is to aid currying, so --- you can write expressions like --- @filter (ilike "Rel%" . packageName) =<< each haskellPackages@ +{- | @ilike x y@ corresponds to the expression @y ILIKE x@. + +Note that the arguments to @ilike@ are swapped. This is to aid currying, so +you can write expressions like +@filter (ilike "Rel%" . packageName) =<< each haskellPackages@ +-} ilike :: Expr Text -> Expr Text -> Expr Bool ilike = flip (binaryOperator "ILIKE") diff --git a/src/Rel8/Expr/Time.hs b/src/Rel8/Expr/Time.hs index c5ad08cf..e412cf42 100644 --- a/src/Rel8/Expr/Time.hs +++ b/src/Rel8/Expr/Time.hs @@ -1,42 +1,49 @@ -module Rel8.Expr.Time - ( -- * Working with @Day@ - today - , toDay - , fromDay - , addDays - , diffDays - , subtractDays - - -- * Working with @UTCTime@ - , now - , addTime - , diffTime - , subtractTime +module Rel8.Expr.Time ( + -- * Working with @Day@ + today, + toDay, + fromDay, + addDays, + diffDays, + subtractDays, + + -- * Working with @UTCTime@ + now, + addTime, + diffTime, + subtractTime, -- * Working with @CalendarDiffTime@ - , scaleInterval - , second, seconds - , minute, minutes - , hour, hours - , day, days - , week, weeks - , month, months - , year, years - ) where + scaleInterval, + second, + seconds, + minute, + minutes, + hour, + hours, + day, + days, + week, + weeks, + month, + months, + year, + years, +) where -- base -import Data.Int ( Int32 ) +import Data.Int (Int32) import Prelude -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Expr.Function ( binaryOperator, nullaryFunction ) -import Rel8.Expr.Opaleye ( castExpr, unsafeCastExpr, unsafeLiteral ) +import Rel8.Expr (Expr) +import Rel8.Expr.Function (binaryOperator, nullaryFunction) +import Rel8.Expr.Opaleye (castExpr, unsafeCastExpr, unsafeLiteral) -- time -import Data.Time.Calendar ( Day ) -import Data.Time.Clock ( UTCTime ) -import Data.Time.LocalTime ( CalendarDiffTime ) +import Data.Time.Calendar (Day) +import Data.Time.Clock (UTCTime) +import Data.Time.LocalTime (CalendarDiffTime) -- | Corresponds to @date(now())@. @@ -64,7 +71,7 @@ diffDays :: Expr Day -> Expr Day -> Expr Int32 diffDays = binaryOperator "-" --- | Subtract a given number of days from a particular 'Day'. +-- | Subtract a given number of days from a particular 'Day'. subtractDays :: Expr Int32 -> Expr Day -> Expr Day subtractDays = flip (binaryOperator "-") @@ -129,7 +136,7 @@ day = singleton "day" -- | Create a literal interval from a number of days. -days :: Expr Double -> Expr CalendarDiffTime +days :: Expr Double -> Expr CalendarDiffTime days = (`scaleInterval` day) @@ -139,7 +146,7 @@ week = singleton "week" -- | Create a literal interval from a number of weeks. -weeks :: Expr Double -> Expr CalendarDiffTime +weeks :: Expr Double -> Expr CalendarDiffTime weeks = (`scaleInterval` week) @@ -149,7 +156,7 @@ month = singleton "month" -- | Create a literal interval from a number of months. -months :: Expr Double -> Expr CalendarDiffTime +months :: Expr Double -> Expr CalendarDiffTime months = (`scaleInterval` month) @@ -159,7 +166,7 @@ year = singleton "year" -- | Create a literal interval from a number of years. -years :: Expr Double -> Expr CalendarDiffTime +years :: Expr Double -> Expr CalendarDiffTime years = (`scaleInterval` year) diff --git a/src/Rel8/Expr/Window.hs b/src/Rel8/Expr/Window.hs index ad18f028..ba61bef3 100644 --- a/src/Rel8/Expr/Window.hs +++ b/src/Rel8/Expr/Window.hs @@ -1,21 +1,26 @@ -module Rel8.Expr.Window - ( cumulative - , rowNumber - , rank - , denseRank - , percentRank - , cumeDist - , ntile - , lag, lagOn - , lead, leadOn - , firstValue, firstValueOn - , lastValue, lastValueOn - , nthValue, nthValueOn - ) +module Rel8.Expr.Window ( + cumulative, + rowNumber, + rank, + denseRank, + percentRank, + cumeDist, + ntile, + lag, + lagOn, + lead, + leadOn, + firstValue, + firstValueOn, + lastValue, + lastValueOn, + nthValue, + nthValueOn, +) where -- base -import Data.Int ( Int32, Int64 ) +import Data.Int (Int32, Int64) import Prelude -- opaleye @@ -29,16 +34,17 @@ import Data.Profunctor (dimap, lmap) -- rel8 import Rel8.Aggregate (Aggregator' (Aggregator)) -import Rel8.Expr ( Expr ) -import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr, toColumn, toPrimExpr ) -import Rel8.Schema.Null ( Nullify ) -import Rel8.Window ( Window( Window ) ) +import Rel8.Expr (Expr) +import Rel8.Expr.Opaleye (fromColumn, fromPrimExpr, toColumn, toPrimExpr) +import Rel8.Schema.Null (Nullify) +import Rel8.Window (Window (Window)) --- | 'cumulative' allows the use of aggregation functions in 'Window' --- expressions. In particular, @'cumulative' 'Rel8.sum'@ --- (when combined with 'Rel8.Window.orderPartitionBy') gives a running total, --- also known as a \"cumulative sum\", hence the name @cumulative@. +{- | 'cumulative' allows the use of aggregation functions in 'Window' +expressions. In particular, @'cumulative' 'Rel8.sum'@ +(when combined with 'Rel8.Window.orderPartitionBy') gives a running total, +also known as a \"cumulative sum\", hence the name @cumulative@. +-} cumulative :: Aggregator' fold i a -> Window i a cumulative f = fromWindowFunction $ Opaleye.aggregatorWindowFunction (fromAggregate f) id @@ -71,8 +77,10 @@ cumeDist = fromWindowFunction $ fromPrimExpr . fromColumn <$> Opaleye.cumeDist -- | [@ntile(num_buckets)@](https://www.postgresql.org/docs/current/functions-window.html) ntile :: Expr Int32 -> Window i (Expr Int32) -ntile buckets = fromWindowFunction $ fromPrimExpr . fromColumn <$> - Opaleye.ntile (toColumn (toPrimExpr buckets)) +ntile buckets = + fromWindowFunction $ + fromPrimExpr . fromColumn + <$> Opaleye.ntile (toColumn (toPrimExpr buckets)) -- | [@lag(value, offset, default)@](https://www.postgresql.org/docs/current/functions-window.html) @@ -105,7 +113,9 @@ leadOn offset def f = lmap f (lead offset def) firstValue :: Window (Expr a) (Expr a) firstValue = fromWindowFunction $ - dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) + dimap + (toColumn . toPrimExpr) + (fromPrimExpr . fromColumn) Opaleye.firstValue @@ -118,7 +128,9 @@ firstValueOn f = lmap f firstValue lastValue :: Window (Expr a) (Expr a) lastValue = fromWindowFunction $ - dimap (toColumn . toPrimExpr) (fromPrimExpr . fromColumn) + dimap + (toColumn . toPrimExpr) + (fromPrimExpr . fromColumn) Opaleye.lastValue diff --git a/src/Rel8/FCF.hs b/src/Rel8/FCF.hs index 97a5c471..c99b10c8 100644 --- a/src/Rel8/FCF.hs +++ b/src/Rel8/FCF.hs @@ -1,16 +1,17 @@ -{-# language DataKinds #-} -{-# language PolyKinds #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeFamilies #-} - -module Rel8.FCF - ( Exp, Eval - , Id - ) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} + +module Rel8.FCF ( + Exp, + Eval, + Id, +) where -- base -import Data.Kind ( Type ) +import Data.Kind (Type) import Prelude () diff --git a/src/Rel8/Generic/Construction.hs b/src/Rel8/Generic/Construction.hs index cec92825..81446f29 100644 --- a/src/Rel8/Generic/Construction.hs +++ b/src/Rel8/Generic/Construction.hs @@ -1,71 +1,94 @@ -{-# language AllowAmbiguousTypes #-} -{-# language ConstraintKinds #-} -{-# language DataKinds #-} -{-# language FlexibleContexts #-} -{-# language NamedFieldPuns #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeApplications #-} -{-# language TypeFamilies #-} -{-# language TypeOperators #-} -{-# language UndecidableInstances #-} -{-# language ViewPatterns #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} -module Rel8.Generic.Construction - ( GGBuildable - , GGBuild, ggbuild - , GGConstructable - , GGConstruct, ggconstruct - , GGDeconstruct, ggdeconstruct, ggdeconstructA - , GGName, ggname - ) +module Rel8.Generic.Construction ( + GGBuildable, + GGBuild, + ggbuild, + GGConstructable, + GGConstruct, + ggconstruct, + GGDeconstruct, + ggdeconstruct, + ggdeconstructA, + GGName, + ggname, +) where -- base -import Data.Bifunctor ( first ) +import Data.Bifunctor (first) import Data.Functor ((<&>)) -import Data.Kind ( Constraint, Type ) -import Data.List.NonEmpty ( NonEmpty( (:|) ) ) -import GHC.TypeLits ( Symbol ) +import Data.Kind (Constraint, Type) +import Data.List.NonEmpty (NonEmpty ((:|))) +import GHC.TypeLits (Symbol) import Prelude -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Expr.Eq ( (==.) ) -import Rel8.Expr.Null ( nullify, snull, unsafeUnnullify ) -import Rel8.Expr.Serialize ( litExpr ) -import Rel8.FCF ( Eval, Exp, Id ) -import Rel8.Generic.Construction.ADT - ( GConstructorADT, GMakeableADT, gmakeADT - , GConstructableADT - , GBuildADT, gbuildADT - , GConstructADT, gconstructADT, gdeconstructADT - , RepresentableConstructors, GConstructors, gcindex, gctabulate - , RepresentableFields, gftabulate - ) -import Rel8.Generic.Construction.Record - ( GConstructor - , GConstructable, GConstruct, gconstruct, gdeconstruct - , Representable, gindex, gtabulate - ) -import Rel8.Generic.Table ( GGColumns ) -import Rel8.Kind.Algebra - ( SAlgebra( SProduct, SSum ) - , KnownAlgebra, algebraSing - ) +import Rel8.Expr (Expr) +import Rel8.Expr.Eq ((==.)) +import Rel8.Expr.Null (nullify, snull, unsafeUnnullify) +import Rel8.Expr.Serialize (litExpr) +import Rel8.FCF (Eval, Exp, Id) +import Rel8.Generic.Construction.ADT ( + GBuildADT, + GConstructADT, + GConstructableADT, + GConstructorADT, + GConstructors, + GMakeableADT, + RepresentableConstructors, + RepresentableFields, + gbuildADT, + gcindex, + gconstructADT, + gctabulate, + gdeconstructADT, + gftabulate, + gmakeADT, + ) +import Rel8.Generic.Construction.Record ( + GConstruct, + GConstructable, + GConstructor, + Representable, + gconstruct, + gdeconstruct, + gindex, + gtabulate, + ) +import Rel8.Generic.Table (GGColumns) +import Rel8.Kind.Algebra ( + KnownAlgebra, + SAlgebra (SProduct, SSum), + algebraSing, + ) import qualified Rel8.Kind.Algebra as K -import Rel8.Schema.HTable ( HTable ) -import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) ) +import Rel8.Schema.HTable (HTable) +import Rel8.Schema.HTable.Identity (HIdentity (HIdentity)) import qualified Rel8.Schema.Kind as K -import Rel8.Schema.Name ( Name( Name ) ) -import Rel8.Schema.Null ( Nullity( Null, NotNull ) ) -import Rel8.Schema.Spec ( Spec( Spec, nullity, info ) ) -import Rel8.Table - ( TTable, TColumns - , Table, fromColumns, toColumns - ) -import Rel8.Table.Bool ( case_ ) -import Rel8.Type.Tag ( Tag ) +import Rel8.Schema.Name (Name (Name)) +import Rel8.Schema.Null (Nullity (NotNull, Null)) +import Rel8.Schema.Spec (Spec (Spec, info, nullity)) +import Rel8.Table ( + TColumns, + TTable, + Table, + fromColumns, + toColumns, + ) +import Rel8.Table.Bool (case_) +import Rel8.Type.Tag (Tag) -- semigroupoids import Data.Functor.Apply (Apply) @@ -103,36 +126,39 @@ type family GGBuild algebra name rep r where GConstruct Id (GConstructorADT name (Eval (rep Expr))) r -ggbuild :: forall algebra name rep a. GGBuildable algebra name rep - => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a) - -> GGBuild algebra name rep a +ggbuild :: + forall algebra name rep a. + GGBuildable algebra name rep => + (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a) -> + GGBuild algebra name rep a ggbuild gfromColumns = case algebraSing @algebra of SProduct -> gtabulate @Id @(Eval (rep Expr)) @a $ - gfromColumns . - gconstruct - @(TTable Expr) - @TColumns - @Id - @Expr - @(Eval (rep Expr)) - (const toColumns) + gfromColumns + . gconstruct + @(TTable Expr) + @TColumns + @Id + @Expr + @(Eval (rep Expr)) + (const toColumns) SSum -> gtabulate @Id @(GConstructorADT name (Eval (rep Expr))) @a $ - gfromColumns . - gmakeADT - @(TTable Expr) - @TColumns - @Id - @Expr - @name - @(Eval (rep Expr)) - (const toColumns) - (\Spec {info} -> snull info) - (\Spec {nullity} -> case nullity of - Null -> id - NotNull -> nullify) - (HIdentity . litExpr) + gfromColumns + . gmakeADT + @(TTable Expr) + @TColumns + @Id + @Expr + @name + @(Eval (rep Expr)) + (const toColumns) + (\Spec{info} -> snull info) + ( \Spec{nullity} -> case nullity of + Null -> id + NotNull -> nullify + ) + (HIdentity . litExpr) type GGConstructable :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Constraint @@ -169,36 +195,40 @@ type family GGConstruct algebra rep r where GGConstruct 'K.Sum rep r = GConstructADT Id (Eval (rep Expr)) r r -ggconstruct :: forall algebra rep a. GGConstructable algebra rep - => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a) - -> GGConstruct algebra rep a -> a +ggconstruct :: + forall algebra rep a. + GGConstructable algebra rep => + (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a) -> + GGConstruct algebra rep a -> + a ggconstruct gfromColumns f = case algebraSing @algebra of SProduct -> f $ - gtabulate @Id @(Eval (rep Expr)) @a $ - gfromColumns . - gconstruct - @(TTable Expr) - @TColumns - @Id - @Expr - @(Eval (rep Expr)) - (const toColumns) + gtabulate @Id @(Eval (rep Expr)) @a $ + gfromColumns + . gconstruct + @(TTable Expr) + @TColumns + @Id + @Expr + @(Eval (rep Expr)) + (const toColumns) SSum -> gcindex @Id @(Eval (rep Expr)) @a f $ - fmap gfromColumns $ - gconstructADT - @(TTable Expr) - @TColumns - @Id - @Expr - @(Eval (rep Expr)) - (const toColumns) - (\Spec {info} -> snull info) - (\Spec {nullity} -> case nullity of - Null -> id - NotNull -> nullify) - (HIdentity . litExpr) + fmap gfromColumns $ + gconstructADT + @(TTable Expr) + @TColumns + @Id + @Expr + @(Eval (rep Expr)) + (const toColumns) + (\Spec{info} -> snull info) + ( \Spec{nullity} -> case nullity of + Null -> id + NotNull -> nullify + ) + (HIdentity . litExpr) type GGDeconstruct :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type -> Type @@ -209,20 +239,22 @@ type family GGDeconstruct algebra rep a r where GConstructADT Id (Eval (rep Expr)) r (a -> r) -ggdeconstruct :: forall algebra rep a r. (GGConstructable algebra rep, Table Expr r) - => (a -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr) - -> GGDeconstruct algebra rep a r +ggdeconstruct :: + forall algebra rep a r. + (GGConstructable algebra rep, Table Expr r) => + (a -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr) -> + GGDeconstruct algebra rep a r ggdeconstruct gtoColumns = case algebraSing @algebra of SProduct -> \build -> - gindex @Id @(Eval (rep Expr)) @r build . - gdeconstruct - @(TTable Expr) - @TColumns - @Id - @Expr - @(Eval (rep Expr)) - (const fromColumns) . - gtoColumns + gindex @Id @(Eval (rep Expr)) @r build + . gdeconstruct + @(TTable Expr) + @TColumns + @Id + @Expr + @(Eval (rep Expr)) + (const fromColumns) + . gtoColumns SSum -> gctabulate @Id @(Eval (rep Expr)) @r @(a -> r) $ \constructors as -> let @@ -234,31 +266,34 @@ ggdeconstruct gtoColumns = case algebraSing @algebra of @Expr @(Eval (rep Expr)) (const fromColumns) - (\Spec {nullity} -> case nullity of - Null -> id - NotNull -> unsafeUnnullify) - constructors $ - gtoColumns as - in + ( \Spec{nullity} -> case nullity of + Null -> id + NotNull -> unsafeUnnullify + ) + constructors + $ gtoColumns as + in case cases of ((_, r) :| (map (first ((tag ==.) . litExpr)) -> cases')) -> case_ cases' r -ggdeconstructA :: forall algebra rep a f r. (GGConstructable algebra rep, Apply f, Table Expr r) - => (a -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr) - -> GGDeconstruct algebra rep a (f r) +ggdeconstructA :: + forall algebra rep a f r. + (GGConstructable algebra rep, Apply f, Table Expr r) => + (a -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr) -> + GGDeconstruct algebra rep a (f r) ggdeconstructA gtoColumns = case algebraSing @algebra of SProduct -> \build -> - gindex @Id @(Eval (rep Expr)) @(f r) build . - gdeconstruct - @(TTable Expr) - @TColumns - @Id - @Expr - @(Eval (rep Expr)) - (const fromColumns) . - gtoColumns + gindex @Id @(Eval (rep Expr)) @(f r) build + . gdeconstruct + @(TTable Expr) + @TColumns + @Id + @Expr + @(Eval (rep Expr)) + (const fromColumns) + . gtoColumns SSum -> gctabulate @Id @(Eval (rep Expr)) @(f r) @(a -> f r) $ \constructors as -> let @@ -270,13 +305,14 @@ ggdeconstructA gtoColumns = case algebraSing @algebra of @Expr @(Eval (rep Expr)) (const fromColumns) - (\Spec {nullity} -> case nullity of - Null -> id - NotNull -> unsafeUnnullify) - constructors $ - gtoColumns as + ( \Spec{nullity} -> case nullity of + Null -> id + NotNull -> unsafeUnnullify + ) + constructors + $ gtoColumns as fcases = traverse1 sequence1 cases - in + in fcases <&> \((_, r) :| (map (first ((tag ==.) . litExpr)) -> cases')) -> case_ cases' r @@ -288,29 +324,31 @@ type family GGName algebra rep a where GGName 'K.Sum rep a = Name Tag -> GBuildADT Id (Eval (rep Name)) a -ggname :: forall algebra rep a. GGConstructable algebra rep - => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Name -> a) - -> GGName algebra rep a +ggname :: + forall algebra rep a. + GGConstructable algebra rep => + (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Name -> a) -> + GGName algebra rep a ggname gfromColumns = case algebraSing @algebra of SProduct -> gtabulate @Id @(Eval (rep Name)) @a $ - gfromColumns . - gconstruct - @(TTable Name) - @TColumns - @Id - @Name - @(Eval (rep Name)) - (const toColumns) + gfromColumns + . gconstruct + @(TTable Name) + @TColumns + @Id + @Name + @(Eval (rep Name)) + (const toColumns) SSum -> \tag -> gftabulate @Id @(Eval (rep Name)) @a $ - gfromColumns . - gbuildADT - @(TTable Name) - @TColumns - @Id - @Name - @(Eval (rep Name)) - (const toColumns) - (\_ _ (Name a) -> Name a) - (HIdentity tag) + gfromColumns + . gbuildADT + @(TTable Name) + @TColumns + @Id + @Name + @(Eval (rep Name)) + (const toColumns) + (\_ _ (Name a) -> Name a) + (HIdentity tag) diff --git a/src/Rel8/Generic/Construction/ADT.hs b/src/Rel8/Generic/Construction/ADT.hs index f5cc0cf8..78d62cb3 100644 --- a/src/Rel8/Generic/Construction/ADT.hs +++ b/src/Rel8/Generic/Construction/ADT.hs @@ -1,66 +1,92 @@ -{-# language AllowAmbiguousTypes #-} -{-# language BlockArguments #-} -{-# language DataKinds #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language MultiParamTypeClasses #-} -{-# language RankNTypes #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language TupleSections #-} -{-# language TypeApplications #-} -{-# language TypeFamilies #-} -{-# language TypeOperators #-} -{-# language UndecidableInstances #-} - -module Rel8.Generic.Construction.ADT - ( GConstructableADT - , GBuildADT, gbuildADT, gunbuildADT - , GConstructADT, gconstructADT, gdeconstructADT - , GFields, RepresentableFields, gftabulate, gfindex - , GConstructors, RepresentableConstructors, gctabulate, gcindex - , GConstructorADT, GMakeableADT, gmakeADT - ) +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Rel8.Generic.Construction.ADT ( + GConstructableADT, + GBuildADT, + gbuildADT, + gunbuildADT, + GConstructADT, + gconstructADT, + gdeconstructADT, + GFields, + RepresentableFields, + gftabulate, + gfindex, + GConstructors, + RepresentableConstructors, + gctabulate, + gcindex, + GConstructorADT, + GMakeableADT, + gmakeADT, +) where -- base -import Data.Bifunctor ( first ) -import Data.Functor.Identity ( runIdentity ) -import Data.Kind ( Constraint, Type ) -import Data.List.NonEmpty ( NonEmpty ) -import Data.Proxy ( Proxy( Proxy ) ) -import GHC.Generics - ( (:+:), (:*:)( (:*:) ), M1, U1 - , C, D - , Meta( MetaData, MetaCons ) - ) -import GHC.TypeLits - ( ErrorMessage( (:<>:), Text ), TypeError - , Symbol, KnownSymbol, symbolVal - ) -import Prelude hiding ( null ) +import Data.Bifunctor (first) +import Data.Functor.Identity (runIdentity) +import Data.Kind (Constraint, Type) +import Data.List.NonEmpty (NonEmpty) +import Data.Proxy (Proxy (Proxy)) +import GHC.Generics ( + C, + D, + M1, + Meta (MetaCons, MetaData), + U1, + (:*:) ((:*:)), + (:+:), + ) +import GHC.TypeLits ( + ErrorMessage (Text, (:<>:)), + KnownSymbol, + Symbol, + TypeError, + symbolVal, + ) +import Prelude hiding (null) -- rel8 -import Rel8.FCF ( Exp ) -import Rel8.Generic.Construction.Record - ( GConstruct, GConstructable, gconstruct, gdeconstruct - , GFields, Representable, gtabulate, gindex - , FromColumns, ToColumns - ) -import Rel8.Generic.Table.ADT ( GColumnsADT, GColumnsADT' ) -import Rel8.Generic.Table.Record ( GColumns ) -import Rel8.Schema.HTable ( HTable ) -import Rel8.Schema.HTable.Identity ( HIdentity ) -import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel ) -import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify ) -import Rel8.Schema.HTable.Product ( HProduct( HProduct ) ) -import Rel8.Schema.Null ( Nullify ) -import Rel8.Schema.Spec ( Spec ) +import Rel8.FCF (Exp) +import Rel8.Generic.Construction.Record ( + FromColumns, + GConstruct, + GConstructable, + GFields, + Representable, + ToColumns, + gconstruct, + gdeconstruct, + gindex, + gtabulate, + ) +import Rel8.Generic.Table.ADT (GColumnsADT, GColumnsADT') +import Rel8.Generic.Table.Record (GColumns) +import Rel8.Schema.HTable (HTable) +import Rel8.Schema.HTable.Identity (HIdentity) +import Rel8.Schema.HTable.Label (HLabel, hlabel, hunlabel) +import Rel8.Schema.HTable.Nullify (HNullify, hnullify, hnulls, hunnullify) +import Rel8.Schema.HTable.Product (HProduct (HProduct)) import qualified Rel8.Schema.Kind as K -import Rel8.Type.Tag ( Tag( Tag ) ) +import Rel8.Schema.Null (Nullify) +import Rel8.Schema.Spec (Spec) +import Rel8.Type.Tag (Tag (Tag)) -- text -import Data.Text ( pack ) +import Data.Text (pack) type Null :: K.Context -> Type @@ -77,11 +103,11 @@ type Unnullifier context = forall a. Spec a -> context (Nullify a) -> context a type NoConstructor :: Symbol -> Symbol -> ErrorMessage type NoConstructor datatype constructor = - ( 'Text "The type `" ':<>: - 'Text datatype ':<>: - 'Text "` has no constructor `" ':<>: - 'Text constructor ':<>: - 'Text "`." + ( 'Text "The type `" + ':<>: 'Text datatype + ':<>: 'Text "` has no constructor `" + ':<>: 'Text constructor + ':<>: 'Text "`." ) @@ -101,9 +127,12 @@ type family GConstructorADT' name rep fallback where GConstructorADT' _ _ fallback = fallback -type GConstructADT - :: (Type -> Exp Type) - -> (Type -> Type) -> Type -> Type -> Type +type GConstructADT :: + (Type -> Exp Type) -> + (Type -> Type) -> + Type -> + Type -> + Type type family GConstructADT f rep r x where GConstructADT f (M1 D _ rep) r x = GConstructADT f rep r x GConstructADT f (a :+: b) r x = GConstructADT f a r (GConstructADT f b r x) @@ -128,9 +157,10 @@ instance RepresentableConstructors f rep => RepresentableConstructors f (M1 D me gcindex = gcindex @f @rep -instance (RepresentableConstructors f a, RepresentableConstructors f b) => +instance + (RepresentableConstructors f a, RepresentableConstructors f b) => RepresentableConstructors f (a :+: b) - where + where gctabulate f = gctabulate @f @a \a -> gctabulate @f @b \b -> f (a :*: b) gcindex f (a :*: b) = gcindex @f @b (gcindex @f @a f a) b @@ -177,100 +207,127 @@ instance Representable f rep => RepresentableFields f (M1 C meta rep) where gfindex = gindex @f @rep -type GConstructableADT - :: (Type -> Exp Constraint) - -> (Type -> Exp K.HTable) - -> (Type -> Exp Type) - -> K.Context -> (Type -> Type) -> Constraint +type GConstructableADT :: + (Type -> Exp Constraint) -> + (Type -> Exp K.HTable) -> + (Type -> Exp Type) -> + K.Context -> + (Type -> Type) -> + Constraint class GConstructableADT _Table _Columns f context rep where - gbuildADT :: () - => ToColumns _Table _Columns f context - -> (Tag -> Nullifier context) - -> HIdentity Tag context - -> GFieldsADT f rep - -> GColumnsADT _Columns rep context - - gunbuildADT :: () - => FromColumns _Table _Columns f context - -> Unnullifier context - -> GColumnsADT _Columns rep context - -> (HIdentity Tag context, GFieldsADT f rep) - - gconstructADT :: () - => ToColumns _Table _Columns f context - -> Null context - -> Nullifier context - -> (Tag -> HIdentity Tag context) - -> GConstructors f rep (GColumnsADT _Columns rep context) - - gdeconstructADT :: () - => FromColumns _Table _Columns f context - -> Unnullifier context - -> GConstructors f rep r - -> GColumnsADT _Columns rep context - -> (HIdentity Tag context, NonEmpty (Tag, r)) + gbuildADT :: + () => + ToColumns _Table _Columns f context -> + (Tag -> Nullifier context) -> + HIdentity Tag context -> + GFieldsADT f rep -> + GColumnsADT _Columns rep context + + + gunbuildADT :: + () => + FromColumns _Table _Columns f context -> + Unnullifier context -> + GColumnsADT _Columns rep context -> + (HIdentity Tag context, GFieldsADT f rep) + + + gconstructADT :: + () => + ToColumns _Table _Columns f context -> + Null context -> + Nullifier context -> + (Tag -> HIdentity Tag context) -> + GConstructors f rep (GColumnsADT _Columns rep context) + + + gdeconstructADT :: + () => + FromColumns _Table _Columns f context -> + Unnullifier context -> + GConstructors f rep r -> + GColumnsADT _Columns rep context -> + (HIdentity Tag context, NonEmpty (Tag, r)) instance ( htable ~ HLabel "tag" (HIdentity Tag) , GConstructableADT' _Table _Columns f context htable rep - ) - => GConstructableADT _Table _Columns f context (M1 D meta rep) - where + ) => + GConstructableADT _Table _Columns f context (M1 D meta rep) + where gbuildADT toColumns nullifier = - gbuildADT' @_Table @_Columns @f @context @htable @rep toColumns nullifier . - hlabel + gbuildADT' @_Table @_Columns @f @context @htable @rep toColumns nullifier + . hlabel + gunbuildADT fromColumns unnullifier = - first hunlabel . - gunbuildADT' @_Table @_Columns @f @context @htable @rep fromColumns unnullifier + first hunlabel + . gunbuildADT' @_Table @_Columns @f @context @htable @rep fromColumns unnullifier + gconstructADT toColumns null nullifier mk = - gconstructADT' @_Table @_Columns @f @context @htable @rep toColumns null nullifier + gconstructADT' @_Table @_Columns @f @context @htable @rep + toColumns + null + nullifier (hlabel . mk) + gdeconstructADT fromColumns unnullifier cases = - first hunlabel . - gdeconstructADT' @_Table @_Columns @f @context @htable @rep fromColumns unnullifier cases + first hunlabel + . gdeconstructADT' @_Table @_Columns @f @context @htable @rep fromColumns unnullifier cases + + +type GConstructableADT' :: + (Type -> Exp Constraint) -> + (Type -> Exp K.HTable) -> + (Type -> Exp Type) -> + K.Context -> + K.HTable -> + (Type -> Type) -> + Constraint +class GConstructableADT' _Table _Columns f context htable rep where + gbuildADT' :: + () => + ToColumns _Table _Columns f context -> + (Tag -> Nullifier context) -> + htable context -> + GFieldsADT f rep -> + GColumnsADT' _Columns htable rep context -type GConstructableADT' - :: (Type -> Exp Constraint) - -> (Type -> Exp K.HTable) - -> (Type -> Exp Type) - -> K.Context -> K.HTable -> (Type -> Type) -> Constraint -class GConstructableADT' _Table _Columns f context htable rep where - gbuildADT' :: () - => ToColumns _Table _Columns f context - -> (Tag -> Nullifier context) - -> htable context - -> GFieldsADT f rep - -> GColumnsADT' _Columns htable rep context - - gunbuildADT' :: () - => FromColumns _Table _Columns f context - -> Unnullifier context - -> GColumnsADT' _Columns htable rep context - -> (htable context, GFieldsADT f rep) - - gconstructADT' :: () - => ToColumns _Table _Columns f context - -> Null context - -> Nullifier context - -> (Tag -> htable context) - -> GConstructors f rep (GColumnsADT' _Columns htable rep context) - - gdeconstructADT' :: () - => FromColumns _Table _Columns f context - -> Unnullifier context - -> GConstructors f rep r - -> GColumnsADT' _Columns htable rep context - -> (htable context, NonEmpty (Tag, r)) - - gfill :: () - => Null context - -> htable context - -> GColumnsADT' _Columns htable rep context + gunbuildADT' :: + () => + FromColumns _Table _Columns f context -> + Unnullifier context -> + GColumnsADT' _Columns htable rep context -> + (htable context, GFieldsADT f rep) + + + gconstructADT' :: + () => + ToColumns _Table _Columns f context -> + Null context -> + Nullifier context -> + (Tag -> htable context) -> + GConstructors f rep (GColumnsADT' _Columns htable rep context) + + + gdeconstructADT' :: + () => + FromColumns _Table _Columns f context -> + Unnullifier context -> + GConstructors f rep r -> + GColumnsADT' _Columns htable rep context -> + (htable context, NonEmpty (Tag, r)) + + + gfill :: + () => + Null context -> + htable context -> + GColumnsADT' _Columns htable rep context instance @@ -278,23 +335,28 @@ instance , Functor (GConstructors f a) , GConstructableADT' _Table _Columns f context htable a , GConstructableADT' _Table _Columns f context htable' b - ) - => GConstructableADT' _Table _Columns f context htable (a :+: b) - where + ) => + GConstructableADT' _Table _Columns f context htable (a :+: b) + where gbuildADT' toColumns nullifier htable (a, b) = - gbuildADT' @_Table @_Columns @f @context @htable' @b toColumns nullifier + gbuildADT' @_Table @_Columns @f @context @htable' @b + toColumns + nullifier (gbuildADT' @_Table @_Columns @f @context @htable @a toColumns nullifier htable a) b + gunbuildADT' fromColumns unnullifier columns = case gunbuildADT' @_Table @_Columns @f @context @htable' @b fromColumns unnullifier columns of (htable', b) -> case gunbuildADT' @_Table @_Columns @f @context @htable @a fromColumns unnullifier htable' of (htable, a) -> (htable, (a, b)) + gconstructADT' toColumns null nullifier mk = - fmap (gfill @_Table @_Columns @f @context @htable' @b null) (gconstructADT' @_Table @_Columns @f @context @htable @a toColumns null nullifier mk) :*: - gconstructADT' @_Table @_Columns @f @context @htable' @b toColumns null nullifier (gfill @_Table @_Columns @f @context @htable @a null . mk) + fmap (gfill @_Table @_Columns @f @context @htable' @b null) (gconstructADT' @_Table @_Columns @f @context @htable @a toColumns null nullifier mk) + :*: gconstructADT' @_Table @_Columns @f @context @htable' @b toColumns null nullifier (gfill @_Table @_Columns @f @context @htable @a null . mk) + gdeconstructADT' fromColumns unnullifier (a :*: b) columns = case gdeconstructADT' @_Table @_Columns @f @context @htable' @b fromColumns unnullifier b columns of @@ -302,16 +364,18 @@ instance case gdeconstructADT' @_Table @_Columns @f @context @htable @a fromColumns unnullifier a htable' of (htable, cases') -> (htable, cases' <> cases) + gfill null = - gfill @_Table @_Columns @f @context @htable' @b null . - gfill @_Table @_Columns @f @context @htable @a null + gfill @_Table @_Columns @f @context @htable' @b null + . gfill @_Table @_Columns @f @context @htable @a null -instance (meta ~ 'MetaCons label _fixity _isRecord, KnownSymbol label) => +instance + (meta ~ 'MetaCons label _fixity _isRecord, KnownSymbol label) => GConstructableADT' _Table _Columns f context htable (M1 C meta U1) - where + where gbuildADT' _ _ = const - gunbuildADT' _ _ = (, ()) + gunbuildADT' _ _ = (,()) gconstructADT' _ _ _ f _ = f tag where tag = Tag $ pack $ symbolVal (Proxy @label) @@ -321,70 +385,80 @@ instance (meta ~ 'MetaCons label _fixity _isRecord, KnownSymbol label) => gfill _ = id -instance {-# OVERLAPPABLE #-} +instance + {-# OVERLAPPABLE #-} ( HTable (GColumns _Columns rep) , KnownSymbol label , meta ~ 'MetaCons label _fixity _isRecord , GConstructable _Table _Columns f context rep - , GColumnsADT' _Columns htable (M1 C meta rep) ~ - HProduct htable (HLabel label (HNullify (GColumns _Columns rep))) - ) - => GConstructableADT' _Table _Columns f context htable (M1 C meta rep) - where + , GColumnsADT' _Columns htable (M1 C meta rep) + ~ HProduct htable (HLabel label (HNullify (GColumns _Columns rep))) + ) => + GConstructableADT' _Table _Columns f context htable (M1 C meta rep) + where gbuildADT' toColumns nullifier htable = - HProduct htable . - hlabel . - hnullify (nullifier tag) . - gconstruct @_Table @_Columns @f @context @rep toColumns + HProduct htable + . hlabel + . hnullify (nullifier tag) + . gconstruct @_Table @_Columns @f @context @rep toColumns where tag = Tag $ pack $ symbolVal (Proxy @label) + gunbuildADT' fromColumns unnullifier (HProduct htable a) = ( htable , gdeconstruct @_Table @_Columns @f @context @rep fromColumns $ runIdentity $ - hunnullify (\spec -> pure . unnullifier spec) $ - hunlabel - a + hunnullify (\spec -> pure . unnullifier spec) $ + hunlabel + a ) + gconstructADT' toColumns _ nullifier mk = - HProduct htable . - hlabel . - hnullify nullifier . - gconstruct @_Table @_Columns @f @context @rep toColumns + HProduct htable + . hlabel + . hnullify nullifier + . gconstruct @_Table @_Columns @f @context @rep toColumns where tag = Tag $ pack $ symbolVal (Proxy @label) htable = mk tag + gdeconstructADT' fromColumns unnullifier r (HProduct htable columns) = ( htable , pure (tag, r a) ) where - a = gdeconstruct @_Table @_Columns @f @context @rep fromColumns $ - runIdentity $ - hunnullify (\spec -> pure . unnullifier spec) $ - hunlabel - columns + a = + gdeconstruct @_Table @_Columns @f @context @rep fromColumns $ + runIdentity $ + hunnullify (\spec -> pure . unnullifier spec) $ + hunlabel + columns tag = Tag $ pack $ symbolVal (Proxy @label) + gfill null htable = HProduct htable (hlabel (hnulls null)) -type GMakeableADT - :: (Type -> Exp Constraint) - -> (Type -> Exp K.HTable) - -> (Type -> Exp Type) - -> K.Context -> Symbol -> (Type -> Type) -> Constraint +type GMakeableADT :: + (Type -> Exp Constraint) -> + (Type -> Exp K.HTable) -> + (Type -> Exp Type) -> + K.Context -> + Symbol -> + (Type -> Type) -> + Constraint class GMakeableADT _Table _Columns f context name rep where - gmakeADT :: () - => ToColumns _Table _Columns f context - -> Null context - -> Nullifier context - -> (Tag -> HIdentity Tag context) - -> GFields f (GConstructorADT name rep) - -> GColumnsADT _Columns rep context + gmakeADT :: + () => + ToColumns _Table _Columns f context -> + Null context -> + Nullifier context -> + (Tag -> HIdentity Tag context) -> + GFields f (GConstructorADT name rep) -> + GColumnsADT _Columns rep context instance @@ -394,85 +468,113 @@ instance , fields ~ GFields f (GConstructorADT' name rep fallback) , GMakeableADT' _Table _Columns f context htable name rep fields , KnownSymbol name - ) - => GMakeableADT _Table _Columns f context name (M1 D meta rep) - where + ) => + GMakeableADT _Table _Columns f context name (M1 D meta rep) + where gmakeADT toColumns null nullifier wrap = gmakeADT' - @_Table @_Columns @f @context @htable @name @rep @fields - toColumns null nullifier htable + @_Table + @_Columns + @f + @context + @htable + @name + @rep + @fields + toColumns + null + nullifier + htable where tag = Tag $ pack $ symbolVal (Proxy @name) htable = hlabel (wrap tag) -type GMakeableADT' - :: (Type -> Exp Constraint) - -> (Type -> Exp K.HTable) - -> (Type -> Exp Type) - -> K.Context -> K.HTable -> Symbol -> (Type -> Type) -> Type -> Constraint +type GMakeableADT' :: + (Type -> Exp Constraint) -> + (Type -> Exp K.HTable) -> + (Type -> Exp Type) -> + K.Context -> + K.HTable -> + Symbol -> + (Type -> Type) -> + Type -> + Constraint class GMakeableADT' _Table _Columns f context htable name rep fields where - gmakeADT' :: () - => ToColumns _Table _Columns f context - -> Null context - -> Nullifier context - -> htable context - -> fields - -> GColumnsADT' _Columns htable rep context + gmakeADT' :: + () => + ToColumns _Table _Columns f context -> + Null context -> + Nullifier context -> + htable context -> + fields -> + GColumnsADT' _Columns htable rep context instance ( htable' ~ GColumnsADT' _Columns htable a , GMakeableADT' _Table _Columns f context htable name a fields , GMakeableADT' _Table _Columns f context htable' name b fields - ) - => GMakeableADT' _Table _Columns f context htable name (a :+: b) fields - where + ) => + GMakeableADT' _Table _Columns f context htable name (a :+: b) fields + where gmakeADT' toColumns null nullifier htable x = gmakeADT' @_Table @_Columns @f @context @htable' @name @b @fields - toColumns null nullifier - (gmakeADT' - @_Table @_Columns @f @context @htable @name @a @fields toColumns - null nullifier htable x) + toColumns + null + nullifier + ( gmakeADT' + @_Table + @_Columns + @f + @context + @htable + @name + @a + @fields + toColumns + null + nullifier + htable + x + ) x -instance {-# OVERLAPPING #-} - GMakeableADT' _Table _Columns f context htable name (M1 C ('MetaCons name _fixity _isRecord) U1) fields - where +instance {-# OVERLAPPING #-} GMakeableADT' _Table _Columns f context htable name (M1 C ('MetaCons name _fixity _isRecord) U1) fields where gmakeADT' _ _ _ = const -instance {-# OVERLAPS #-} - GMakeableADT' _Table _Columns f context htable name (M1 C ('MetaCons label _fixity _isRecord) U1) fields - where +instance {-# OVERLAPS #-} GMakeableADT' _Table _Columns f context htable name (M1 C ('MetaCons label _fixity _isRecord) U1) fields where gmakeADT' _ _ _ = const -instance {-# OVERLAPS #-} +instance + {-# OVERLAPS #-} ( HTable (GColumns _Columns rep) , GConstructable _Table _Columns f context rep , fields ~ GFields f rep - , GColumnsADT' _Columns htable (M1 C ('MetaCons name _fixity _isRecord) rep) ~ - HProduct htable (HLabel name (HNullify (GColumns _Columns rep))) - ) - => GMakeableADT' _Table _Columns f context htable name (M1 C ('MetaCons name _fixity _isRecord) rep) fields - where + , GColumnsADT' _Columns htable (M1 C ('MetaCons name _fixity _isRecord) rep) + ~ HProduct htable (HLabel name (HNullify (GColumns _Columns rep))) + ) => + GMakeableADT' _Table _Columns f context htable name (M1 C ('MetaCons name _fixity _isRecord) rep) fields + where gmakeADT' toColumns _ nullifier htable = - HProduct htable . - hlabel . - hnullify nullifier . - gconstruct @_Table @_Columns @f @context @rep toColumns + HProduct htable + . hlabel + . hnullify nullifier + . gconstruct @_Table @_Columns @f @context @rep toColumns -instance {-# OVERLAPPABLE #-} +instance + {-# OVERLAPPABLE #-} ( HTable (GColumns _Columns rep) - , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) rep) ~ - HProduct htable (HLabel label (HNullify (GColumns _Columns rep))) - ) - => GMakeableADT' _Table _Columns f context htable name (M1 C ('MetaCons label _fixity _isRecord) rep) fields - where + , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) rep) + ~ HProduct htable (HLabel label (HNullify (GColumns _Columns rep))) + ) => + GMakeableADT' _Table _Columns f context htable name (M1 C ('MetaCons label _fixity _isRecord) rep) fields + where gmakeADT' _ null _ htable _ = HProduct htable $ - hlabel $ - hnulls null + hlabel $ + hnulls null diff --git a/src/Rel8/Generic/Construction/Record.hs b/src/Rel8/Generic/Construction/Record.hs index 9350b442..3de83fb4 100644 --- a/src/Rel8/Generic/Construction/Record.hs +++ b/src/Rel8/Generic/Construction/Record.hs @@ -1,72 +1,96 @@ -{-# language AllowAmbiguousTypes #-} -{-# language BlockArguments #-} -{-# language DataKinds #-} -{-# language FlexibleInstances #-} -{-# language MultiParamTypeClasses #-} -{-# language RankNTypes #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeApplications #-} -{-# language TypeFamilies #-} -{-# language TypeOperators #-} -{-# language UndecidableInstances #-} - -module Rel8.Generic.Construction.Record - ( GConstructor, GConstruct, GConstructable, gconstruct, gdeconstruct - , GFields, Representable, gtabulate, gindex - , FromColumns, ToColumns - ) +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Rel8.Generic.Construction.Record ( + GConstructor, + GConstruct, + GConstructable, + gconstruct, + gdeconstruct, + GFields, + Representable, + gtabulate, + gindex, + FromColumns, + ToColumns, +) where -- base -import Data.Kind ( Constraint, Type ) -import Data.Proxy ( Proxy( Proxy ) ) -import GHC.Generics - ( (:*:), K1, M1, U1 - , D, C, S, Meta( MetaData, MetaCons, MetaSel ) - ) -import GHC.TypeLits - ( ErrorMessage( (:<>:), Text ), TypeError - , Symbol - ) +import Data.Kind (Constraint, Type) +import Data.Proxy (Proxy (Proxy)) +import GHC.Generics ( + C, + D, + K1, + M1, + Meta (MetaCons, MetaData, MetaSel), + S, + U1, + (:*:), + ) +import GHC.TypeLits ( + ErrorMessage (Text, (:<>:)), + Symbol, + TypeError, + ) import Prelude -- rel8 -import Rel8.FCF ( Eval, Exp ) -import Rel8.Generic.Table.Record ( GColumns ) -import Rel8.Schema.HTable.Label ( hlabel, hunlabel ) -import Rel8.Schema.HTable.Product ( HProduct( HProduct ) ) +import Rel8.FCF (Eval, Exp) +import Rel8.Generic.Table.Record (GColumns) +import Rel8.Schema.HTable.Label (hlabel, hunlabel) +import Rel8.Schema.HTable.Product (HProduct (HProduct)) import qualified Rel8.Schema.Kind as K -type FromColumns - :: (Type -> Exp Constraint) - -> (Type -> Exp K.HTable) - -> (Type -> Exp Type) - -> K.Context - -> Type -type FromColumns _Table _Columns f context = forall proxy x. - Eval (_Table x) => proxy x -> Eval (_Columns x) context -> Eval (f x) - - -type ToColumns - :: (Type -> Exp Constraint) - -> (Type -> Exp K.HTable) - -> (Type -> Exp Type) - -> K.Context - -> Type -type ToColumns _Table _Columns f context = forall proxy x. - Eval (_Table x) => proxy x -> Eval (f x) -> Eval (_Columns x) context +type FromColumns :: + (Type -> Exp Constraint) -> + (Type -> Exp K.HTable) -> + (Type -> Exp Type) -> + K.Context -> + Type +type FromColumns _Table _Columns f context = + forall proxy x. + Eval (_Table x) => + proxy x -> + Eval (_Columns x) context -> + Eval (f x) + + +type ToColumns :: + (Type -> Exp Constraint) -> + (Type -> Exp K.HTable) -> + (Type -> Exp Type) -> + K.Context -> + Type +type ToColumns _Table _Columns f context = + forall proxy x. + Eval (_Table x) => + proxy x -> + Eval (f x) -> + Eval (_Columns x) context type GConstructor :: (Type -> Type) -> Symbol type family GConstructor rep where GConstructor (M1 D _ (M1 C ('MetaCons name _ _) _)) = name - GConstructor (M1 D ('MetaData name _ _ _) _) = TypeError ( - 'Text "`" ':<>: - 'Text name ':<>: - 'Text "` does not appear to have exactly 1 constructor" - ) + GConstructor (M1 D ('MetaData name _ _ _) _) = + TypeError + ( 'Text "`" + ':<>: 'Text name + ':<>: 'Text "` does not appear to have exactly 1 constructor" + ) type GConstruct :: (Type -> Exp Type) -> (Type -> Type) -> Type -> Type @@ -96,9 +120,10 @@ instance Representable f rep => Representable f (M1 i meta rep) where gindex = gindex @f @rep -instance (Representable f a, Representable f b) => +instance + (Representable f a, Representable f b) => Representable f (a :*: b) - where + where gtabulate f = gtabulate @f @a \a -> gtabulate @f @b \b -> f (a, b) gindex f (a, b) = gindex @f @b (gindex @f @a f a) b @@ -113,32 +138,38 @@ instance Representable f (K1 i a) where gindex = id -type GConstructable - :: (Type -> Exp Constraint) - -> (Type -> Exp K.HTable) - -> (Type -> Exp Type) - -> K.Context -> (Type -> Type) -> Constraint +type GConstructable :: + (Type -> Exp Constraint) -> + (Type -> Exp K.HTable) -> + (Type -> Exp Type) -> + K.Context -> + (Type -> Type) -> + Constraint class GConstructable _Table _Columns f context rep where - gconstruct :: () - => ToColumns _Table _Columns f context - -> GFields f rep - -> GColumns _Columns rep context - gdeconstruct :: () - => FromColumns _Table _Columns f context - -> GColumns _Columns rep context - -> GFields f rep + gconstruct :: + () => + ToColumns _Table _Columns f context -> + GFields f rep -> + GColumns _Columns rep context + gdeconstruct :: + () => + FromColumns _Table _Columns f context -> + GColumns _Columns rep context -> + GFields f rep -instance (GConstructable _Table _Columns f context rep) => +instance + (GConstructable _Table _Columns f context rep) => GConstructable _Table _Columns f context (M1 D meta rep) - where + where gconstruct = gconstruct @_Table @_Columns @f @context @rep gdeconstruct = gdeconstruct @_Table @_Columns @f @context @rep -instance (GConstructable _Table _Columns f context rep) => +instance + (GConstructable _Table _Columns f context rep) => GConstructable _Table _Columns f context (M1 C meta rep) - where + where gconstruct = gconstruct @_Table @_Columns @f @context @rep gdeconstruct = gdeconstruct @_Table @_Columns @f @context @rep @@ -146,12 +177,13 @@ instance (GConstructable _Table _Columns f context rep) => instance ( GConstructable _Table _Columns f context a , GConstructable _Table _Columns f context b - ) - => GConstructable _Table _Columns f context (a :*: b) - where - gconstruct toColumns (a, b) = HProduct - (gconstruct @_Table @_Columns @f @context @a toColumns a) - (gconstruct @_Table @_Columns @f @context @b toColumns b) + ) => + GConstructable _Table _Columns f context (a :*: b) + where + gconstruct toColumns (a, b) = + HProduct + (gconstruct @_Table @_Columns @f @context @a toColumns a) + (gconstruct @_Table @_Columns @f @context @b toColumns b) gdeconstruct fromColumns (HProduct a b) = ( gdeconstruct @_Table @_Columns @f @context @a fromColumns a , gdeconstruct @_Table @_Columns @f @context @b fromColumns b @@ -161,8 +193,8 @@ instance instance ( Eval (_Table a) , meta ~ 'MetaSel ('Just label) _su _ss _ds - ) - => GConstructable _Table _Columns f context (M1 S meta (K1 i a)) - where + ) => + GConstructable _Table _Columns f context (M1 S meta (K1 i a)) + where gconstruct toColumns = hlabel . toColumns (Proxy @a) gdeconstruct fromColumns = fromColumns (Proxy @a) . hunlabel diff --git a/src/Rel8/Generic/Map.hs b/src/Rel8/Generic/Map.hs index 5395626b..84b8acb8 100644 --- a/src/Rel8/Generic/Map.hs +++ b/src/Rel8/Generic/Map.hs @@ -1,24 +1,29 @@ -{-# language DataKinds #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeFamilies #-} -{-# language TypeOperators #-} -{-# language UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -module Rel8.Generic.Map - ( GMap - , Map - ) +module Rel8.Generic.Map ( + GMap, + Map, +) where -- base -import Data.Kind ( Type ) -import GHC.Generics - ( (:+:), (:*:), K1, M1, U1, V1 - ) +import Data.Kind (Type) +import GHC.Generics ( + K1, + M1, + U1, + V1, + (:*:), + (:+:), + ) import Prelude () -- rel8 -import Rel8.FCF ( Eval, Exp ) +import Rel8.FCF (Eval, Exp) type GMap :: (Type -> Exp Type) -> (Type -> Type) -> Type -> Type @@ -31,15 +36,27 @@ type family GMap f rep where GMap f (K1 i a) = K1 i (Eval (f a)) --- | Map a @Type -> Type@ function over the @Type@-kinded type variables in --- of a type constructor. +{- | Map a @Type -> Type@ function over the @Type@-kinded type variables in +of a type constructor. +-} type Map :: (Type -> Exp Type) -> Type -> Type type family Map f a where Map p (t a b c d e f g) = - t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d)) (Eval (p e)) - (Eval (p f)) (Eval (p g)) + t + (Eval (p a)) + (Eval (p b)) + (Eval (p c)) + (Eval (p d)) + (Eval (p e)) + (Eval (p f)) + (Eval (p g)) Map p (t a b c d e f) = - t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d)) (Eval (p e)) + t + (Eval (p a)) + (Eval (p b)) + (Eval (p c)) + (Eval (p d)) + (Eval (p e)) (Eval (p f)) Map p (t a b c d e) = t (Eval (p a)) (Eval (p b)) (Eval (p c)) (Eval (p d)) (Eval (p e)) diff --git a/src/Rel8/Generic/Record.hs b/src/Rel8/Generic/Record.hs index b0e83546..6817bf5c 100644 --- a/src/Rel8/Generic/Record.hs +++ b/src/Rel8/Generic/Record.hs @@ -1,31 +1,42 @@ -{-# language AllowAmbiguousTypes #-} -{-# language DataKinds #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language MultiParamTypeClasses #-} -{-# language PolyKinds #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeApplications #-} -{-# language TypeFamilies #-} -{-# language TypeOperators #-} -{-# language UndecidableInstances #-} - -module Rel8.Generic.Record - ( Record(..) - , GRecordable, GRecord, grecord, gunrecord - ) +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Rel8.Generic.Record ( + Record (..), + GRecordable, + GRecord, + grecord, + gunrecord, +) where -- base -import Data.Kind ( Constraint, Type ) -import GHC.Generics - ( Generic, Rep, from, to - , (:+:)( L1, R1 ), (:*:)( (:*:) ), M1( M1 ) - , Meta( MetaCons, MetaSel ), D, C, S - ) -import GHC.TypeLits ( type (+), AppendSymbol, Div, Mod, Nat, Symbol ) -import Prelude hiding ( Show ) +import Data.Kind (Constraint, Type) +import GHC.Generics ( + C, + D, + Generic, + M1 (M1), + Meta (MetaCons, MetaSel), + Rep, + S, + from, + to, + (:*:) ((:*:)), + (:+:) (L1, R1), + ) +import GHC.TypeLits (AppendSymbol, Div, Mod, Nat, Symbol, type (+)) +import Prelude hiding (Show) type GRecord :: (Type -> Type) -> Type -> Type @@ -103,9 +114,10 @@ instance (GRecordable l, GRecordable r) => GRecordable (l :+: r) where gunrecord (R1 a) = R1 (gunrecord a) -instance Countable 0 rep => +instance + Countable 0 rep => GRecordable (M1 C ('MetaCons name fixity 'False) rep) - where + where grecord (M1 a) = M1 (count @0 a) gunrecord (M1 a) = M1 (uncount @0 a) @@ -127,12 +139,13 @@ instance Countable n (M1 S ('MetaSel selector su ss ds) rep) where instance - ( Countable n a, Countable n' b + ( Countable n a + , Countable n' b , '(n', a') ~ Count n a , Snd (CountHelper2 a' (Count n' b)) ~ (a' :*: Snd (Count n' b)) - ) - => Countable n (a :*: b) - where + ) => + Countable n (a :*: b) + where count (a :*: b) = count @n a :*: count @n' b uncount (a :*: b) = uncount @n a :*: uncount @n' b @@ -151,5 +164,6 @@ newtype Record a = Record instance (Generic a, GRecordable (Rep a)) => Generic (Record a) where type Rep (Record a) = GRecord (Rep a) + from (Record a) = grecord (from a) to = Record . to . gunrecord diff --git a/src/Rel8/Generic/Rel8able.hs b/src/Rel8/Generic/Rel8able.hs index 25faaead..d813aa02 100644 --- a/src/Rel8/Generic/Rel8able.hs +++ b/src/Rel8/Generic/Rel8able.hs @@ -1,57 +1,71 @@ -{-# language AllowAmbiguousTypes #-} -{-# language ConstraintKinds #-} -{-# language DataKinds #-} -{-# language DefaultSignatures #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language LambdaCase #-} -{-# language MultiParamTypeClasses #-} -{-# language PolyKinds #-} -{-# language QuantifiedConstraints #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeApplications #-} -{-# language TypeFamilyDependencies #-} -{-# language TypeOperators #-} -{-# language UndecidableInstances #-} - -module Rel8.Generic.Rel8able - ( KRel8able, Rel8able - , Algebra - , GRep - , GColumns, gfromColumns, gtoColumns - , GFromExprs, gfromResult, gtoResult - , TSerialize, serialize, deserialize - ) +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Rel8.Generic.Rel8able ( + KRel8able, + Rel8able, + Algebra, + GRep, + GColumns, + gfromColumns, + gtoColumns, + GFromExprs, + gfromResult, + gtoResult, + TSerialize, + serialize, + deserialize, +) where -- base -import Data.Functor.Identity ( Identity ) -import Data.Kind ( Constraint, Type ) -import Data.Type.Bool ( type (&&) ) -import GHC.Generics ( Generic, Rep, from, to ) +import Data.Functor.Identity (Identity) +import Data.Kind (Constraint, Type) +import Data.Type.Bool (type (&&)) +import GHC.Generics (Generic, Rep, from, to) import Prelude -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.FCF ( Exp, Eval ) -import Rel8.Generic.Record ( Record(..) ) -import Rel8.Generic.Table ( GAlgebra ) +import Rel8.Expr (Expr) +import Rel8.FCF (Eval, Exp) +import Rel8.Generic.Record (Record (..)) +import Rel8.Generic.Table (GAlgebra) import qualified Rel8.Generic.Table.Record as G -import qualified Rel8.Kind.Algebra as K ( Algebra(..) ) -import Rel8.Kind.Context ( SContext(..) ) -import Rel8.Schema.Field ( Field ) -import Rel8.Schema.HTable ( HTable ) +import qualified Rel8.Kind.Algebra as K (Algebra (..)) +import Rel8.Kind.Context (SContext (..)) +import Rel8.Schema.Field (Field) +import Rel8.Schema.HTable (HTable) import qualified Rel8.Schema.Kind as K -import Rel8.Schema.Name ( Name ) -import Rel8.Schema.Result ( Result ) -import Rel8.Table - ( Table, Columns, Context, fromColumns, toColumns - , FromExprs, fromResult, toResult - , Transpose - , TTable, TColumns - ) -import Rel8.Table.Transpose ( Transposes ) +import Rel8.Schema.Name (Name) +import Rel8.Schema.Result (Result) +import Rel8.Table ( + Columns, + Context, + FromExprs, + TColumns, + TTable, + Table, + Transpose, + fromColumns, + fromResult, + toColumns, + toResult, + ) +import Rel8.Table.Transpose (Transposes) -- | The kind of 'Rel8able' types @@ -66,12 +80,10 @@ type family a == b where -- KRel8able), which occurs when we have polymorphic Rel8ables -- (e.g., newtype T t f = T { x :: t a }) (a :: KRel8able) == (a :: KRel8able) = 'True - - -- This extra case is needed to solve the equation "a == Identity a", - -- which occurs when we have polymorphic Rel8ables + -- This extra case is needed to solve the equation "a == Identity a", + -- which occurs when we have polymorphic Rel8ables -- (e.g., newtype T a f = T { x :: Column f a }) a == Identity a = 'False - -- These cases are exactly the same as those in 'Data.Type.Equality.==. f a == g b = f == g && a == b a == a = 'True @@ -79,9 +91,10 @@ type family a == b where type Serialize :: Bool -> Type -> Type -> Constraint -class transposition ~ (a == Transpose Result expr) => +class + transposition ~ (a == Transpose Result expr) => Serialize transposition expr a - where + where serialize :: a -> Columns expr Result deserialize :: Columns expr Result -> a @@ -89,9 +102,9 @@ class transposition ~ (a == Transpose Result expr) => instance ( (a == Transpose Result expr) ~ 'True , Transposes Expr Result expr a - ) - => Serialize 'True expr a - where + ) => + Serialize 'True expr a + where serialize = toColumns deserialize = fromColumns @@ -100,106 +113,125 @@ instance ( (a == Transpose Result expr) ~ 'False , Table (Context expr) expr , FromExprs expr ~ a - ) - => Serialize 'False expr a - where + ) => + Serialize 'False expr a + where serialize = toResult @_ @expr deserialize = fromResult @_ @expr data TSerialize :: Type -> Type -> Exp Constraint -type instance Eval (TSerialize expr a) = - Serialize (a == Transpose Result expr) expr a - - --- | This type class allows you to define custom 'Table's using higher-kinded --- data types. Higher-kinded data types are data types of the pattern: --- --- @ --- data MyType f = --- MyType { field1 :: Column f T1 OR HK1 f --- , field2 :: Column f T2 OR HK2 f --- , ... --- , fieldN :: Column f Tn OR HKn f --- } --- @ --- --- where @Tn@ is any Haskell type, and @HKn@ is any higher-kinded type. --- --- That is, higher-kinded data are records where all fields in the record are --- all either of the type @Column f T@ (for any @T@), or are themselves --- higher-kinded data: --- --- [Nested] --- --- @ --- data Nested f = --- Nested { nested1 :: MyType f --- , nested2 :: MyType f --- } --- @ --- --- The @Rel8able@ type class is used to give us a special mapping operation --- that lets us change the type parameter @f@. --- --- [Supplying @Rel8able@ instances] --- --- This type class should be derived generically for all table types in your --- project. To do this, enable the @DeriveAnyClass@ and @DeriveGeneric@ language --- extensions: --- --- @ --- \{\-\# LANGUAGE DeriveAnyClass, DeriveGeneric #-\} --- --- data MyType f = MyType { fieldA :: Column f T } --- deriving ( GHC.Generics.Generic, Rel8able ) --- @ +type instance + Eval (TSerialize expr a) = + Serialize (a == Transpose Result expr) expr a + + +{- | This type class allows you to define custom 'Table's using higher-kinded +data types. Higher-kinded data types are data types of the pattern: + +@ +data MyType f = + MyType { field1 :: Column f T1 OR HK1 f + , field2 :: Column f T2 OR HK2 f + , ... + , fieldN :: Column f Tn OR HKn f + } +@ + +where @Tn@ is any Haskell type, and @HKn@ is any higher-kinded type. + +That is, higher-kinded data are records where all fields in the record are +all either of the type @Column f T@ (for any @T@), or are themselves +higher-kinded data: + +[Nested] + +@ +data Nested f = + Nested { nested1 :: MyType f + , nested2 :: MyType f + } +@ + +The @Rel8able@ type class is used to give us a special mapping operation +that lets us change the type parameter @f@. + +[Supplying @Rel8able@ instances] + +This type class should be derived generically for all table types in your +project. To do this, enable the @DeriveAnyClass@ and @DeriveGeneric@ language +extensions: + +@ +\{\-\# LANGUAGE DeriveAnyClass, DeriveGeneric #-\} + +data MyType f = MyType { fieldA :: Column f T } + deriving ( GHC.Generics.Generic, Rel8able ) +@ +-} type Rel8able :: K.Rel8able -> Constraint class HTable (GColumns t) => Rel8able t where type GColumns t :: K.HTable type GFromExprs t :: Type + gfromColumns :: SContext context -> GColumns t context -> t context gtoColumns :: SContext context -> t context -> GColumns t context + gfromResult :: GColumns t Result -> GFromExprs t gtoResult :: GFromExprs t -> GColumns t Result + type GColumns t = G.GColumns TColumns (GRep t Expr) type GFromExprs t = t Result - default gfromColumns :: forall context. + + default gfromColumns :: + forall context. ( SRel8able t Expr , forall table. SRel8able t (Field table) , SRel8able t Name , SSerialize t - ) - => SContext context -> GColumns t context -> t context + ) => + SContext context -> + GColumns t context -> + t context gfromColumns = \case SExpr -> sfromColumns SField -> sfromColumns SName -> sfromColumns SResult -> sfromResult - default gtoColumns :: forall context. + + default gtoColumns :: + forall context. ( SRel8able t Expr , forall table. SRel8able t (Field table) , SRel8able t Name , SSerialize t - ) - => SContext context -> t context -> GColumns t context + ) => + SContext context -> + t context -> + GColumns t context gtoColumns = \case SExpr -> stoColumns SField -> stoColumns SName -> stoColumns SResult -> stoResult - default gfromResult :: (SSerialize t, GFromExprs t ~ t Result) - => GColumns t Result -> GFromExprs t + + default gfromResult :: + (SSerialize t, GFromExprs t ~ t Result) => + GColumns t Result -> + GFromExprs t gfromResult = sfromResult - default gtoResult :: (SSerialize t, GFromExprs t ~ t Result) - => GFromExprs t -> GColumns t Result + + default gtoResult :: + (SSerialize t, GFromExprs t ~ t Result) => + GFromExprs t -> + GColumns t Result gtoResult = stoResult @@ -216,14 +248,14 @@ class ( Generic (Record (t context)) , G.GTable (TTable context) TColumns (GRep t context) , G.GColumns TColumns (GRep t context) ~ GColumns t - ) - => SRel8able t context + ) => + SRel8able t context instance ( Generic (Record (t context)) , G.GTable (TTable context) TColumns (GRep t context) , G.GColumns TColumns (GRep t context) ~ GColumns t - ) - => SRel8able t context + ) => + SRel8able t context type SSerialize :: K.Rel8able -> Constraint @@ -234,43 +266,55 @@ type SSerialize t = ) -sfromColumns :: forall t context. SRel8able t context - => GColumns t context -> t context +sfromColumns :: + forall t context. + SRel8able t context => + GColumns t context -> + t context sfromColumns = - unrecord . - to . - G.gfromColumns @(TTable context) @TColumns fromColumns + unrecord + . to + . G.gfromColumns @(TTable context) @TColumns fromColumns -stoColumns :: forall t context. SRel8able t context - => t context -> GColumns t context +stoColumns :: + forall t context. + SRel8able t context => + t context -> + GColumns t context stoColumns = - G.gtoColumns @(TTable context) @TColumns toColumns . - from . - Record + G.gtoColumns @(TTable context) @TColumns toColumns + . from + . Record -sfromResult :: forall t. SSerialize t - => GColumns t Result -> t Result +sfromResult :: + forall t. + SSerialize t => + GColumns t Result -> + t Result sfromResult = - unrecord . - to . - G.gfromResult - @TSerialize - @TColumns - @(GRep t Expr) - @(GRep t Result) - (\(_ :: proxy x) -> deserialize @_ @x) - - -stoResult :: forall t. SSerialize t - => t Result -> GColumns t Result + unrecord + . to + . G.gfromResult + @TSerialize + @TColumns + @(GRep t Expr) + @(GRep t Result) + (\(_ :: proxy x) -> deserialize @_ @x) + + +stoResult :: + forall t. + SSerialize t => + t Result -> + GColumns t Result stoResult = G.gtoResult @TSerialize @TColumns @(GRep t Expr) @(GRep t Result) - (\(_ :: proxy x) -> serialize @_ @x) . - from . - Record + (\(_ :: proxy x) -> serialize @_ @x) + . from + . Record diff --git a/src/Rel8/Generic/Table.hs b/src/Rel8/Generic/Table.hs index 98da2ea7..204f684b 100644 --- a/src/Rel8/Generic/Table.hs +++ b/src/Rel8/Generic/Table.hs @@ -1,64 +1,75 @@ -{-# language AllowAmbiguousTypes #-} -{-# language DataKinds #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language MultiParamTypeClasses #-} -{-# language RankNTypes #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeApplications #-} -{-# language TypeFamilies #-} -{-# language TypeOperators #-} -{-# language UndecidableInstances #-} - -module Rel8.Generic.Table - ( GGSerialize, GGColumns, ggfromResult, ggtoResult - , GAlgebra - ) +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Rel8.Generic.Table ( + GGSerialize, + GGColumns, + ggfromResult, + ggtoResult, + GAlgebra, +) where -- base -import Data.Kind ( Constraint, Type ) -import GHC.Generics ( (:+:), (:*:), K1, M1, U1, V1 ) +import Data.Kind (Constraint, Type) +import GHC.Generics (K1, M1, U1, V1, (:*:), (:+:)) import Prelude () -- rel8 -import Rel8.FCF ( Eval, Exp ) -import Rel8.Generic.Table.ADT - ( GSerializeADT, GColumnsADT, gtoResultADT, gfromResultADT - ) -import Rel8.Generic.Table.Record ( GSerialize, GColumns, gtoResult, gfromResult ) -import Rel8.Kind.Algebra - ( Algebra( Product, Sum ) - , SAlgebra( SProduct, SSum ) - , KnownAlgebra, algebraSing - ) +import Rel8.FCF (Eval, Exp) +import Rel8.Generic.Table.ADT ( + GColumnsADT, + GSerializeADT, + gfromResultADT, + gtoResultADT, + ) +import Rel8.Generic.Table.Record (GColumns, GSerialize, gfromResult, gtoResult) +import Rel8.Kind.Algebra ( + Algebra (Product, Sum), + KnownAlgebra, + SAlgebra (SProduct, SSum), + algebraSing, + ) import qualified Rel8.Schema.Kind as K -import Rel8.Schema.Result ( Result ) +import Rel8.Schema.Result (Result) -data GGSerialize - :: Algebra - -> (Type -> Type -> Exp Constraint) - -> (Type -> Exp K.HTable) - -> (Type -> Type) - -> (Type -> Type) - -> Exp Constraint +data + GGSerialize :: + Algebra -> + (Type -> Type -> Exp Constraint) -> + (Type -> Exp K.HTable) -> + (Type -> Type) -> + (Type -> Type) -> + Exp Constraint -type instance Eval (GGSerialize 'Product _Serialize _Columns exprs rep) = - GSerialize _Serialize _Columns exprs rep +type instance + Eval (GGSerialize 'Product _Serialize _Columns exprs rep) = + GSerialize _Serialize _Columns exprs rep -type instance Eval (GGSerialize 'Sum _Serialize _Columns exprs rep) = - GSerializeADT _Serialize _Columns exprs rep +type instance + Eval (GGSerialize 'Sum _Serialize _Columns exprs rep) = + GSerializeADT _Serialize _Columns exprs rep -data GGColumns - :: Algebra - -> (Type -> Exp K.HTable) - -> (Type -> Type) - -> Exp K.HTable +data + GGColumns :: + Algebra -> + (Type -> Exp K.HTable) -> + (Type -> Type) -> + Exp K.HTable type instance Eval (GGColumns 'Product _Columns rep) = GColumns _Columns rep @@ -77,27 +88,37 @@ type family GAlgebra rep where GAlgebra (K1 _ _) = 'Product -ggfromResult :: forall algebra _Serialize _Columns exprs rep x. +ggfromResult :: + forall algebra _Serialize _Columns exprs rep x. ( KnownAlgebra algebra , Eval (GGSerialize algebra _Serialize _Columns exprs rep) - ) - => (forall expr a proxy. Eval (_Serialize expr a) - => proxy expr -> Eval (_Columns expr) Result -> a) - -> Eval (GGColumns algebra _Columns exprs) Result - -> rep x + ) => + ( forall expr a proxy. + Eval (_Serialize expr a) => + proxy expr -> + Eval (_Columns expr) Result -> + a + ) -> + Eval (GGColumns algebra _Columns exprs) Result -> + rep x ggfromResult f x = case algebraSing @algebra of SProduct -> gfromResult @_Serialize @_Columns @exprs @rep f x SSum -> gfromResultADT @_Serialize @_Columns @exprs @rep f x -ggtoResult :: forall algebra _Serialize _Columns exprs rep x. +ggtoResult :: + forall algebra _Serialize _Columns exprs rep x. ( KnownAlgebra algebra , Eval (GGSerialize algebra _Serialize _Columns exprs rep) - ) - => (forall expr a proxy. Eval (_Serialize expr a) - => proxy expr -> a -> Eval (_Columns expr) Result) - -> rep x - -> Eval (GGColumns algebra _Columns exprs) Result + ) => + ( forall expr a proxy. + Eval (_Serialize expr a) => + proxy expr -> + a -> + Eval (_Columns expr) Result + ) -> + rep x -> + Eval (GGColumns algebra _Columns exprs) Result ggtoResult f x = case algebraSing @algebra of SProduct -> gtoResult @_Serialize @_Columns @exprs @rep f x SSum -> gtoResultADT @_Serialize @_Columns @exprs @rep f x diff --git a/src/Rel8/Generic/Table/ADT.hs b/src/Rel8/Generic/Table/ADT.hs index b9fb8c0a..99c0934f 100644 --- a/src/Rel8/Generic/Table/ADT.hs +++ b/src/Rel8/Generic/Table/ADT.hs @@ -1,63 +1,73 @@ -{-# language AllowAmbiguousTypes #-} -{-# language DataKinds #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language LambdaCase #-} -{-# language MultiParamTypeClasses #-} -{-# language RankNTypes #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeApplications #-} -{-# language TypeFamilies #-} -{-# language TypeOperators #-} -{-# language UndecidableInstances #-} - -module Rel8.Generic.Table.ADT - ( GSerializeADT, GColumnsADT, gfromResultADT, gtoResultADT - , GSerializeADT', GColumnsADT' - ) +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Rel8.Generic.Table.ADT ( + GSerializeADT, + GColumnsADT, + gfromResultADT, + gtoResultADT, + GSerializeADT', + GColumnsADT', +) where -- base -import Data.Functor.Identity ( Identity( Identity ) ) -import Data.Kind ( Constraint, Type ) -import Data.Proxy ( Proxy( Proxy ) ) -import GHC.Generics - ( (:+:)( L1, R1 ), M1( M1 ), U1( U1 ) - , C, D - , Meta( MetaCons ) - ) -import GHC.TypeLits ( KnownSymbol, symbolVal ) -import Prelude hiding ( null ) +import Data.Functor.Identity (Identity (Identity)) +import Data.Kind (Constraint, Type) +import Data.Proxy (Proxy (Proxy)) +import GHC.Generics ( + C, + D, + M1 (M1), + Meta (MetaCons), + U1 (U1), + (:+:) (L1, R1), + ) +import GHC.TypeLits (KnownSymbol, symbolVal) +import Prelude hiding (null) -- rel8 -import Rel8.FCF ( Eval, Exp ) -import Rel8.Generic.Table.Record ( GSerialize, GColumns, gfromResult, gtoResult ) -import Rel8.Schema.HTable ( HTable ) -import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) ) -import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel ) -import Rel8.Schema.HTable.Nullify ( HNullify, hnulls, hnullify, hunnullify ) -import Rel8.Schema.HTable.Product ( HProduct( HProduct ) ) +import Rel8.FCF (Eval, Exp) +import Rel8.Generic.Table.Record (GColumns, GSerialize, gfromResult, gtoResult) +import Rel8.Schema.HTable (HTable) +import Rel8.Schema.HTable.Identity (HIdentity (HIdentity)) +import Rel8.Schema.HTable.Label (HLabel, hlabel, hunlabel) +import Rel8.Schema.HTable.Nullify (HNullify, hnullify, hnulls, hunnullify) +import Rel8.Schema.HTable.Product (HProduct (HProduct)) import qualified Rel8.Schema.Kind as K -import Rel8.Schema.Result ( Result, null, nullifier, unnullifier ) -import Rel8.Type.Tag ( Tag( Tag ) ) +import Rel8.Schema.Result (Result, null, nullifier, unnullifier) +import Rel8.Type.Tag (Tag (Tag)) -- text -import Data.Text ( pack ) +import Data.Text (pack) -type GColumnsADT - :: (Type -> Exp K.HTable) - -> (Type -> Type) -> K.HTable +type GColumnsADT :: + (Type -> Exp K.HTable) -> + (Type -> Type) -> + K.HTable type family GColumnsADT _Columns rep where GColumnsADT _Columns (M1 D _ rep) = GColumnsADT' _Columns (HLabel "tag" (HIdentity Tag)) rep -type GColumnsADT' - :: (Type -> Exp K.HTable) - -> K.HTable -> (Type -> Type) -> K.HTable -type family GColumnsADT' _Columns htable rep where +type GColumnsADT' :: + (Type -> Exp K.HTable) -> + K.HTable -> + (Type -> Type) -> + K.HTable +type family GColumnsADT' _Columns htable rep where GColumnsADT' _Columns htable (a :+: b) = GColumnsADT' _Columns (GColumnsADT' _Columns htable a) b GColumnsADT' _Columns htable (M1 C ('MetaCons _ _ _) U1) = htable @@ -65,30 +75,43 @@ type family GColumnsADT' _Columns htable rep where HProduct htable (HLabel label (HNullify (GColumns _Columns rep))) -type GSerializeADT - :: (Type -> Type -> Exp Constraint) - -> (Type -> Exp K.HTable) - -> (Type -> Type) -> (Type -> Type) -> Constraint +type GSerializeADT :: + (Type -> Type -> Exp Constraint) -> + (Type -> Exp K.HTable) -> + (Type -> Type) -> + (Type -> Type) -> + Constraint class GSerializeADT _Serialize _Columns exprs rep where - gfromResultADT :: () - => (forall expr a proxy. Eval (_Serialize expr a) - => proxy expr -> Eval (_Columns expr) Result -> a) - -> GColumnsADT _Columns exprs Result - -> rep x + gfromResultADT :: + () => + ( forall expr a proxy. + Eval (_Serialize expr a) => + proxy expr -> + Eval (_Columns expr) Result -> + a + ) -> + GColumnsADT _Columns exprs Result -> + rep x + - gtoResultADT :: () - => (forall expr a proxy. Eval (_Serialize expr a) - => proxy expr -> a -> Eval (_Columns expr) Result) - -> rep x - -> GColumnsADT _Columns exprs Result + gtoResultADT :: + () => + ( forall expr a proxy. + Eval (_Serialize expr a) => + proxy expr -> + a -> + Eval (_Columns expr) Result + ) -> + rep x -> + GColumnsADT _Columns exprs Result instance ( htable ~ HLabel "tag" (HIdentity Tag) , GSerializeADT' _Serialize _Columns htable exprs rep - ) - => GSerializeADT _Serialize _Columns (M1 D meta exprs) (M1 D meta rep) - where + ) => + GSerializeADT _Serialize _Columns (M1 D meta exprs) (M1 D meta rep) + where gfromResultADT fromResult columns = case gfromResultADT' @_Serialize @_Columns @htable @exprs @rep fromResult tag columns of Just rep -> M1 rep @@ -96,30 +119,46 @@ instance where tag = (\(HIdentity (Identity a)) -> a) . hunlabel @"tag" + gtoResultADT toResult (M1 rep) = gtoResultADT' @_Serialize @_Columns @htable @exprs @rep toResult tag (Just rep) where tag = hlabel @"tag" . HIdentity . Identity -type GSerializeADT' - :: (Type -> Type -> Exp Constraint) - -> (Type -> Exp K.HTable) - -> K.HTable -> (Type -> Type) -> (Type -> Type) -> Constraint +type GSerializeADT' :: + (Type -> Type -> Exp Constraint) -> + (Type -> Exp K.HTable) -> + K.HTable -> + (Type -> Type) -> + (Type -> Type) -> + Constraint class GSerializeADT' _Serialize _Columns htable exprs rep where - gfromResultADT' :: context ~ Result - => (forall expr a proxy. Eval (_Serialize expr a) - => proxy expr -> Eval (_Columns expr) context -> a) - -> (htable Result -> Tag) - -> GColumnsADT' _Columns htable exprs context - -> Maybe (rep x) - - gtoResultADT' :: context ~ Result - => (forall expr a proxy. Eval (_Serialize expr a) - => proxy expr -> a -> Eval (_Columns expr) context) - -> (Tag -> htable Result) - -> Maybe (rep x) - -> GColumnsADT' _Columns htable exprs context + gfromResultADT' :: + context ~ Result => + ( forall expr a proxy. + Eval (_Serialize expr a) => + proxy expr -> + Eval (_Columns expr) context -> + a + ) -> + (htable Result -> Tag) -> + GColumnsADT' _Columns htable exprs context -> + Maybe (rep x) + + + gtoResultADT' :: + context ~ Result => + ( forall expr a proxy. + Eval (_Serialize expr a) => + proxy expr -> + a -> + Eval (_Columns expr) context + ) -> + (Tag -> htable Result) -> + Maybe (rep x) -> + GColumnsADT' _Columns htable exprs context + extract :: GColumnsADT' _Columns htable exprs context -> htable context @@ -128,17 +167,18 @@ instance ( htable' ~ GColumnsADT' _Columns htable exprs1 , GSerializeADT' _Serialize _Columns htable exprs1 a , GSerializeADT' _Serialize _Columns htable' exprs2 b - ) - => GSerializeADT' _Serialize _Columns htable (exprs1 :+: exprs2) (a :+: b) - where + ) => + GSerializeADT' _Serialize _Columns htable (exprs1 :+: exprs2) (a :+: b) + where gfromResultADT' fromResult f columns = case ma of Just a -> Just (L1 a) - Nothing -> R1 <$> - gfromResultADT' @_Serialize @_Columns @_ @exprs2 @b - fromResult - (f . extract @_Serialize @_Columns @_ @exprs1 @a) - columns + Nothing -> + R1 + <$> gfromResultADT' @_Serialize @_Columns @_ @exprs2 @b + fromResult + (f . extract @_Serialize @_Columns @_ @exprs1 @a) + columns where ma = gfromResultADT' @_Serialize @_Columns @_ @exprs1 @a @@ -146,23 +186,27 @@ instance f (extract @_Serialize @_Columns @_ @exprs2 @b columns) + gtoResultADT' toResult tag = \case Just (L1 a) -> gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b toResult - (\_ -> gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a - toResult - tag - (Just a)) + ( \_ -> + gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a + toResult + tag + (Just a) + ) Nothing Just (R1 b) -> gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b toResult - (\tag' -> - gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a - toResult - (\_ -> tag tag') - Nothing) + ( \tag' -> + gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a + toResult + (\_ -> tag tag') + Nothing + ) (Just b) Nothing -> gtoResultADT' @_Serialize @_Columns @_ @exprs2 @b @@ -170,52 +214,60 @@ instance (\_ -> gtoResultADT' @_Serialize @_Columns @_ @exprs1 @a toResult tag Nothing) Nothing + extract = - extract @_Serialize @_Columns @_ @exprs1 @a . - extract @_Serialize @_Columns @_ @exprs2 @b + extract @_Serialize @_Columns @_ @exprs1 @a + . extract @_Serialize @_Columns @_ @exprs2 @b -instance (meta ~ 'MetaCons label _fixity _isRecord, KnownSymbol label) => +instance + (meta ~ 'MetaCons label _fixity _isRecord, KnownSymbol label) => GSerializeADT' _Serialize _Columns _htable (M1 C meta U1) (M1 C meta U1) - where + where gfromResultADT' _ tag columns | tag columns == tag' = Just (M1 U1) | otherwise = Nothing where tag' = Tag $ pack $ symbolVal (Proxy @label) + gtoResultADT' _ tag _ = tag tag' where tag' = Tag $ pack $ symbolVal (Proxy @label) + extract = id -instance {-# OVERLAPPABLE #-} +instance + {-# OVERLAPPABLE #-} ( HTable (GColumns _Columns exprs) , GSerialize _Serialize _Columns exprs rep , meta ~ 'MetaCons label _fixity _isRecord , KnownSymbol label - , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) exprs) ~ - HProduct htable (HLabel label (HNullify (GColumns _Columns exprs))) - ) - => GSerializeADT' _Serialize _Columns htable (M1 C meta exprs) (M1 C meta rep) - where + , GColumnsADT' _Columns htable (M1 C ('MetaCons label _fixity _isRecord) exprs) + ~ HProduct htable (HLabel label (HNullify (GColumns _Columns exprs))) + ) => + GSerializeADT' _Serialize _Columns htable (M1 C meta exprs) (M1 C meta rep) + where gfromResultADT' fromResult tag (HProduct a b) | tag a == tag' = - M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult <$> - hunnullify unnullifier (hunlabel b) + M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult + <$> hunnullify unnullifier (hunlabel b) | otherwise = Nothing where tag' = Tag $ pack $ symbolVal (Proxy @label) + gtoResultADT' toResult tag = \case Nothing -> HProduct (tag tag') (hlabel (hnulls (const null))) - Just (M1 rep) -> HProduct (tag tag') $ - hlabel $ - hnullify nullifier $ - gtoResult @_Serialize @_Columns @exprs @rep toResult rep + Just (M1 rep) -> + HProduct (tag tag') $ + hlabel $ + hnullify nullifier $ + gtoResult @_Serialize @_Columns @exprs @rep toResult rep where tag' = Tag $ pack $ symbolVal (Proxy @label) + extract (HProduct a _) = a diff --git a/src/Rel8/Generic/Table/Record.hs b/src/Rel8/Generic/Table/Record.hs index e9cfa368..c368f7c7 100644 --- a/src/Rel8/Generic/Table/Record.hs +++ b/src/Rel8/Generic/Table/Record.hs @@ -1,37 +1,48 @@ -{-# language AllowAmbiguousTypes #-} -{-# language DataKinds #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language MultiParamTypeClasses #-} -{-# language PolyKinds #-} -{-# language RankNTypes #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeApplications #-} -{-# language TypeFamilies #-} -{-# language TypeOperators #-} -{-# language UndecidableInstances #-} - -module Rel8.Generic.Table.Record - ( GTable, GColumns, GContext, gfromColumns, gtoColumns, gtable - , GSerialize, gfromResult, gtoResult - ) +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Rel8.Generic.Table.Record ( + GTable, + GColumns, + GContext, + gfromColumns, + gtoColumns, + gtable, + GSerialize, + gfromResult, + gtoResult, +) where -- base -import Data.Kind ( Constraint, Type ) -import Data.Proxy ( Proxy( Proxy ) ) -import GHC.Generics - ( (:*:)( (:*:) ), K1( K1 ), M1( M1 ) - , C, D, S - , Meta( MetaSel ) - ) -import Prelude hiding ( null ) +import Data.Kind (Constraint, Type) +import Data.Proxy (Proxy (Proxy)) +import GHC.Generics ( + C, + D, + K1 (K1), + M1 (M1), + Meta (MetaSel), + S, + (:*:) ((:*:)), + ) +import Prelude hiding (null) -- rel8 -import Rel8.FCF ( Eval, Exp ) -import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel ) -import Rel8.Schema.HTable.Product ( HProduct(..) ) +import Rel8.FCF (Eval, Exp) +import Rel8.Schema.HTable.Label (HLabel, hlabel, hunlabel) +import Rel8.Schema.HTable.Product (HProduct (..)) import qualified Rel8.Schema.Kind as K @@ -52,48 +63,64 @@ type family GContext _Context rep where GContext _Context (K1 _ a) = Eval (_Context a) -type GTable - :: (Type -> Exp Constraint) - -> (Type -> Exp K.HTable) - -> (Type -> Type) -> Constraint -class GTable _Table _Columns rep - where - gfromColumns :: () - => (forall a. Eval (_Table a) => Eval (_Columns a) context -> a) - -> GColumns _Columns rep context - -> rep x - - gtoColumns :: () - => (forall a. Eval (_Table a) => a -> Eval (_Columns a) context) - -> rep x - -> GColumns _Columns rep context - - gtable :: () - => (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context) - -> GColumns _Columns rep context - - -type GSerialize - :: (Type -> Type -> Exp Constraint) - -> (Type -> Exp K.HTable) - -> (Type -> Type) -> (Type -> Type) -> Constraint -class GSerialize _Serialize _Columns exprs rep - where - gfromResult :: () - => (forall expr a proxy. Eval (_Serialize expr a) - => proxy expr -> Eval (_Columns expr) context -> a) - -> GColumns _Columns exprs context - -> rep x - - gtoResult :: () - => (forall expr a proxy. Eval (_Serialize expr a) - => proxy expr -> a -> Eval (_Columns expr) context) - -> rep x - -> GColumns _Columns exprs context - - -instance GTable _Table _Columns rep => GTable _Table _Columns (M1 D c rep) - where +type GTable :: + (Type -> Exp Constraint) -> + (Type -> Exp K.HTable) -> + (Type -> Type) -> + Constraint +class GTable _Table _Columns rep where + gfromColumns :: + () => + (forall a. Eval (_Table a) => Eval (_Columns a) context -> a) -> + GColumns _Columns rep context -> + rep x + + + gtoColumns :: + () => + (forall a. Eval (_Table a) => a -> Eval (_Columns a) context) -> + rep x -> + GColumns _Columns rep context + + + gtable :: + () => + (forall a proxy. Eval (_Table a) => proxy a -> Eval (_Columns a) context) -> + GColumns _Columns rep context + + +type GSerialize :: + (Type -> Type -> Exp Constraint) -> + (Type -> Exp K.HTable) -> + (Type -> Type) -> + (Type -> Type) -> + Constraint +class GSerialize _Serialize _Columns exprs rep where + gfromResult :: + () => + ( forall expr a proxy. + Eval (_Serialize expr a) => + proxy expr -> + Eval (_Columns expr) context -> + a + ) -> + GColumns _Columns exprs context -> + rep x + + + gtoResult :: + () => + ( forall expr a proxy. + Eval (_Serialize expr a) => + proxy expr -> + a -> + Eval (_Columns expr) context + ) -> + rep x -> + GColumns _Columns exprs context + + +instance GTable _Table _Columns rep => GTable _Table _Columns (M1 D c rep) where gfromColumns fromColumns = M1 . gfromColumns @_Table @_Columns @rep fromColumns gtoColumns toColumns (M1 a) = @@ -101,17 +128,17 @@ instance GTable _Table _Columns rep => GTable _Table _Columns (M1 D c rep) gtable = gtable @_Table @_Columns @rep -instance GSerialize _Serialize _Columns exprs rep => +instance + GSerialize _Serialize _Columns exprs rep => GSerialize _Serialize _Columns (M1 D c exprs) (M1 D c rep) - where + where gfromResult fromResult = M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult gtoResult toResult (M1 a) = gtoResult @_Serialize @_Columns @exprs @rep toResult a -instance GTable _Table _Columns rep => GTable _Table _Columns (M1 C c rep) - where +instance GTable _Table _Columns rep => GTable _Table _Columns (M1 C c rep) where gfromColumns fromColumns = M1 . gfromColumns @_Table @_Columns @rep fromColumns gtoColumns toColumns (M1 a) = @@ -119,38 +146,42 @@ instance GTable _Table _Columns rep => GTable _Table _Columns (M1 C c rep) gtable = gtable @_Table @_Columns @rep -instance GSerialize _Serialize _Columns exprs rep => +instance + GSerialize _Serialize _Columns exprs rep => GSerialize _Serialize _Columns (M1 C c exprs) (M1 C c rep) - where + where gfromResult fromResult = M1 . gfromResult @_Serialize @_Columns @exprs @rep fromResult gtoResult toResult (M1 a) = gtoResult @_Serialize @_Columns @exprs @rep toResult a -instance (GTable _Table _Columns rep1, GTable _Table _Columns rep2) => +instance + (GTable _Table _Columns rep1, GTable _Table _Columns rep2) => GTable _Table _Columns (rep1 :*: rep2) - where + where gfromColumns fromColumns (HProduct a b) = - gfromColumns @_Table @_Columns @rep1 fromColumns a :*: - gfromColumns @_Table @_Columns @rep2 fromColumns b - gtoColumns toColumns (a :*: b) = HProduct - (gtoColumns @_Table @_Columns @rep1 toColumns a) - (gtoColumns @_Table @_Columns @rep2 toColumns b) - gtable table = HProduct - (gtable @_Table @_Columns @rep1 table) - (gtable @_Table @_Columns @rep2 table) + gfromColumns @_Table @_Columns @rep1 fromColumns a + :*: gfromColumns @_Table @_Columns @rep2 fromColumns b + gtoColumns toColumns (a :*: b) = + HProduct + (gtoColumns @_Table @_Columns @rep1 toColumns a) + (gtoColumns @_Table @_Columns @rep2 toColumns b) + gtable table = + HProduct + (gtable @_Table @_Columns @rep1 table) + (gtable @_Table @_Columns @rep2 table) instance ( GSerialize _Serialize _Columns expr1 rep1 , GSerialize _Serialize _Columns expr2 rep2 - ) - => GSerialize _Serialize _Columns (expr1 :*: expr2) (rep1 :*: rep2) - where + ) => + GSerialize _Serialize _Columns (expr1 :*: expr2) (rep1 :*: rep2) + where gfromResult fromResult (HProduct a b) = - gfromResult @_Serialize @_Columns @expr1 @rep1 fromResult a :*: - gfromResult @_Serialize @_Columns @expr2 @rep2 fromResult b + gfromResult @_Serialize @_Columns @expr1 @rep1 fromResult a + :*: gfromResult @_Serialize @_Columns @expr2 @rep2 fromResult b gtoResult toResult (a :*: b) = HProduct (gtoResult @_Serialize @_Columns @expr1 @rep1 toResult a) @@ -161,9 +192,9 @@ instance ( Eval (_Table a) , meta ~ 'MetaSel ('Just label) _su _ss _ds , k1 ~ K1 i a - ) - => GTable _Table _Columns (M1 S meta k1) - where + ) => + GTable _Table _Columns (M1 S meta k1) + where gfromColumns fromColumns = M1 . K1 . fromColumns . hunlabel gtoColumns toColumns (M1 (K1 a)) = hlabel (toColumns a) gtable table = hlabel (table (Proxy @a)) @@ -174,8 +205,8 @@ instance , meta ~ 'MetaSel ('Just label) _su _ss _ds , k1 ~ K1 i expr , k1' ~ K1 i a - ) - => GSerialize _Serialize _Columns (M1 S meta k1) (M1 S meta k1') - where + ) => + GSerialize _Serialize _Columns (M1 S meta k1) (M1 S meta k1') + where gfromResult fromResult = M1 . K1 . fromResult (Proxy @expr) . hunlabel gtoResult toResult (M1 (K1 a)) = hlabel (toResult (Proxy @expr) a) diff --git a/src/Rel8/Kind/Algebra.hs b/src/Rel8/Kind/Algebra.hs index f133d370..97d1d265 100644 --- a/src/Rel8/Kind/Algebra.hs +++ b/src/Rel8/Kind/Algebra.hs @@ -1,17 +1,17 @@ -{-# language DataKinds #-} -{-# language FlexibleContexts #-} -{-# language GADTs #-} -{-# language StandaloneKindSignatures #-} - -module Rel8.Kind.Algebra - ( Algebra( Product, Sum ) - , SAlgebra( SProduct, SSum ) - , KnownAlgebra( algebraSing ) - ) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneKindSignatures #-} + +module Rel8.Kind.Algebra ( + Algebra (Product, Sum), + SAlgebra (SProduct, SSum), + KnownAlgebra (algebraSing), +) where -- base -import Data.Kind ( Constraint, Type ) +import Data.Kind (Constraint, Type) import Prelude () diff --git a/src/Rel8/Kind/Context.hs b/src/Rel8/Kind/Context.hs index 048f096f..b10c8eb9 100644 --- a/src/Rel8/Kind/Context.hs +++ b/src/Rel8/Kind/Context.hs @@ -1,24 +1,24 @@ -{-# language DataKinds #-} -{-# language GADTs #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeSynonymInstances #-} - -module Rel8.Kind.Context - ( Reifiable( contextSing ) - , SContext(..) - ) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Rel8.Kind.Context ( + Reifiable (contextSing), + SContext (..), +) where -- base -import Data.Kind ( Constraint, Type ) +import Data.Kind (Constraint, Type) import Prelude () -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Schema.Field ( Field ) -import Rel8.Schema.Kind ( Context ) -import Rel8.Schema.Name ( Name ) -import Rel8.Schema.Result ( Result ) +import Rel8.Expr (Expr) +import Rel8.Schema.Field (Field) +import Rel8.Schema.Kind (Context) +import Rel8.Schema.Name (Name) +import Rel8.Schema.Result (Result) type SContext :: Context -> Type diff --git a/src/Rel8/Order.hs b/src/Rel8/Order.hs index 4943b42d..feece508 100644 --- a/src/Rel8/Order.hs +++ b/src/Rel8/Order.hs @@ -1,30 +1,31 @@ -{-# language DerivingStrategies #-} -{-# language GeneralizedNewtypeDeriving #-} -{-# language StandaloneKindSignatures #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} -module Rel8.Order - ( Order(..) - ) +module Rel8.Order ( + Order (..), +) where -- base -import Data.Functor.Contravariant ( Contravariant ) -import Data.Kind ( Type ) +import Data.Functor.Contravariant (Contravariant) +import Data.Kind (Type) import Prelude -- contravariant -import Data.Functor.Contravariant.Divisible ( Decidable, Divisible ) +import Data.Functor.Contravariant.Divisible (Decidable, Divisible) -- opaleye import qualified Opaleye.Order as Opaleye --- | An ordering expression for @a@. Primitive orderings are defined with --- 'Rel8.asc' and 'Rel8.desc', and you can combine @Order@ via its various --- instances. --- --- A common pattern is to use '<>' to combine multiple orderings in sequence, --- and 'Data.Functor.Contravariant.>$<' to select individual columns. +{- | An ordering expression for @a@. Primitive orderings are defined with +'Rel8.asc' and 'Rel8.desc', and you can combine @Order@ via its various +instances. + +A common pattern is to use '<>' to combine multiple orderings in sequence, +and 'Data.Functor.Contravariant.>$<' to select individual columns. +-} type Order :: Type -> Type newtype Order a = Order (Opaleye.Order a) deriving newtype (Contravariant, Divisible, Decidable, Semigroup, Monoid) diff --git a/src/Rel8/Query.hs b/src/Rel8/Query.hs index c9457b67..eb7b9f44 100644 --- a/src/Rel8/Query.hs +++ b/src/Rel8/Query.hs @@ -1,17 +1,17 @@ -{-# language FlexibleContexts #-} -{-# language StandaloneKindSignatures #-} -{-# language UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UndecidableInstances #-} -module Rel8.Query - ( Query( Query ) - ) +module Rel8.Query ( + Query (Query), +) where -- base -import Control.Applicative ( liftA2 ) -import Control.Monad ( liftM2 ) -import Data.Kind ( Type ) -import Data.Monoid ( Any( Any ) ) +import Control.Applicative (liftA2) +import Control.Monad (liftM2) +import Data.Kind (Type) +import Data.Monoid (Any (Any)) import Prelude -- opaleye @@ -22,138 +22,141 @@ import qualified Opaleye.Internal.QueryArr as Opaleye import qualified Opaleye.Internal.Tag as Opaleye -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Query.Set ( unionAll ) -import Rel8.Query.Opaleye ( fromOpaleye ) -import Rel8.Query.Values ( values ) -import Rel8.Table ( Table, fromColumns, toColumns ) -import Rel8.Table.Alternative - ( AltTable, (<|>:) - , AlternativeTable, emptyTable - ) -import Rel8.Table.Projection ( Projectable, apply, project ) +import Rel8.Expr (Expr) +import Rel8.Query.Opaleye (fromOpaleye) +import Rel8.Query.Set (unionAll) +import Rel8.Query.Values (values) +import Rel8.Table (Table, fromColumns, toColumns) +import Rel8.Table.Alternative ( + AltTable, + AlternativeTable, + emptyTable, + (<|>:), + ) +import Rel8.Table.Projection (Projectable, apply, project) -- semigroupoids -import Data.Functor.Apply ( Apply, (<.>) ) -import Data.Functor.Bind ( Bind, (>>-) ) +import Data.Functor.Apply (Apply, (<.>)) +import Data.Functor.Bind (Bind, (>>-)) --- | The @Query@ monad allows you to compose a @SELECT@ query. This monad has --- semantics similar to the list (@[]@) monad. +{- | The @Query@ monad allows you to compose a @SELECT@ query. This monad has +semantics similar to the list (@[]@) monad. +-} type Query :: Type -> Type -newtype Query a = - Query ( - -- This is based on Opaleye's Select monad, but with two addtions. We - -- maintain a stack of PrimExprs from parent previous subselects. In - -- practice, these are always the results of dummy calls to random(). - -- - -- We also return a Bool that indicates to the parent subselect whether - -- or not that stack of PrimExprs were used at any point. If they weren't, - -- then the call to random() is never added to the query. - -- - -- This is all needed to implement evaluate. Consider the following code: - -- - -- do - -- x <- values [lit 'a', lit 'b', lit 'c'] - -- y <- evaluate $ nextval "user_id_seq" - -- pure (x, y) - -- - -- If we just used Opaleye's Select monad directly, the SQL would come out - -- like this: - -- - -- SELECT - -- a, b - -- FROM - -- (VALUES ('a'), ('b'), ('c')) Q1(a), - -- LATERAL (SELECT nextval('user_id_seq')) Q2(b); - -- - -- From the Haskell code, you would intuitively expect to get back the - -- results of three different calls to nextval(), but from Postgres' point - -- of view, because the Q2 subquery doesn't reference anything from the Q1 - -- query, it thinks it only needs to call nextval() once. This is actually - -- exactly the same problem you get with the deprecated ListT IO monad from - -- the transformers package — *> behaves differently to >>=, so - -- using ApplicativeDo can change the results of a program. ApplicativeDo - -- is exactly the optimisation Postgres does on a "LATERAL" query that - -- doesn't make any references to previous subselects. - -- - -- Rel8's solution is generate the following SQL instead: - -- - -- SELECT - -- a, b - -- FROM - -- (SELECT - -- random() AS dummy, - -- * - -- FROM - -- (VALUES ('a'), ('b'), ('c')) Q1(a)) Q1, - -- LATERAL (SELECT - -- CASE - -- WHEN dummy IS NOT NULL - -- THEN nextval('user_id_seq') - -- END) Q2(b); - -- - -- We use random() here as the dummy value (and not some constant) because - -- Postgres will again optimize if it sees that a value is constant - -- (and thus only call nextval() once), but because random() is marked as - -- VOLATILE, this inhibits Postgres from doing that optimisation. - -- - -- Why not just reference the a column from the previous query directly - -- instead of adding a dummy value? Basically, even if we extract out all - -- the bindings introduced in a PrimQuery, we can't always be sure which - -- ones refer to constant values, so if we end up laterally referencing a - -- constant value, then all of this would be for nothing. - -- - -- Why not just add the call to the previous subselect directly, like so: - -- - -- SELECT - -- a, b - -- FROM - -- (SELECT - -- nextval('user_id_seq') AS eval, - -- * - -- FROM - -- (VALUES ('a'), ('b'), ('c')) Q1(a)) Q1, - -- LATERAL (SELECT eval) Q2(b); - -- - -- That would work in this case. But consider the following Rel8 code: - -- - -- do - -- x <- values [lit 'a', lit 'b', lit 'c'] - -- y <- values [lit 'd', lit 'e', lit 'f'] - -- z <- evaluate $ nextval "user_id_seq" - -- pure (x, y, z) - -- - -- How many calls to nextval should there be? Our Haskell intuition says - -- nine. But that's not what you would get if you used the above - -- technique. The problem is, which VALUES query should the nextval be - -- added to? You can choose one or the other to get three calls to - -- nextval, but you still need to make a superfluous LATERAL references to - -- the other if you want nine calls. So for the above Rel8 code we generate - -- the following SQL: - -- - -- SELECT - -- a, b, c - -- FROM - -- (SELECT - -- random() AS dummy, - -- * - -- FROM - -- (VALUES ('a'), ('b'), ('c')) Q1(a)) Q1, - -- (SELECT - -- random() AS dummy, - -- * - -- FROM - -- (VALUES ('d'), ('e'), ('f')) Q2(b)) Q2, - -- LATERAL (SELECT - -- CASE - -- WHEN Q1.dummy IS NOT NULL AND Q2.dummy IS NOT NULL - -- THEN nextval('user_id_seq') - -- END) Q3(c); - -- - -- This gives nine calls to nextval() as we would expect. - [Opaleye.PrimExpr] -> Opaleye.Select (Any, a) - ) +newtype Query a + = Query + ( -- This is based on Opaleye's Select monad, but with two addtions. We + -- maintain a stack of PrimExprs from parent previous subselects. In + -- practice, these are always the results of dummy calls to random(). + -- + -- We also return a Bool that indicates to the parent subselect whether + -- or not that stack of PrimExprs were used at any point. If they weren't, + -- then the call to random() is never added to the query. + -- + -- This is all needed to implement evaluate. Consider the following code: + -- + -- do + -- x <- values [lit 'a', lit 'b', lit 'c'] + -- y <- evaluate $ nextval "user_id_seq" + -- pure (x, y) + -- + -- If we just used Opaleye's Select monad directly, the SQL would come out + -- like this: + -- + -- SELECT + -- a, b + -- FROM + -- (VALUES ('a'), ('b'), ('c')) Q1(a), + -- LATERAL (SELECT nextval('user_id_seq')) Q2(b); + -- + -- From the Haskell code, you would intuitively expect to get back the + -- results of three different calls to nextval(), but from Postgres' point + -- of view, because the Q2 subquery doesn't reference anything from the Q1 + -- query, it thinks it only needs to call nextval() once. This is actually + -- exactly the same problem you get with the deprecated ListT IO monad from + -- the transformers package — *> behaves differently to >>=, so + -- using ApplicativeDo can change the results of a program. ApplicativeDo + -- is exactly the optimisation Postgres does on a "LATERAL" query that + -- doesn't make any references to previous subselects. + -- + -- Rel8's solution is generate the following SQL instead: + -- + -- SELECT + -- a, b + -- FROM + -- (SELECT + -- random() AS dummy, + -- * + -- FROM + -- (VALUES ('a'), ('b'), ('c')) Q1(a)) Q1, + -- LATERAL (SELECT + -- CASE + -- WHEN dummy IS NOT NULL + -- THEN nextval('user_id_seq') + -- END) Q2(b); + -- + -- We use random() here as the dummy value (and not some constant) because + -- Postgres will again optimize if it sees that a value is constant + -- (and thus only call nextval() once), but because random() is marked as + -- VOLATILE, this inhibits Postgres from doing that optimisation. + -- + -- Why not just reference the a column from the previous query directly + -- instead of adding a dummy value? Basically, even if we extract out all + -- the bindings introduced in a PrimQuery, we can't always be sure which + -- ones refer to constant values, so if we end up laterally referencing a + -- constant value, then all of this would be for nothing. + -- + -- Why not just add the call to the previous subselect directly, like so: + -- + -- SELECT + -- a, b + -- FROM + -- (SELECT + -- nextval('user_id_seq') AS eval, + -- * + -- FROM + -- (VALUES ('a'), ('b'), ('c')) Q1(a)) Q1, + -- LATERAL (SELECT eval) Q2(b); + -- + -- That would work in this case. But consider the following Rel8 code: + -- + -- do + -- x <- values [lit 'a', lit 'b', lit 'c'] + -- y <- values [lit 'd', lit 'e', lit 'f'] + -- z <- evaluate $ nextval "user_id_seq" + -- pure (x, y, z) + -- + -- How many calls to nextval should there be? Our Haskell intuition says + -- nine. But that's not what you would get if you used the above + -- technique. The problem is, which VALUES query should the nextval be + -- added to? You can choose one or the other to get three calls to + -- nextval, but you still need to make a superfluous LATERAL references to + -- the other if you want nine calls. So for the above Rel8 code we generate + -- the following SQL: + -- + -- SELECT + -- a, b, c + -- FROM + -- (SELECT + -- random() AS dummy, + -- * + -- FROM + -- (VALUES ('a'), ('b'), ('c')) Q1(a)) Q1, + -- (SELECT + -- random() AS dummy, + -- * + -- FROM + -- (VALUES ('d'), ('e'), ('f')) Q2(b)) Q2, + -- LATERAL (SELECT + -- CASE + -- WHEN Q1.dummy IS NOT NULL AND Q2.dummy IS NOT NULL + -- THEN nextval('user_id_seq') + -- END) Q3(c); + -- + -- This gives nine calls to nextval() as we would expect. + [Opaleye.PrimExpr] -> Opaleye.Select (Any, a) + ) instance Projectable Query where @@ -199,7 +202,7 @@ instance Monad Query where | needsDummies = query' <> query'' | otherwise = query <> query'' m'' = m <> m' - in + in ((m'', b), query''', tag''') diff --git a/src/Rel8/Query/Aggregate.hs b/src/Rel8/Query/Aggregate.hs index 2e3a215d..ba332e4c 100644 --- a/src/Rel8/Query/Aggregate.hs +++ b/src/Rel8/Query/Aggregate.hs @@ -1,58 +1,61 @@ -{-# language FlexibleContexts #-} -{-# language MonoLocalBinds #-} -{-# language ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE ScopedTypeVariables #-} -module Rel8.Query.Aggregate - ( aggregate - , aggregate1 - , countRows - , mode - ) +module Rel8.Query.Aggregate ( + aggregate, + aggregate1, + countRows, + mode, +) where -- base import Control.Applicative (liftA2) -import Data.Functor.Contravariant ( (>$<) ) -import Data.Int ( Int64 ) +import Data.Functor.Contravariant ((>$<)) +import Data.Int (Int64) import Prelude -- opaleye import qualified Opaleye.Aggregate as Opaleye -- rel8 -import Rel8.Aggregate (Aggregator' (Aggregator), Aggregator) +import Rel8.Aggregate (Aggregator, Aggregator' (Aggregator)) import Rel8.Aggregate.Fold (Fallback (Fallback)) -import Rel8.Expr ( Expr ) -import Rel8.Expr.Aggregate ( countStar ) -import Rel8.Expr.Order ( desc ) -import Rel8.Query ( Query ) -import Rel8.Query.Limit ( limit ) -import Rel8.Query.Maybe ( optional ) -import Rel8.Query.Opaleye ( mapOpaleye ) -import Rel8.Query.Order ( orderBy ) +import Rel8.Expr (Expr) +import Rel8.Expr.Aggregate (countStar) +import Rel8.Expr.Order (desc) +import Rel8.Query (Query) +import Rel8.Query.Limit (limit) +import Rel8.Query.Maybe (optional) +import Rel8.Query.Opaleye (mapOpaleye) +import Rel8.Query.Order (orderBy) import Rel8.Table (Table) import Rel8.Table.Aggregate (groupBy) import Rel8.Table.Eq (EqTable) import Rel8.Table.Maybe (fromMaybeTable) --- | Apply an 'Aggregator' to all rows returned by a 'Query'. If the 'Query' --- is empty, then a single \"fallback\" row is returned, composed of the --- identity elements of the constituent aggregation functions. +{- | Apply an 'Aggregator' to all rows returned by a 'Query'. If the 'Query' +is empty, then a single \"fallback\" row is returned, composed of the +identity elements of the constituent aggregation functions. +-} aggregate :: Table Expr a => Aggregator i a -> Query i -> Query a aggregate aggregator@(Aggregator (Fallback fallback) _) = fmap (fromMaybeTable fallback) . optional . aggregate1 aggregator --- | Apply an 'Rel8.Aggregator1' to all rows returned by a 'Query'. If --- the 'Query' is empty, then zero rows are returned. +{- | Apply an 'Rel8.Aggregator1' to all rows returned by a 'Query'. If +the 'Query' is empty, then zero rows are returned. +-} aggregate1 :: Aggregator' fold i a -> Query i -> Query a aggregate1 (Aggregator _ aggregator) = mapOpaleye (Opaleye.aggregate aggregator) --- | Count the number of rows returned by a query. Note that this is different --- from @countStar@, as even if the given query yields no rows, @countRows@ --- will return @0@. +{- | Count the number of rows returned by a query. Note that this is different +from @countStar@, as even if the given query yields no rows, @countRows@ +will return @0@. +-} countRows :: Query a -> Query (Expr Int64) countRows = aggregate countStar @@ -60,6 +63,7 @@ countRows = aggregate countStar -- | Return the most common row in a query. mode :: forall a. EqTable a => Query a -> Query a mode rows = - limit 1 $ fmap snd $ - orderBy (fst >$< desc) $ do - aggregate1 (liftA2 (,) countStar groupBy) rows + limit 1 $ + fmap snd $ + orderBy (fst >$< desc) $ do + aggregate1 (liftA2 (,) countStar groupBy) rows diff --git a/src/Rel8/Query/Distinct.hs b/src/Rel8/Query/Distinct.hs index 7cb6cf64..8adf949d 100644 --- a/src/Rel8/Query/Distinct.hs +++ b/src/Rel8/Query/Distinct.hs @@ -1,8 +1,8 @@ -module Rel8.Query.Distinct - ( distinct - , distinctOn - , distinctOnBy - ) +module Rel8.Query.Distinct ( + distinct, + distinctOn, + distinctOnBy, +) where -- base @@ -13,28 +13,31 @@ import qualified Opaleye.Distinct as Opaleye import qualified Opaleye.Order 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 ) +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) --- | Select all distinct rows from a query, removing duplicates. @distinct q@ --- is equivalent to the SQL statement @SELECT DISTINCT q@. +{- | Select all distinct rows from a query, removing duplicates. @distinct q@ +is equivalent to the SQL statement @SELECT DISTINCT q@. +-} distinct :: EqTable a => Query a -> Query a distinct = mapOpaleye (Opaleye.distinctExplicit distinctspec) --- | Select all distinct rows from a query, where rows are equivalent according --- to a projection. If multiple rows have the same projection, it is --- unspecified which row will be returned. If this matters, use 'distinctOnBy'. +{- | Select all distinct rows from a query, where rows are equivalent according +to a projection. If multiple rows have the same projection, it is +unspecified which row will be returned. If this matters, use 'distinctOnBy'. +-} distinctOn :: EqTable b => (a -> b) -> Query a -> Query a distinctOn proj = mapOpaleye (Opaleye.distinctOnExplicit unpackspec proj) --- | Select all distinct rows from a query, where rows are equivalent according --- to a projection. If there are multiple rows with the same projection, the --- first row according to the specified 'Order' will be returned. +{- | Select all distinct rows from a query, where rows are equivalent according +to a projection. If there are multiple rows with the same projection, the +first row according to the specified 'Order' will be returned. +-} distinctOnBy :: EqTable b => (a -> b) -> Order a -> Query a -> Query a distinctOnBy proj (Order order) = mapOpaleye (Opaleye.distinctOnByExplicit unpackspec proj order) diff --git a/src/Rel8/Query/Each.hs b/src/Rel8/Query/Each.hs index 930c102e..2d5752df 100644 --- a/src/Rel8/Query/Each.hs +++ b/src/Rel8/Query/Each.hs @@ -1,9 +1,9 @@ -{-# language FlexibleContexts #-} -{-# language MonoLocalBinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} -module Rel8.Query.Each - ( each - ) +module Rel8.Query.Each ( + each, +) where -- base @@ -13,20 +13,21 @@ import Prelude import qualified Opaleye.Table as Opaleye -- rel8 -import Rel8.Query ( Query ) -import Rel8.Query.Opaleye ( fromOpaleye ) -import Rel8.Schema.Name ( Selects ) -import Rel8.Schema.Table ( TableSchema ) -import Rel8.Table.Cols ( fromCols, toCols ) -import Rel8.Table.Opaleye ( table, unpackspec ) +import Rel8.Query (Query) +import Rel8.Query.Opaleye (fromOpaleye) +import Rel8.Schema.Name (Selects) +import Rel8.Schema.Table (TableSchema) +import Rel8.Table.Cols (fromCols, toCols) +import Rel8.Table.Opaleye (table, unpackspec) --- | Select each row from a table definition. This is equivalent to @FROM --- table@. +{- | Select each row from a table definition. This is equivalent to @FROM +table@. +-} each :: Selects names exprs => TableSchema names -> Query exprs each = - fmap fromCols . - fromOpaleye . - Opaleye.selectTableExplicit unpackspec . - table . - fmap toCols + fmap fromCols + . fromOpaleye + . Opaleye.selectTableExplicit unpackspec + . table + . fmap toCols diff --git a/src/Rel8/Query/Either.hs b/src/Rel8/Query/Either.hs index f82ffed0..a0381a02 100644 --- a/src/Rel8/Query/Either.hs +++ b/src/Rel8/Query/Either.hs @@ -1,29 +1,30 @@ -{-# language FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} -module Rel8.Query.Either - ( keepLeftTable - , keepRightTable - , bitraverseEitherTable - ) +module Rel8.Query.Either ( + keepLeftTable, + keepRightTable, + bitraverseEitherTable, +) where -- base import Prelude -- comonad -import Control.Comonad ( extract ) +import Control.Comonad (extract) -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Expr.Eq ( (==.) ) -import Rel8.Query ( Query ) -import Rel8.Query.Filter ( where_ ) -import Rel8.Query.Maybe ( optional ) -import Rel8.Table.Either - ( EitherTable( EitherTable ) - , isLeftTable, isRightTable - ) -import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable ) +import Rel8.Expr (Expr) +import Rel8.Expr.Eq ((==.)) +import Rel8.Query (Query) +import Rel8.Query.Filter (where_) +import Rel8.Query.Maybe (optional) +import Rel8.Table.Either ( + EitherTable (EitherTable), + isLeftTable, + isRightTable, + ) +import Rel8.Table.Maybe (MaybeTable (MaybeTable), isJustTable) -- | Filter 'EitherTable's, keeping only 'leftTable's. @@ -40,27 +41,29 @@ keepRightTable e@(EitherTable _ _ b) = do pure (extract b) --- | @bitraverseEitherTable f g x@ will pass all @leftTable@s through @f@ and --- all @rightTable@s through @g@. The results are then lifted back into --- @leftTable@ and @rightTable@, respectively. This is similar to 'bitraverse' --- for 'Either'. --- --- For example, --- --- >>> :{ --- select do --- x <- values (map lit [ Left True, Right (42 :: Int32) ]) --- bitraverseEitherTable (\y -> values [y, not_ y]) (\y -> pure (y * 100)) x --- :} --- [ Left True --- , Left False --- , Right 4200 --- ] -bitraverseEitherTable :: () - => (a -> Query c) - -> (b -> Query d) - -> EitherTable Expr a b - -> Query (EitherTable Expr c d) +{- | @bitraverseEitherTable f g x@ will pass all @leftTable@s through @f@ and +all @rightTable@s through @g@. The results are then lifted back into +@leftTable@ and @rightTable@, respectively. This is similar to 'bitraverse' +for 'Either'. + +For example, + +>>> :{ +select do + x <- values (map lit [ Left True, Right (42 :: Int32) ]) + bitraverseEitherTable (\y -> values [y, not_ y]) (\y -> pure (y * 100)) x +:} +[ Left True +, Left False +, Right 4200 +] +-} +bitraverseEitherTable :: + () => + (a -> Query c) -> + (b -> Query d) -> + EitherTable Expr a b -> + Query (EitherTable Expr c d) bitraverseEitherTable f g e@(EitherTable tag _ _) = do mc@(MaybeTable _ c) <- optional (f =<< keepLeftTable e) md@(MaybeTable _ d) <- optional (g =<< keepRightTable e) diff --git a/src/Rel8/Query/Evaluate.hs b/src/Rel8/Query/Evaluate.hs index 5816387c..7b29c325 100644 --- a/src/Rel8/Query/Evaluate.hs +++ b/src/Rel8/Query/Evaluate.hs @@ -1,48 +1,50 @@ -{-# language FlexibleContexts #-} -{-# language TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} -module Rel8.Query.Evaluate - ( evaluate - ) +module Rel8.Query.Evaluate ( + evaluate, +) where -- base -import Control.Monad ( (>=>) ) -import Data.Foldable ( foldl' ) -import Data.List.NonEmpty ( NonEmpty( (:|) ), nonEmpty ) -import Data.Monoid ( Any( Any ) ) -import Prelude hiding ( undefined ) +import Control.Monad ((>=>)) +import Data.Foldable (foldl') +import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty) +import Data.Monoid (Any (Any)) +import Prelude hiding (undefined) -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Expr.Bool ( (&&.) ) -import Rel8.Expr.Opaleye ( fromPrimExpr ) -import Rel8.Query ( Query( Query ) ) -import Rel8.Query.Rebind ( rebind ) -import Rel8.Table ( Table ) -import Rel8.Table.Bool ( case_ ) -import Rel8.Table.Undefined ( undefined ) - - --- | 'evaluate' takes expressions that could potentially have side effects and --- \"runs\" them in the 'Query' monad. The returned expressions have no side --- effects and can safely be reused. +import Rel8.Expr (Expr) +import Rel8.Expr.Bool ((&&.)) +import Rel8.Expr.Opaleye (fromPrimExpr) +import Rel8.Query (Query (Query)) +import Rel8.Query.Rebind (rebind) +import Rel8.Table (Table) +import Rel8.Table.Bool (case_) +import Rel8.Table.Undefined (undefined) + + +{- | 'evaluate' takes expressions that could potentially have side effects and +\"runs\" them in the 'Query' monad. The returned expressions have no side +effects and can safely be reused. +-} evaluate :: Table Expr a => a -> Query a evaluate = laterally >=> rebind "eval" laterally :: Table Expr a => a -> Query a -laterally a = Query $ \bindings -> pure $ (Any True,) $ - case nonEmpty bindings of - Nothing -> a - Just bindings' -> case_ [(condition, a)] undefined - where - condition = foldl1' (&&.) (fmap go bindings') - where - go = fromPrimExpr . Opaleye.UnExpr Opaleye.OpIsNotNull +laterally a = Query $ \bindings -> pure $ + (Any True,) $ + case nonEmpty bindings of + Nothing -> a + Just bindings' -> case_ [(condition, a)] undefined + where + condition = foldl1' (&&.) (fmap go bindings') + where + go = fromPrimExpr . Opaleye.UnExpr Opaleye.OpIsNotNull foldl1' :: (a -> a -> a) -> NonEmpty a -> a diff --git a/src/Rel8/Query/Exists.hs b/src/Rel8/Query/Exists.hs index 2b4b43d6..52dc5693 100644 --- a/src/Rel8/Query/Exists.hs +++ b/src/Rel8/Query/Exists.hs @@ -1,26 +1,31 @@ -{-# language DataKinds #-} - -module Rel8.Query.Exists - ( exists, inQuery - , present, with, withBy - , absent, without, withoutBy - ) +{-# LANGUAGE DataKinds #-} + +module Rel8.Query.Exists ( + exists, + inQuery, + present, + with, + withBy, + absent, + without, + withoutBy, +) where -- base -import Prelude hiding ( filter ) +import Prelude hiding (filter) -- opaleye import qualified Opaleye.Exists as Opaleye import qualified Opaleye.Operators as Opaleye -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr ) -import Rel8.Query ( Query ) -import Rel8.Query.Filter ( filter ) -import Rel8.Query.Opaleye ( mapOpaleye ) -import Rel8.Table.Eq ( EqTable, (==:) ) +import Rel8.Expr (Expr) +import Rel8.Expr.Opaleye (fromColumn, fromPrimExpr) +import Rel8.Query (Query) +import Rel8.Query.Filter (filter) +import Rel8.Query.Opaleye (mapOpaleye) +import Rel8.Table.Eq (EqTable, (==:)) -- | Checks if a query returns at least one row. @@ -32,21 +37,24 @@ inQuery :: EqTable a => a -> Query a -> Query (Expr Bool) inQuery a = exists . (>>= filter (a ==:)) --- | Produce the empty query if the given query returns no rows. @present@ --- is equivalent to @WHERE EXISTS@ in SQL. +{- | Produce the empty query if the given query returns no rows. @present@ +is equivalent to @WHERE EXISTS@ in SQL. +-} present :: Query a -> Query () present = mapOpaleye Opaleye.restrictExists --- | Produce the empty query if the given query returns rows. @absent@ --- is equivalent to @WHERE NOT EXISTS@ in SQL. +{- | Produce the empty query if the given query returns rows. @absent@ +is equivalent to @WHERE NOT EXISTS@ in SQL. +-} absent :: Query a -> Query () absent = mapOpaleye Opaleye.restrictNotExists --- | @with@ is similar to 'filter', but allows the predicate to be a full query. --- --- @with f a = a <$ present (f a)@, but this form matches 'filter'. +{- | @with@ is similar to 'filter', but allows the predicate to be a full query. + +@with f a = a <$ present (f a)@, but this form matches 'filter'. +-} with :: (a -> Query b) -> a -> Query a with f a = a <$ present (f a) diff --git a/src/Rel8/Query/Filter.hs b/src/Rel8/Query/Filter.hs index c0123fe7..4019e81c 100644 --- a/src/Rel8/Query/Filter.hs +++ b/src/Rel8/Query/Filter.hs @@ -1,35 +1,37 @@ -module Rel8.Query.Filter - ( filter - , where_ - ) +module Rel8.Query.Filter ( + filter, + where_, +) where -- base -import Prelude hiding ( filter ) +import Prelude hiding (filter) -- opaleye import qualified Opaleye.Operators as Opaleye -- profunctors -import Data.Profunctor ( lmap ) +import Data.Profunctor (lmap) -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Expr.Opaleye ( toColumn, toPrimExpr ) -import Rel8.Query ( Query ) -import Rel8.Query.Opaleye ( fromOpaleye ) +import Rel8.Expr (Expr) +import Rel8.Expr.Opaleye (toColumn, toPrimExpr) +import Rel8.Query (Query) +import Rel8.Query.Opaleye (fromOpaleye) --- | @filter f x@ will be a zero-row query when @f x@ is @False@, and will --- return @x@ unchanged when @f x@ is @True@. This is similar to --- 'Control.Monad.guard', but as the predicate is separate from the argument, --- it is easy to use in a pipeline of 'Query' transformations. +{- | @filter f x@ will be a zero-row query when @f x@ is @False@, and will +return @x@ unchanged when @f x@ is @True@. This is similar to +'Control.Monad.guard', but as the predicate is separate from the argument, +it is easy to use in a pipeline of 'Query' transformations. +-} filter :: (a -> Expr Bool) -> a -> Query a filter f a = a <$ where_ (f a) --- | Drop any rows that don't match a predicate. @where_ expr@ is equivalent --- to the SQL @WHERE expr@. +{- | Drop any rows that don't match a predicate. @where_ expr@ is equivalent +to the SQL @WHERE expr@. +-} where_ :: Expr Bool -> Query () where_ condition = fromOpaleye $ lmap (\_ -> toColumn $ toPrimExpr condition) Opaleye.restrict diff --git a/src/Rel8/Query/Indexed.hs b/src/Rel8/Query/Indexed.hs index a0a595d4..697b200e 100644 --- a/src/Rel8/Query/Indexed.hs +++ b/src/Rel8/Query/Indexed.hs @@ -1,19 +1,19 @@ -module Rel8.Query.Indexed - ( indexed - ) +module Rel8.Query.Indexed ( + indexed, +) where -- base -import Control.Applicative ( liftA2 ) -import Data.Int ( Int64 ) +import Control.Applicative (liftA2) +import Data.Int (Int64) import Prelude -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Expr.Window ( rowNumber ) -import Rel8.Query ( Query ) -import Rel8.Query.Window ( window ) -import Rel8.Table.Window ( currentRow ) +import Rel8.Expr (Expr) +import Rel8.Expr.Window (rowNumber) +import Rel8.Query (Query) +import Rel8.Query.Window (window) +import Rel8.Table.Window (currentRow) -- | Pair each row of a query with its index within the query. diff --git a/src/Rel8/Query/Limit.hs b/src/Rel8/Query/Limit.hs index 997eb955..3617ed9f 100644 --- a/src/Rel8/Query/Limit.hs +++ b/src/Rel8/Query/Limit.hs @@ -1,7 +1,7 @@ -module Rel8.Query.Limit - ( limit - , offset - ) +module Rel8.Query.Limit ( + limit, + offset, +) where -- base @@ -11,17 +11,19 @@ import Prelude import qualified Opaleye -- rel8 -import Rel8.Query ( Query ) -import Rel8.Query.Opaleye ( mapOpaleye ) +import Rel8.Query (Query) +import Rel8.Query.Opaleye (mapOpaleye) --- | @limit n@ select at most @n@ rows from a query. @limit n@ is equivalent --- to the SQL @LIMIT n@. +{- | @limit n@ select at most @n@ rows from a query. @limit n@ is equivalent +to the SQL @LIMIT n@. +-} limit :: Word -> Query a -> Query a limit = mapOpaleye . Opaleye.limit . fromIntegral --- | @offset n@ drops the first @n@ rows from a query. @offset n@ is equivalent --- to the SQL @OFFSET n@. +{- | @offset n@ drops the first @n@ rows from a query. @offset n@ is equivalent +to the SQL @OFFSET n@. +-} offset :: Word -> Query a -> Query a offset = mapOpaleye . Opaleye.offset . fromIntegral diff --git a/src/Rel8/Query/List.hs b/src/Rel8/Query/List.hs index 0ba686bc..4eca7bf2 100644 --- a/src/Rel8/Query/List.hs +++ b/src/Rel8/Query/List.hs @@ -1,62 +1,68 @@ -{-# language FlexibleContexts #-} -{-# language GADTs #-} -{-# language NamedFieldPuns #-} - -module Rel8.Query.List - ( many, some - , manyExpr, someExpr - , catListTable, catNonEmptyTable - , catList, catNonEmpty - ) +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Rel8.Query.List ( + many, + some, + manyExpr, + someExpr, + catListTable, + catNonEmptyTable, + catList, + catNonEmpty, +) where -- base import Control.Monad ((>=>)) -import Data.Functor.Identity ( runIdentity ) -import Data.List.NonEmpty ( NonEmpty ) +import Data.Functor.Identity (runIdentity) +import Data.List.NonEmpty (NonEmpty) import Prelude -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Expr.Aggregate ( listAggExpr, nonEmptyAggExpr ) -import Rel8.Expr.Opaleye ( mapPrimExpr ) -import Rel8.Query ( Query ) +import Rel8.Expr (Expr) +import Rel8.Expr.Aggregate (listAggExpr, nonEmptyAggExpr) +import Rel8.Expr.Opaleye (mapPrimExpr) +import Rel8.Query (Query) import Rel8.Query.Aggregate (aggregate, aggregate1) import Rel8.Query.Rebind (hrebind, rebind) import Rel8.Schema.HTable (HTable, hfield, hspecs, htabulate) -import Rel8.Schema.HTable.Vectorize ( hunvectorize ) -import Rel8.Schema.Null ( Sql ) -import Rel8.Schema.Spec ( Spec( Spec, info ) ) +import Rel8.Schema.HTable.Vectorize (hunvectorize) +import Rel8.Schema.Null (Sql) +import Rel8.Schema.Spec (Spec (Spec, info)) import Rel8.Table (Table, fromColumns, toColumns) -import Rel8.Table.Aggregate ( listAgg, nonEmptyAgg ) -import Rel8.Table.List ( ListTable( ListTable ) ) -import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) ) -import Rel8.Type ( DBType ) -import Rel8.Type.Array ( extractArrayElement ) - - --- | Aggregate a 'Query' into a 'ListTable'. If the supplied query returns 0 --- rows, this function will produce a 'Query' that returns one row containing --- the empty @ListTable@. If the supplied @Query@ does return rows, @many@ will --- return exactly one row, with a @ListTable@ collecting all returned rows. --- --- @many@ is analogous to 'Control.Applicative.many' from --- @Control.Applicative@. +import Rel8.Table.Aggregate (listAgg, nonEmptyAgg) +import Rel8.Table.List (ListTable (ListTable)) +import Rel8.Table.NonEmpty (NonEmptyTable (NonEmptyTable)) +import Rel8.Type (DBType) +import Rel8.Type.Array (extractArrayElement) + + +{- | Aggregate a 'Query' into a 'ListTable'. If the supplied query returns 0 +rows, this function will produce a 'Query' that returns one row containing +the empty @ListTable@. If the supplied @Query@ does return rows, @many@ will +return exactly one row, with a @ListTable@ collecting all returned rows. + +@many@ is analogous to 'Control.Applicative.many' from +@Control.Applicative@. +-} many :: Table Expr a => Query a -> Query (ListTable Expr a) many = aggregate listAgg --- | Aggregate a 'Query' into a 'NonEmptyTable'. If the supplied query returns --- 0 rows, this function will produce a 'Query' that is empty - that is, will --- produce zero @NonEmptyTable@s. If the supplied @Query@ does return rows, --- @some@ will return exactly one row, with a @NonEmptyTable@ collecting all --- returned rows. --- --- @some@ is analogous to 'Control.Applicative.some' from --- @Control.Applicative@. +{- | Aggregate a 'Query' into a 'NonEmptyTable'. If the supplied query returns +0 rows, this function will produce a 'Query' that is empty - that is, will +produce zero @NonEmptyTable@s. If the supplied @Query@ does return rows, +@some@ will return exactly one row, with a @NonEmptyTable@ collecting all +returned rows. + +@some@ is analogous to 'Control.Applicative.some' from +@Control.Applicative@. +-} some :: Table Expr a => Query a -> Query (NonEmptyTable Expr a) some = aggregate1 nonEmptyAgg @@ -71,38 +77,46 @@ someExpr :: Sql DBType a => Query (Expr a) -> Query (Expr (NonEmpty a)) someExpr = aggregate1 nonEmptyAggExpr --- | Expand a 'ListTable' into a 'Query', where each row in the query is an --- element of the given @ListTable@. --- --- @catListTable@ is an inverse to 'many'. +{- | Expand a 'ListTable' into a 'Query', where each row in the query is an +element of the given @ListTable@. + +@catListTable@ is an inverse to 'many'. +-} catListTable :: Table Expr a => ListTable Expr a -> Query a catListTable (ListTable as) = - fmap fromColumns $ (hrebind "unnest" >=> hextract) $ runIdentity $ - hunvectorize (\_ -> pure . unnest) as + fmap fromColumns $ + (hrebind "unnest" >=> hextract) $ + runIdentity $ + hunvectorize (\_ -> pure . unnest) as + +{- | Expand a 'NonEmptyTable' into a 'Query', where each row in the query is an +element of the given @NonEmptyTable@. --- | Expand a 'NonEmptyTable' into a 'Query', where each row in the query is an --- element of the given @NonEmptyTable@. --- --- @catNonEmptyTable@ is an inverse to 'some'. +@catNonEmptyTable@ is an inverse to 'some'. +-} catNonEmptyTable :: Table Expr a => NonEmptyTable Expr a -> Query a catNonEmptyTable (NonEmptyTable as) = - fmap fromColumns $ (hrebind "unnest" >=> hextract) $ runIdentity $ - hunvectorize (\_ -> pure . unnest) as + fmap fromColumns $ + (hrebind "unnest" >=> hextract) $ + runIdentity $ + hunvectorize (\_ -> pure . unnest) as --- | Expand an expression that contains a list into a 'Query', where each row --- in the query is an element of the given list. --- --- @catList@ is an inverse to 'manyExpr'. +{- | Expand an expression that contains a list into a 'Query', where each row +in the query is an element of the given list. + +@catList@ is an inverse to 'manyExpr'. +-} catList :: Sql DBType a => Expr [a] -> Query (Expr a) catList = rebind "unnest" . unnest >=> extract --- | Expand an expression that contains a non-empty list into a 'Query', where --- each row in the query is an element of the given list. --- --- @catNonEmpty@ is an inverse to 'someExpr'. +{- | Expand an expression that contains a non-empty list into a 'Query', where +each row in the query is an element of the given list. + +@catNonEmpty@ is an inverse to 'someExpr'. +-} catNonEmpty :: Sql DBType a => Expr (NonEmpty a) -> Query (Expr a) catNonEmpty = rebind "unnest" . unnest >=> extract @@ -121,4 +135,4 @@ hextract = hrebind "extract" . go go as = htabulate $ \field -> case hfield as field of a -> case hfield hspecs field of - Spec {info} -> mapPrimExpr (extractArrayElement info) a + Spec{info} -> mapPrimExpr (extractArrayElement info) a diff --git a/src/Rel8/Query/Loop.hs b/src/Rel8/Query/Loop.hs index cdb9efb0..97af3ec9 100644 --- a/src/Rel8/Query/Loop.hs +++ b/src/Rel8/Query/Loop.hs @@ -1,29 +1,30 @@ -{-# language FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} -module Rel8.Query.Loop - ( loop - ) where +module Rel8.Query.Loop ( + loop, +) where -- base import Prelude -- opaleye -import Opaleye.With ( withRecursiveExplicit ) +import Opaleye.With (withRecursiveExplicit) -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Query ( Query ) -import Rel8.Query.Opaleye ( fromOpaleye, toOpaleye ) -import Rel8.Table ( Table ) -import Rel8.Table.Opaleye ( binaryspec ) +import Rel8.Expr (Expr) +import Rel8.Query (Query) +import Rel8.Query.Opaleye (fromOpaleye, toOpaleye) +import Rel8.Table (Table) +import Rel8.Table.Opaleye (binaryspec) --- | 'loop' allows the construction of recursive queries, using Postgres' --- [@WITH RECURSIVE@](https://www.postgresql.org/docs/current/queries-with.html#QUERIES-WITH-RECURSIVE) --- under the hood. The first argument to 'loop' is what the Postgres --- documentation refers to as the \"non-recursive term\" and the second --- argument is the \"recursive term\", which is defined in terms of the result --- of the \"non-recursive term\". +{- | 'loop' allows the construction of recursive queries, using Postgres' +[@WITH RECURSIVE@](https://www.postgresql.org/docs/current/queries-with.html#QUERIES-WITH-RECURSIVE) +under the hood. The first argument to 'loop' is what the Postgres +documentation refers to as the \"non-recursive term\" and the second +argument is the \"recursive term\", which is defined in terms of the result +of the \"non-recursive term\". +-} loop :: Table Expr a => Query a -> (a -> Query a) -> Query a loop base recurse = fromOpaleye $ withRecursiveExplicit binaryspec base' recurse' diff --git a/src/Rel8/Query/Materialize.hs b/src/Rel8/Query/Materialize.hs index 9e010d10..b4f5403f 100644 --- a/src/Rel8/Query/Materialize.hs +++ b/src/Rel8/Query/Materialize.hs @@ -1,42 +1,44 @@ -{-# language FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} -module Rel8.Query.Materialize - ( materialize - ) where +module Rel8.Query.Materialize ( + materialize, +) where -- base import Prelude -- opaleye -import Opaleye.With ( withExplicit ) +import Opaleye.With (withExplicit) -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Query ( Query ) -import Rel8.Query.Opaleye ( fromOpaleye, toOpaleye ) -import Rel8.Query.Rebind ( rebind ) -import Rel8.Table ( Table ) -import Rel8.Table.Opaleye ( unpackspec ) +import Rel8.Expr (Expr) +import Rel8.Query (Query) +import Rel8.Query.Opaleye (fromOpaleye, toOpaleye) +import Rel8.Query.Rebind (rebind) +import Rel8.Table (Table) +import Rel8.Table.Opaleye (unpackspec) --- | 'materialize' takes a 'Query' and fully evaluates it and caches the --- results thereof, and passes to a continuation a new 'Query' that simply --- looks up these cached results. It's usually best not to use this and to let --- the Postgres optimizer decide for itself what's best, but if you know what --- you're doing this can sometimes help to nudge it in a particular direction. --- --- 'materialize' is currently implemented in terms of Postgres' --- [@WITH](https://www.postgresql.org/docs/current/queries-with.html) syntax. --- Note that on newer versions of PostgreSQL starting with version 12, @WITH@ --- doesn't always automatically materialize if the results of the query aren't --- used more than once. We reserve the right to change the implementation of --- 'materialize' to use the newer @WITH foo AS MATERIALIZED bar@ syntax --- introduced in PostgreSQL 12 in the future. Currently Rel8 does not use --- @AS MATERIALIZED@ to support earlier PostgreSQL versions. +{- | 'materialize' takes a 'Query' and fully evaluates it and caches the +results thereof, and passes to a continuation a new 'Query' that simply +looks up these cached results. It's usually best not to use this and to let +the Postgres optimizer decide for itself what's best, but if you know what +you're doing this can sometimes help to nudge it in a particular direction. + +'materialize' is currently implemented in terms of Postgres' +[@WITH](https://www.postgresql.org/docs/current/queries-with.html) syntax. +Note that on newer versions of PostgreSQL starting with version 12, @WITH@ +doesn't always automatically materialize if the results of the query aren't +used more than once. We reserve the right to change the implementation of +'materialize' to use the newer @WITH foo AS MATERIALIZED bar@ syntax +introduced in PostgreSQL 12 in the future. Currently Rel8 does not use +@AS MATERIALIZED@ to support earlier PostgreSQL versions. +-} materialize :: Table Expr a => Query a -> (Query a -> Query b) -> Query b materialize query f = fromOpaleye $ - withExplicit unpackspec + withExplicit + unpackspec (toOpaleye query') (toOpaleye . f . fromOpaleye) where diff --git a/src/Rel8/Query/Maybe.hs b/src/Rel8/Query/Maybe.hs index ba272651..9188eb35 100644 --- a/src/Rel8/Query/Maybe.hs +++ b/src/Rel8/Query/Maybe.hs @@ -1,62 +1,65 @@ -{-# language GADTs #-} -{-# language LambdaCase #-} -{-# language NamedFieldPuns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} -module Rel8.Query.Maybe - ( optional - , catMaybeTable - , traverseMaybeTable - ) +module Rel8.Query.Maybe ( + optional, + catMaybeTable, + traverseMaybeTable, +) where -- base import Prelude -- comonad -import Control.Comonad ( extract ) +import Control.Comonad (extract) -- opaleye import qualified Opaleye.Internal.MaybeFields as Opaleye -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Expr.Eq ( (==.) ) -import Rel8.Query ( Query ) -import Rel8.Query.Filter ( where_ ) -import Rel8.Query.Opaleye ( mapOpaleye ) -import Rel8.Table.Maybe (MaybeTable(..), isJustTable, makeMaybeTable) +import Rel8.Expr (Expr) +import Rel8.Expr.Eq ((==.)) +import Rel8.Query (Query) +import Rel8.Query.Filter (where_) +import Rel8.Query.Opaleye (mapOpaleye) +import Rel8.Table.Maybe (MaybeTable (..), isJustTable, makeMaybeTable) --- | Convert a query that might return zero rows to a query that always returns --- at least one row. --- --- To speak in more concrete terms, 'optional' is most useful to write @LEFT --- JOIN@s. +{- | Convert a query that might return zero rows to a query that always returns +at least one row. + +To speak in more concrete terms, 'optional' is most useful to write @LEFT +JOIN@s. +-} optional :: Query a -> Query (MaybeTable Expr a) optional = mapOpaleye $ Opaleye.optionalInternal makeMaybeTable --- | Filter out 'MaybeTable's, returning only the tables that are not-null. --- --- This operation can be used to "undo" the effect of 'optional', which --- operationally is like turning a @LEFT JOIN@ back into a full @JOIN@. You --- can think of this as analogous to 'Data.Maybe.catMaybes'. +{- | Filter out 'MaybeTable's, returning only the tables that are not-null. + +This operation can be used to "undo" the effect of 'optional', which +operationally is like turning a @LEFT JOIN@ back into a full @JOIN@. You +can think of this as analogous to 'Data.Maybe.catMaybes'. +-} catMaybeTable :: MaybeTable Expr a -> Query a catMaybeTable ma@(MaybeTable _ a) = do where_ $ isJustTable ma pure (extract a) --- | Extend an optional query with another query. This is useful if you want --- to step through multiple @LEFT JOINs@. --- --- Note that @traverseMaybeTable@ takes a @a -> Query b@ function, which means --- you also have the ability to "expand" one row into multiple rows. If the --- @a -> Query b@ function returns no rows, then the resulting query will also --- have no rows. However, regardless of the given @a -> Query b@ function, if --- the input is @nothingTable@, you will always get exactly one @nothingTable@ --- back. -traverseMaybeTable :: (a -> Query b) -> MaybeTable Expr a -> Query (MaybeTable Expr b) +{- | Extend an optional query with another query. This is useful if you want +to step through multiple @LEFT JOINs@. + +Note that @traverseMaybeTable@ takes a @a -> Query b@ function, which means +you also have the ability to "expand" one row into multiple rows. If the +@a -> Query b@ function returns no rows, then the resulting query will also +have no rows. However, regardless of the given @a -> Query b@ function, if +the input is @nothingTable@, you will always get exactly one @nothingTable@ +back. +-} +traverseMaybeTable :: (a -> Query b) -> MaybeTable Expr a -> Query (MaybeTable Expr b) traverseMaybeTable query ma@(MaybeTable input _) = do optional (query =<< catMaybeTable ma) >>= \case MaybeTable output b -> do diff --git a/src/Rel8/Query/Null.hs b/src/Rel8/Query/Null.hs index af4d0dbd..5045d3f3 100644 --- a/src/Rel8/Query/Null.hs +++ b/src/Rel8/Query/Null.hs @@ -1,37 +1,39 @@ -{-# language FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} -module Rel8.Query.Null - ( catNull - , catNullTable - ) +module Rel8.Query.Null ( + catNull, + catNullTable, +) where -- base import Prelude -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Expr.Null ( isNonNull, unsafeUnnullify ) -import Rel8.Table ( Table ) -import Rel8.Table.Null ( NullTable, isNonNullTable, unsafeUnnullifyTable ) -import Rel8.Query ( Query ) -import Rel8.Query.Filter ( where_ ) - - --- | Filter a 'Query' that might return @null@ to a 'Query' without any --- @null@s. --- --- Corresponds to 'Data.Maybe.catMaybes'. +import Rel8.Expr (Expr) +import Rel8.Expr.Null (isNonNull, unsafeUnnullify) +import Rel8.Query (Query) +import Rel8.Query.Filter (where_) +import Rel8.Table (Table) +import Rel8.Table.Null (NullTable, isNonNullTable, unsafeUnnullifyTable) + + +{- | Filter a 'Query' that might return @null@ to a 'Query' without any +@null@s. + +Corresponds to 'Data.Maybe.catMaybes'. +-} catNull :: Expr (Maybe a) -> Query (Expr a) catNull a = do where_ $ isNonNull a pure $ unsafeUnnullify a --- | Filter a 'Query' that might return @nullTable@ to a 'Query' without any --- @nullTable@s. --- --- Corresponds to 'Data.Maybe.catMaybes'. +{- | Filter a 'Query' that might return @nullTable@ to a 'Query' without any +@nullTable@s. + +Corresponds to 'Data.Maybe.catMaybes'. +-} catNullTable :: Table Expr a => NullTable Expr a -> Query a catNullTable a = do where_ $ isNonNullTable a diff --git a/src/Rel8/Query/Opaleye.hs b/src/Rel8/Query/Opaleye.hs index 8e1601b2..c338db10 100644 --- a/src/Rel8/Query/Opaleye.hs +++ b/src/Rel8/Query/Opaleye.hs @@ -1,16 +1,16 @@ -{-# language TupleSections #-} - -module Rel8.Query.Opaleye - ( fromOpaleye - , toOpaleye - , mapOpaleye - , zipOpaleyeWith - , unsafePeekQuery - ) +{-# LANGUAGE TupleSections #-} + +module Rel8.Query.Opaleye ( + fromOpaleye, + toOpaleye, + mapOpaleye, + zipOpaleyeWith, + unsafePeekQuery, +) where -- base -import Control.Applicative ( liftA2 ) +import Control.Applicative (liftA2) import Prelude -- opaleye @@ -18,7 +18,7 @@ import qualified Opaleye.Internal.QueryArr as Opaleye import qualified Opaleye.Internal.Tag as Opaleye -- rel8 -import {-# SOURCE #-} Rel8.Query ( Query( Query ) ) +import {-# SOURCE #-} Rel8.Query (Query (Query)) fromOpaleye :: Opaleye.Select a -> Query a @@ -33,9 +33,12 @@ mapOpaleye :: (Opaleye.Select a -> Opaleye.Select b) -> Query a -> Query b mapOpaleye f (Query a) = Query (fmap (mapping f) a) -zipOpaleyeWith :: () - => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c) - -> Query a -> Query b -> Query c +zipOpaleyeWith :: + () => + (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c) -> + Query a -> + Query b -> + Query c zipOpaleyeWith f (Query a) (Query b) = Query $ liftA2 (zipping f) a b @@ -45,20 +48,25 @@ unsafePeekQuery (Query q) = case q mempty of ((_, a), _, _) -> a -mapping :: () - => (Opaleye.Select a -> Opaleye.Select b) - -> Opaleye.Select (m, a) -> Opaleye.Select (m, b) +mapping :: + () => + (Opaleye.Select a -> Opaleye.Select b) -> + Opaleye.Select (m, a) -> + Opaleye.Select (m, b) mapping f q = Opaleye.stateQueryArr $ \_ tag -> let ((m, _), _, _) = Opaleye.runStateQueryArr q () tag q' = (m,) <$> f (snd <$> q) - in + in Opaleye.runStateQueryArr q' () tag -zipping :: Semigroup m - => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c) - -> Opaleye.Select (m, a) -> Opaleye.Select (m, b) -> Opaleye.Select (m, c) +zipping :: + Semigroup m => + (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c) -> + Opaleye.Select (m, a) -> + Opaleye.Select (m, b) -> + Opaleye.Select (m, c) zipping f q q' = Opaleye.stateQueryArr $ \_ tag -> let @@ -66,5 +74,5 @@ zipping f q q' = ((m', _), _, _) = Opaleye.runStateQueryArr q' () tag m'' = m <> m' q'' = (m'',) <$> f (snd <$> q) (snd <$> q') - in + in Opaleye.runStateQueryArr q'' () tag diff --git a/src/Rel8/Query/Order.hs b/src/Rel8/Query/Order.hs index b98246cc..d1cca32c 100644 --- a/src/Rel8/Query/Order.hs +++ b/src/Rel8/Query/Order.hs @@ -1,18 +1,18 @@ -module Rel8.Query.Order - ( orderBy - ) +module Rel8.Query.Order ( + orderBy, +) where -- base import Prelude () -- opaleye -import qualified Opaleye.Order as Opaleye ( orderBy ) +import qualified Opaleye.Order as Opaleye (orderBy) -- rel8 -import Rel8.Order ( Order( Order ) ) -import Rel8.Query ( Query ) -import Rel8.Query.Opaleye ( mapOpaleye ) +import Rel8.Order (Order (Order)) +import Rel8.Query (Query) +import Rel8.Query.Opaleye (mapOpaleye) -- | Order the rows returned by a query. diff --git a/src/Rel8/Query/Rebind.hs b/src/Rel8/Query/Rebind.hs index 159ef012..45ab0174 100644 --- a/src/Rel8/Query/Rebind.hs +++ b/src/Rel8/Query/Rebind.hs @@ -1,31 +1,34 @@ -{-# language FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} -module Rel8.Query.Rebind - ( rebind - , hrebind - ) +module Rel8.Query.Rebind ( + rebind, + hrebind, +) where -- base -import Prelude + +-- base import Control.Arrow ((<<<)) +import Prelude -- opaleye import qualified Opaleye.Internal.Rebind as Opaleye -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Query ( Query ) +import Rel8.Expr (Expr) +import Rel8.Query (Query) +import Rel8.Query.Opaleye (fromOpaleye) import Rel8.Schema.HTable (HTable) -import Rel8.Table ( Table ) +import Rel8.Table (Table) import Rel8.Table.Cols (Cols (Cols)) -import Rel8.Table.Opaleye ( unpackspec ) -import Rel8.Query.Opaleye (fromOpaleye) +import Rel8.Table.Opaleye (unpackspec) --- | 'rebind' takes a variable name, some expressions, and binds each of them --- to a new variable in the SQL. The @a@ returned consists only of these --- variables. It's essentially a @let@ binding for Postgres expressions. +{- | 'rebind' takes a variable name, some expressions, and binds each of them +to a new variable in the SQL. The @a@ returned consists only of these +variables. It's essentially a @let@ binding for Postgres expressions. +-} rebind :: Table Expr a => String -> a -> Query a rebind prefix a = fromOpaleye (Opaleye.rebindExplicitPrefix prefix unpackspec <<< pure a) diff --git a/src/Rel8/Query/SQL.hs b/src/Rel8/Query/SQL.hs index 73158bb2..2edfad54 100644 --- a/src/Rel8/Query/SQL.hs +++ b/src/Rel8/Query/SQL.hs @@ -1,19 +1,19 @@ -{-# language FlexibleContexts #-} -{-# language MonoLocalBinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} -module Rel8.Query.SQL - ( showQuery - ) +module Rel8.Query.SQL ( + showQuery, +) where -- base import Prelude -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Query ( Query ) -import Rel8.Statement.Select ( ppSelect ) -import Rel8.Table ( Table ) +import Rel8.Expr (Expr) +import Rel8.Query (Query) +import Rel8.Statement.Select (ppSelect) +import Rel8.Table (Table) -- | Convert a 'Query' to a 'String' containing a @SELECT@ statement. diff --git a/src/Rel8/Query/Set.hs b/src/Rel8/Query/Set.hs index d384262e..ece172de 100644 --- a/src/Rel8/Query/Set.hs +++ b/src/Rel8/Query/Set.hs @@ -1,10 +1,13 @@ -{-# language FlexibleContexts #-} - -module Rel8.Query.Set - ( union, unionAll - , intersect, intersectAll - , except, exceptAll - ) +{-# LANGUAGE FlexibleContexts #-} + +module Rel8.Query.Set ( + union, + unionAll, + intersect, + intersectAll, + except, + exceptAll, +) where -- base @@ -14,45 +17,51 @@ import Prelude () import qualified Opaleye.Binary as Opaleye -- rel8 -import Rel8.Expr ( Expr ) -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.Expr (Expr) +import {-# SOURCE #-} Rel8.Query (Query) +import Rel8.Query.Opaleye (zipOpaleyeWith) +import Rel8.Table (Table) +import Rel8.Table.Eq (EqTable) +import Rel8.Table.Opaleye (binaryspec) --- | Combine the results of two queries of the same type, collapsing --- duplicates. @union a b@ is the same as the SQL statement @a UNION b@. +{- | Combine the results of two queries of the same type, collapsing +duplicates. @union a b@ is the same as the SQL statement @a UNION b@. +-} union :: EqTable a => Query a -> Query a -> Query a union = zipOpaleyeWith (Opaleye.unionExplicit binaryspec) --- | Combine the results of two queries of the same type, retaining duplicates. --- @unionAll a b@ is the same as the SQL statement @a UNION ALL b@. +{- | Combine the results of two queries of the same type, retaining duplicates. +@unionAll a b@ is the same as the SQL statement @a UNION ALL b@. +-} unionAll :: Table Expr a => Query a -> Query a -> Query a unionAll = zipOpaleyeWith (Opaleye.unionAllExplicit binaryspec) --- | Find the intersection of two queries, collapsing duplicates. @intersect a --- b@ is the same as the SQL statement @a INTERSECT b@. +{- | Find the intersection of two queries, collapsing duplicates. @intersect a +b@ is the same as the SQL statement @a INTERSECT b@. +-} intersect :: EqTable a => Query a -> Query a -> Query a intersect = zipOpaleyeWith (Opaleye.intersectExplicit binaryspec) --- | Find the intersection of two queries, retaining duplicates. @intersectAll --- a b@ is the same as the SQL statement @a INTERSECT ALL b@. +{- | Find the intersection of two queries, retaining duplicates. @intersectAll +a b@ is the same as the SQL statement @a INTERSECT ALL b@. +-} intersectAll :: EqTable a => Query a -> Query a -> Query a intersectAll = zipOpaleyeWith (Opaleye.intersectAllExplicit binaryspec) --- | Find the difference of two queries, collapsing duplicates @except a b@ is --- the same as the SQL statement @a EXCEPT b@. +{- | Find the difference of two queries, collapsing duplicates @except a b@ is +the same as the SQL statement @a EXCEPT b@. +-} except :: EqTable a => Query a -> Query a -> Query a except = zipOpaleyeWith (Opaleye.exceptExplicit binaryspec) --- | Find the difference of two queries, retaining duplicates. @exceptAll a b@ --- is the same as the SQL statement @a EXCEPT ALL b@. +{- | Find the difference of two queries, retaining duplicates. @exceptAll a b@ +is the same as the SQL statement @a EXCEPT ALL b@. +-} exceptAll :: EqTable a => Query a -> Query a -> Query a exceptAll = zipOpaleyeWith (Opaleye.exceptAllExplicit binaryspec) diff --git a/src/Rel8/Query/These.hs b/src/Rel8/Query/These.hs index 05336628..6d651005 100644 --- a/src/Rel8/Query/These.hs +++ b/src/Rel8/Query/These.hs @@ -1,22 +1,27 @@ -{-# language FlexibleContexts #-} -{-# language GADTs #-} - -module Rel8.Query.These - ( alignBy - , keepHereTable, loseHereTable - , keepThereTable, loseThereTable - , keepThisTable, loseThisTable - , keepThatTable, loseThatTable - , keepThoseTable, loseThoseTable - , bitraverseTheseTable - ) +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} + +module Rel8.Query.These ( + alignBy, + keepHereTable, + loseHereTable, + keepThereTable, + loseThereTable, + keepThisTable, + loseThisTable, + keepThatTable, + loseThatTable, + keepThoseTable, + loseThoseTable, + bitraverseTheseTable, +) where -- base import Prelude -- comonad -import Control.Comonad ( extract ) +import Control.Comonad (extract) -- opaleye import qualified Opaleye.Internal.PackMap as Opaleye @@ -25,29 +30,35 @@ import qualified Opaleye.Internal.QueryArr as Opaleye import qualified Opaleye.Internal.Tag as Opaleye -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Expr.Bool ( boolExpr, not_ ) -import Rel8.Expr.Eq ( (==.) ) -import Rel8.Expr.Opaleye ( toPrimExpr, traversePrimExpr ) -import Rel8.Expr.Serialize ( litExpr ) -import Rel8.Query ( Query ) -import Rel8.Query.Filter ( where_ ) -import Rel8.Query.Maybe ( optional ) -import Rel8.Query.Opaleye ( zipOpaleyeWith ) -import Rel8.Table.Either ( EitherTable( EitherTable ) ) -import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable ) -import Rel8.Table.These - ( TheseTable( TheseTable, here, there ) - , hasHereTable, hasThereTable - , isThisTable, isThatTable, isThoseTable - ) -import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ) ) +import Rel8.Expr (Expr) +import Rel8.Expr.Bool (boolExpr, not_) +import Rel8.Expr.Eq ((==.)) +import Rel8.Expr.Opaleye (toPrimExpr, traversePrimExpr) +import Rel8.Expr.Serialize (litExpr) +import Rel8.Query (Query) +import Rel8.Query.Filter (where_) +import Rel8.Query.Maybe (optional) +import Rel8.Query.Opaleye (zipOpaleyeWith) +import Rel8.Table.Either (EitherTable (EitherTable)) +import Rel8.Table.Maybe (MaybeTable (MaybeTable), isJustTable) +import Rel8.Table.These ( + TheseTable (TheseTable, here, there), + hasHereTable, + hasThereTable, + isThatTable, + isThisTable, + isThoseTable, + ) +import Rel8.Type.Tag (EitherTag (IsLeft, IsRight)) -- | Corresponds to a @FULL OUTER JOIN@ between two queries. -alignBy :: () - => (a -> b -> Expr Bool) - -> Query a -> Query b -> Query (TheseTable Expr a b) +alignBy :: + () => + (a -> b -> Expr Bool) -> + Query a -> + Query b -> + Query (TheseTable Expr a b) alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.stateQueryArr $ \_ t -> case t of tag -> (tab, join', tag''') where @@ -67,7 +78,7 @@ alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.stateQueryArr $ \_ t right'' = (Opaleye.NonLateral, Opaleye.toPrimQuery (right' <> Opaleye.aRebind rbindings)) ma' = MaybeTable hasHere' a mb' = MaybeTable hasThere' b - tab = TheseTable {here = ma', there = mb'} + tab = TheseTable{here = ma', there = mb'} join' = Opaleye.aProduct join @@ -125,11 +136,12 @@ loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do tag = boolExpr (litExpr IsLeft) (litExpr IsRight) (isThatTable t) -bitraverseTheseTable :: () - => (a -> Query c) - -> (b -> Query d) - -> TheseTable Expr a b - -> Query (TheseTable Expr c d) +bitraverseTheseTable :: + () => + (a -> Query c) -> + (b -> Query d) -> + TheseTable Expr a b -> + Query (TheseTable Expr c d) bitraverseTheseTable f g t = do mc <- optional (f . fst =<< keepHereTable t) md <- optional (g . snd =<< keepThereTable t) diff --git a/src/Rel8/Query/Values.hs b/src/Rel8/Query/Values.hs index 728eac25..4c841f59 100644 --- a/src/Rel8/Query/Values.hs +++ b/src/Rel8/Query/Values.hs @@ -1,27 +1,28 @@ -{-# language FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} -module Rel8.Query.Values - ( values - ) +module Rel8.Query.Values ( + values, +) where -- base -import Data.Foldable ( toList ) +import Data.Foldable (toList) import Prelude -- opaleye import qualified Opaleye.Values as Opaleye -- rel8 -import Rel8.Expr ( Expr ) -import {-# SOURCE #-} Rel8.Query ( Query ) -import Rel8.Query.Opaleye ( fromOpaleye ) -import Rel8.Table ( Table ) -import Rel8.Table.Opaleye ( valuesspec ) +import Rel8.Expr (Expr) +import {-# SOURCE #-} Rel8.Query (Query) +import Rel8.Query.Opaleye (fromOpaleye) +import Rel8.Table (Table) +import Rel8.Table.Opaleye (valuesspec) --- | Construct a query that returns the given input list of rows. This is like --- folding a list of 'return' statements under 'Rel8.union', but uses the SQL --- @VALUES@ expression for efficiency. +{- | Construct a query that returns the given input list of rows. This is like +folding a list of 'return' statements under 'Rel8.union', but uses the SQL +@VALUES@ expression for efficiency. +-} values :: (Table Expr a, Foldable f) => f a -> Query a values = fromOpaleye . Opaleye.valuesExplicit valuesspec . toList diff --git a/src/Rel8/Query/Window.hs b/src/Rel8/Query/Window.hs index 75c1a997..bcfa1c5a 100644 --- a/src/Rel8/Query/Window.hs +++ b/src/Rel8/Query/Window.hs @@ -1,6 +1,6 @@ -module Rel8.Query.Window - ( window - ) +module Rel8.Query.Window ( + window, +) where -- base @@ -10,17 +10,18 @@ import Prelude () import qualified Opaleye.Window as Opaleye -- rel8 -import Rel8.Query ( Query ) -import Rel8.Query.Opaleye ( mapOpaleye ) -import Rel8.Window ( Window( Window ) ) +import Rel8.Query (Query) +import Rel8.Query.Opaleye (mapOpaleye) +import Rel8.Window (Window (Window)) --- | 'window' runs a query composed of expressions containing --- [window functions](https://www.postgresql.org/docs/current/tutorial-window.html). --- 'window' is similar to 'Rel8.aggregate', with the main difference being --- that in a window query, each input row corresponds to one output row, --- whereas aggregation queries fold the entire input query down into a single --- row. To put this into a Haskell context, 'Rel8.aggregate' is to 'foldl' as --- 'window' is to 'scanl'. +{- | 'window' runs a query composed of expressions containing +[window functions](https://www.postgresql.org/docs/current/tutorial-window.html). +'window' is similar to 'Rel8.aggregate', with the main difference being +that in a window query, each input row corresponds to one output row, +whereas aggregation queries fold the entire input query down into a single +row. To put this into a Haskell context, 'Rel8.aggregate' is to 'foldl' as +'window' is to 'scanl'. +-} window :: Window a b -> Query a -> Query b window (Window a) = mapOpaleye (Opaleye.runWindows a) diff --git a/src/Rel8/Schema/Context/Nullify.hs b/src/Rel8/Schema/Context/Nullify.hs index d980a1a9..1b27ceb5 100644 --- a/src/Rel8/Schema/Context/Nullify.hs +++ b/src/Rel8/Schema/Context/Nullify.hs @@ -1,39 +1,45 @@ -{-# language DataKinds #-} -{-# language EmptyCase #-} -{-# language FlexibleContexts #-} -{-# language GADTs #-} -{-# language LambdaCase #-} -{-# language NamedFieldPuns #-} -{-# language StandaloneKindSignatures #-} - -module Rel8.Schema.Context.Nullify - ( Nullifiability(..), NonNullifiability(..), nullifiableOrNot, absurd - , Nullifiable, nullifiability - , guarder, nullifier, unnullifier - ) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE StandaloneKindSignatures #-} + +module Rel8.Schema.Context.Nullify ( + Nullifiability (..), + NonNullifiability (..), + nullifiableOrNot, + absurd, + Nullifiable, + nullifiability, + guarder, + nullifier, + unnullifier, +) where -- base -import Data.Bool ( bool ) -import Data.Functor.Identity ( Identity( Identity ) ) -import Data.Kind ( Constraint, Type ) -import Prelude hiding ( null ) +import Data.Bool (bool) +import Data.Functor.Identity (Identity (Identity)) +import Data.Kind (Constraint, Type) +import Prelude hiding (null) -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Expr.Bool ( boolExpr ) -import Rel8.Expr.Null ( nullify, unsafeUnnullify ) -import Rel8.Expr.Opaleye ( fromPrimExpr ) -import Rel8.Kind.Context ( SContext(..) ) -import Rel8.Schema.Field ( Field ) +import Rel8.Expr (Expr) +import Rel8.Expr.Bool (boolExpr) +import Rel8.Expr.Null (nullify, unsafeUnnullify) +import Rel8.Expr.Opaleye (fromPrimExpr) +import Rel8.Kind.Context (SContext (..)) +import Rel8.Schema.Field (Field) import qualified Rel8.Schema.Kind as K -import Rel8.Schema.Name ( Name( Name ) ) -import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) ) -import Rel8.Schema.Result ( Result ) -import Rel8.Schema.Spec ( Spec(..) ) +import Rel8.Schema.Name (Name (Name)) +import Rel8.Schema.Null (Nullify, Nullity (NotNull, Null)) +import Rel8.Schema.Result (Result) +import Rel8.Schema.Spec (Spec (..)) type Nullifiability :: K.Context -> Type @@ -61,9 +67,10 @@ data NonNullifiability context where NResult :: NonNullifiability Result -nullifiableOrNot :: () - => SContext context - -> Either (NonNullifiability context) (Nullifiability context) +nullifiableOrNot :: + () => + SContext context -> + Either (NonNullifiability context) (Nullifiability context) nullifiableOrNot = \case SExpr -> Right NExpr SField -> Left NField @@ -73,17 +80,18 @@ nullifiableOrNot = \case absurd :: Nullifiability context -> NonNullifiability context -> a absurd = \case - NExpr -> \case - NName -> \case - - -guarder :: () - => SContext context - -> context tag - -> (tag -> Bool) - -> (Expr tag -> Expr Bool) - -> context (Maybe a) - -> context (Maybe a) + NExpr -> \case {} + NName -> \case {} + + +guarder :: + () => + SContext context -> + context tag -> + (tag -> Bool) -> + (Expr tag -> Expr Bool) -> + context (Maybe a) -> + context (Maybe a) guarder = \case SExpr -> \tag _ isNonNull -> sguard (isNonNull tag) SField -> \_ _ _ -> id @@ -92,23 +100,25 @@ guarder = \case Identity (bool Nothing a (isNonNull tag)) -nullifier :: () - => Nullifiability context - -> Spec a - -> context a - -> context (Nullify a) +nullifier :: + () => + Nullifiability context -> + Spec a -> + context a -> + context (Nullify a) nullifier = \case - NExpr -> \Spec {nullity} a -> snullify nullity a + NExpr -> \Spec{nullity} a -> snullify nullity a NName -> \_ (Name a) -> Name a -unnullifier :: () - => Nullifiability context - -> Spec a - -> context (Nullify a) - -> context a +unnullifier :: + () => + Nullifiability context -> + Spec a -> + context (Nullify a) -> + context a unnullifier = \case - NExpr -> \Spec {nullity} a -> sunnullify nullity a + NExpr -> \Spec{nullity} a -> sunnullify nullity a NName -> \_ (Name a) -> Name a diff --git a/src/Rel8/Schema/Dict.hs b/src/Rel8/Schema/Dict.hs index 90a2fddb..eb6bc0f3 100644 --- a/src/Rel8/Schema/Dict.hs +++ b/src/Rel8/Schema/Dict.hs @@ -1,15 +1,15 @@ -{-# language ConstraintKinds #-} -{-# language GADTs #-} -{-# language PolyKinds #-} -{-# language StandaloneKindSignatures #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} -module Rel8.Schema.Dict - ( Dict( Dict ) - ) +module Rel8.Schema.Dict ( + Dict (Dict), +) where -- base -import Data.Kind ( Constraint, Type ) +import Data.Kind (Constraint, Type) import Prelude () diff --git a/src/Rel8/Schema/Field.hs b/src/Rel8/Schema/Field.hs index 5e8f5d6a..71bb98ec 100644 --- a/src/Rel8/Schema/Field.hs +++ b/src/Rel8/Schema/Field.hs @@ -1,32 +1,38 @@ -{-# language DataKinds #-} -{-# language FlexibleContexts #-} -{-# language MultiParamTypeClasses #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeFamilies #-} - -module Rel8.Schema.Field - ( Field(..) - , fields - ) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} + +module Rel8.Schema.Field ( + Field (..), + fields, +) where -- base -import Data.Functor.Identity ( Identity( Identity ) ) -import Data.Kind ( Type ) +import Data.Functor.Identity (Identity (Identity)) +import Data.Kind (Type) import Prelude -- rel8 -import Rel8.Schema.HTable ( HField, htabulate ) -import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) ) +import Rel8.Schema.HTable (HField, htabulate) +import Rel8.Schema.HTable.Identity (HIdentity (HIdentity)) import Rel8.Schema.Kind as K -import Rel8.Schema.Null ( Sql ) -import Rel8.Table - ( Table, Columns, Context, fromColumns, toColumns - , FromExprs, fromResult, toResult - , Transpose - ) -import Rel8.Table.Transpose ( Transposes ) -import Rel8.Type ( DBType ) +import Rel8.Schema.Null (Sql) +import Rel8.Table ( + Columns, + Context, + FromExprs, + Table, + Transpose, + fromColumns, + fromResult, + toColumns, + toResult, + ) +import Rel8.Table.Transpose (Transposes) +import Rel8.Type (DBType) -- | A special context used in the construction of 'Rel8.Projection's. @@ -40,6 +46,7 @@ instance Sql DBType a => Table (Field table) (Field table a) where type FromExprs (Field table a) = a type Transpose to (Field table a) = to a + toColumns = HIdentity fromColumns (HIdentity a) = a toResult a = HIdentity (Identity a) diff --git a/src/Rel8/Schema/HTable.hs b/src/Rel8/Schema/HTable.hs index 62e8a76a..986cba91 100644 --- a/src/Rel8/Schema/HTable.hs +++ b/src/Rel8/Schema/HTable.hs @@ -1,156 +1,202 @@ -{-# 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 - , hfoldMap, hmap, htabulateA, htraverseP, htraversePWithField - ) +{-# 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, + hfoldMap, + hmap, + htabulateA, + htraverseP, + htraversePWithField, +) where -- base -import Data.Functor.Const ( Const( Const ), getConst ) -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 --- profunctors -import Data.Profunctor ( rmap, Profunctor (lmap) ) +-- base +import Data.Functor.Compose (Compose (Compose), getCompose) +import Data.Functor.Const (Const (Const), getConst) +import Data.Kind (Constraint, Type) +import Data.Proxy (Proxy) +import GHC.Generics ( + Generic (Rep, from, to), + K1 (K1), + M1 (M1), + (:*:) ((:*:)), + ) +import Prelude -- product-profunctors -import Data.Profunctor.Product ( ProductProfunctor ((****)) ) +import Data.Profunctor.Product (ProductProfunctor ((****))) + +-- profunctors +import Data.Profunctor (Profunctor (lmap), rmap) -- rel8 -import Rel8.Schema.Dict ( Dict ) -import Rel8.Schema.Spec ( Spec ) -import Rel8.Schema.HTable.Product ( HProduct( HProduct ) ) +import Rel8.Schema.Dict (Dict) +import Rel8.Schema.HTable.Product (HProduct (HProduct)) import qualified Rel8.Schema.Kind as K +import Rel8.Schema.Spec (Spec) -- semigroupoids -import Data.Functor.Apply ( Apply, (<.>) ) - --- | A @HTable@ is a functor-indexed/higher-kinded data type that is --- representable ('htabulate'/'hfield'), constrainable ('hdicts'), and --- specified ('hspecs'). --- --- This is an internal concept for Rel8, and you should not need to define --- instances yourself or specify this constraint. +import Data.Functor.Apply (Apply, (<.>)) + + +{- | A @HTable@ is a functor-indexed/higher-kinded data type that is +representable ('htabulate'/'hfield'), constrainable ('hdicts'), and +specified ('hspecs'). + +This is an internal concept for Rel8, and you should not need to define +instances yourself or specify this constraint. +-} type HTable :: K.HTable -> Constraint class HTable t where type HField t = (field :: Type -> Type) | field -> t type HConstrainTable t (c :: Type -> Constraint) :: Constraint + hfield :: t context -> HField t a -> context a htabulate :: (forall a. HField t a -> context a) -> t context htraverse :: Apply m => (forall a. f a -> m (g a)) -> t f -> m (t g) hdicts :: HConstrainTable t c => t (Dict c) hspecs :: t Spec + type HField t = GHField t type HConstrainTable t c = HConstrainTable (GHColumns (Rep (t Proxy))) c + default hfield :: ( Generic (t context) , HField t ~ GHField t , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context))) , GHTable context (Rep (t context)) - ) - => t context -> HField t a -> context a + ) => + t context -> + HField t a -> + context a hfield table (GHField field) = hfield (toGHColumns (from table)) field + default htabulate :: ( Generic (t context) , HField t ~ GHField t , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context))) , GHTable context (Rep (t context)) - ) - => (forall a. HField t a -> context a) -> t context + ) => + (forall a. HField t a -> context a) -> + t context htabulate f = to $ fromGHColumns $ htabulate (f . GHField) - default htraverse - :: forall f g m - . ( Apply m - , Generic (t f), GHTable f (Rep (t f)) - , Generic (t g), GHTable g (Rep (t g)) - , GHColumns (Rep (t f)) ~ GHColumns (Rep (t g)) - ) - => (forall a. f a -> m (g a)) -> t f -> m (t g) + + default htraverse :: + forall f g m. + ( Apply m + , Generic (t f) + , GHTable f (Rep (t f)) + , Generic (t g) + , GHTable g (Rep (t g)) + , GHColumns (Rep (t f)) ~ GHColumns (Rep (t g)) + ) => + (forall a. f a -> m (g a)) -> + t f -> + m (t g) htraverse f = fmap (to . fromGHColumns) . htraverse f . toGHColumns . from - default hdicts - :: forall c - . ( Generic (t (Dict c)) - , GHTable (Dict c) (Rep (t (Dict c))) - , GHColumns (Rep (t Proxy)) ~ GHColumns (Rep (t (Dict c))) - , HConstrainTable (GHColumns (Rep (t Proxy))) c - ) - => t (Dict c) + + default hdicts :: + forall c. + ( Generic (t (Dict c)) + , GHTable (Dict c) (Rep (t (Dict c))) + , GHColumns (Rep (t Proxy)) ~ GHColumns (Rep (t (Dict c))) + , HConstrainTable (GHColumns (Rep (t Proxy))) c + ) => + t (Dict c) hdicts = to $ fromGHColumns (hdicts @(GHColumns (Rep (t Proxy))) @c) + default hspecs :: ( Generic (t Spec) , GHTable Spec (Rep (t Spec)) - ) - => t Spec + ) => + t Spec hspecs = to $ fromGHColumns hspecs - {-# INLINABLE hfield #-} - {-# INLINABLE htabulate #-} - {-# INLINABLE htraverse #-} - {-# INLINABLE hdicts #-} - {-# INLINABLE hspecs #-} + + {-# INLINEABLE hfield #-} + {-# INLINEABLE htabulate #-} + {-# INLINEABLE htraverse #-} + {-# INLINEABLE hdicts #-} + {-# INLINEABLE hspecs #-} -hfoldMap :: (HTable t, Semigroup s) - => (forall a. context a -> s) -> t context -> s +hfoldMap :: + (HTable t, Semigroup s) => + (forall a. context a -> s) -> + t context -> + s hfoldMap f a = getConst $ htraverse (Const . f) a -hmap :: HTable t - => (forall a. context a -> context' a) -> t context -> t context' +hmap :: + HTable t => + (forall a. context a -> context' a) -> + t context -> + t context' hmap f a = htabulate $ \field -> f (hfield a field) -htabulateA :: (HTable t, Apply m) - => (forall a. HField t a -> m (context a)) -> m (t context) +htabulateA :: + (HTable t, Apply m) => + (forall a. HField t a -> m (context a)) -> + m (t context) htabulateA f = htraverse getCompose $ htabulate $ Compose . f -{-# INLINABLE htabulateA #-} +{-# INLINEABLE htabulateA #-} + + +newtype ApplyP p a b = ApplyP {unApplyP :: p a b} -newtype ApplyP p a b = ApplyP { unApplyP :: p a b } instance Profunctor p => Functor (ApplyP p a) where fmap f = ApplyP . rmap f . unApplyP + instance ProductProfunctor p => Apply (ApplyP p a) where ApplyP f <.> ApplyP x = ApplyP (rmap id f **** x) -htraverseP :: (HTable t, ProductProfunctor p) - => (forall a. p (f a) (g a)) -> p (t f) (t g) + +htraverseP :: + (HTable t, ProductProfunctor p) => + (forall a. p (f a) (g a)) -> + p (t f) (t g) htraverseP f = htraversePWithField (const f) -htraversePWithField :: (HTable t, ProductProfunctor p) - => (forall a. HField t a -> p (f a) (g a)) -> p (t f) (t g) -htraversePWithField f = unApplyP $ htabulateA $ \field -> ApplyP $ - lmap (flip hfield field) (f field) + +htraversePWithField :: + (HTable t, ProductProfunctor p) => + (forall a. HField t a -> p (f a) (g a)) -> + p (t f) (t g) +htraversePWithField f = unApplyP $ htabulateA $ \field -> + ApplyP $ + lmap (flip hfield field) (f field) + type GHField :: K.HTable -> Type -> Type newtype GHField t a = GHField (HField (GHColumns (Rep (t Proxy))) a) @@ -192,17 +238,20 @@ instance (HTable x, HTable y) => HTable (HProduct x y) where type HConstrainTable (HProduct x y) c = (HConstrainTable x c, HConstrainTable y c) type HField (HProduct x y) = HProductField x y + hfield (HProduct l r) = \case HFst i -> hfield l i HSnd i -> hfield r i + htabulate f = HProduct (htabulate (f . HFst)) (htabulate (f . HSnd)) htraverse f (HProduct x y) = HProduct <$> htraverse f x <.> htraverse f y hdicts = HProduct hdicts hdicts hspecs = HProduct hspecs hspecs - {-# INLINABLE hfield #-} - {-# INLINABLE htabulate #-} - {-# INLINABLE htraverse #-} - {-# INLINABLE hdicts #-} - {-# INLINABLE hspecs #-} + + {-# INLINEABLE hfield #-} + {-# INLINEABLE htabulate #-} + {-# INLINEABLE htraverse #-} + {-# INLINEABLE hdicts #-} + {-# INLINEABLE hspecs #-} diff --git a/src/Rel8/Schema/HTable/Either.hs b/src/Rel8/Schema/HTable/Either.hs index a3ff5a75..6b6f51e0 100644 --- a/src/Rel8/Schema/HTable/Either.hs +++ b/src/Rel8/Schema/HTable/Either.hs @@ -1,25 +1,25 @@ -{-# language DataKinds #-} -{-# language DeriveAnyClass #-} -{-# language DeriveGeneric #-} -{-# language DerivingStrategies #-} -{-# language StandaloneKindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE StandaloneKindSignatures #-} -module Rel8.Schema.HTable.Either - ( HEitherTable(..) - ) +module Rel8.Schema.HTable.Either ( + HEitherTable (..), +) where -- base -import GHC.Generics ( Generic ) +import GHC.Generics (Generic) import Prelude () -- rel8 -import Rel8.Schema.HTable ( HTable ) -import Rel8.Schema.HTable.Identity ( HIdentity ) -import Rel8.Schema.HTable.Label ( HLabel ) -import Rel8.Schema.HTable.Nullify ( HNullify ) +import Rel8.Schema.HTable (HTable) +import Rel8.Schema.HTable.Identity (HIdentity) +import Rel8.Schema.HTable.Label (HLabel) +import Rel8.Schema.HTable.Nullify (HNullify) import qualified Rel8.Schema.Kind as K -import Rel8.Type.Tag ( EitherTag ) +import Rel8.Type.Tag (EitherTag) type HEitherTable :: K.HTable -> K.HTable -> K.HTable @@ -28,5 +28,5 @@ data HEitherTable left right context = HEitherTable , hleft :: HLabel "Left" (HNullify left) context , hright :: HLabel "Right" (HNullify right) context } - deriving stock Generic - deriving anyclass HTable + deriving stock (Generic) + deriving anyclass (HTable) diff --git a/src/Rel8/Schema/HTable/Identity.hs b/src/Rel8/Schema/HTable/Identity.hs index 3f96a346..9e1b49e0 100644 --- a/src/Rel8/Schema/HTable/Identity.hs +++ b/src/Rel8/Schema/HTable/Identity.hs @@ -1,29 +1,35 @@ -{-# language DataKinds #-} -{-# language FlexibleContexts #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeFamilies #-} -{-# language UndecidableInstances #-} - -module Rel8.Schema.HTable.Identity - ( HIdentity( HIdentity, unHIdentity ) - ) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Rel8.Schema.HTable.Identity ( + HIdentity (HIdentity, unHIdentity), +) where -- base -import Data.Kind ( Type ) -import Data.Type.Equality ( (:~:)( Refl ) ) +import Data.Kind (Type) +import Data.Type.Equality ((:~:) (Refl)) import Prelude -- rel8 -import Rel8.Schema.Dict ( Dict( Dict ) ) -import Rel8.Schema.HTable - ( HTable, HConstrainTable, HField - , hfield, htabulate, htraverse, hdicts, hspecs - ) +import Rel8.Schema.Dict (Dict (Dict)) +import Rel8.Schema.HTable ( + HConstrainTable, + HField, + HTable, + hdicts, + hfield, + hspecs, + htabulate, + htraverse, + ) import qualified Rel8.Schema.Kind as K -import Rel8.Schema.Null ( Sql ) -import Rel8.Schema.Spec ( specification ) -import Rel8.Type ( DBType ) +import Rel8.Schema.Null (Sql) +import Rel8.Schema.Spec (specification) +import Rel8.Type (DBType) type HIdentity :: Type -> K.HTable @@ -36,6 +42,7 @@ instance Sql DBType a => HTable (HIdentity a) where type HConstrainTable (HIdentity a) constraint = constraint a type HField (HIdentity a) = (:~:) a + hfield (HIdentity a) Refl = a htabulate f = HIdentity $ f Refl htraverse f (HIdentity a) = HIdentity <$> f a diff --git a/src/Rel8/Schema/HTable/Label.hs b/src/Rel8/Schema/HTable/Label.hs index 43c1843f..b62f0d9e 100644 --- a/src/Rel8/Schema/HTable/Label.hs +++ b/src/Rel8/Schema/HTable/Label.hs @@ -1,30 +1,39 @@ -{-# language DataKinds #-} -{-# language RankNTypes #-} -{-# language RecordWildCards #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeApplications #-} -{-# language TypeFamilies #-} - -module Rel8.Schema.HTable.Label - ( HLabel, hlabel, hrelabel, hunlabel - , hproject - ) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Rel8.Schema.HTable.Label ( + HLabel, + hlabel, + hrelabel, + hunlabel, + hproject, +) where -- base -import Data.Kind ( Type ) -import Data.Proxy ( Proxy( Proxy ) ) -import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal ) +import Data.Kind (Type) +import Data.Proxy (Proxy (Proxy)) +import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) import Prelude -- rel8 -import Rel8.Schema.HTable - ( HTable, HConstrainTable, HField - , htabulate, hfield, htraverse, hdicts, hspecs - ) +import Rel8.Schema.HTable ( + HConstrainTable, + HField, + HTable, + hdicts, + hfield, + hspecs, + htabulate, + htraverse, + ) import qualified Rel8.Schema.Kind as K -import Rel8.Schema.Spec ( Spec(..) ) +import Rel8.Schema.Spec (Spec (..)) type HLabel :: Symbol -> K.HTable -> K.HTable @@ -37,34 +46,38 @@ newtype HLabelField label table a = HLabelField (HField table a) instance (HTable table, KnownSymbol label) => HTable (HLabel label table) where type HField (HLabel label table) = HLabelField label table - type HConstrainTable (HLabel label table) constraint = - HConstrainTable table constraint + type + HConstrainTable (HLabel label table) constraint = + HConstrainTable table constraint + hfield (HLabel a) (HLabelField field) = hfield a field htabulate f = HLabel (htabulate (f . HLabelField)) htraverse f (HLabel a) = HLabel <$> htraverse f a hdicts = HLabel (hdicts @table) hspecs = HLabel $ htabulate $ \field -> case hfield (hspecs @table) field of - Spec {..} -> Spec {labels = symbolVal (Proxy @label) : labels, ..} - {-# INLINABLE hspecs #-} + Spec{..} -> Spec{labels = symbolVal (Proxy @label) : labels, ..} + {-# INLINEABLE hspecs #-} hlabel :: forall label t context. t context -> HLabel label t context hlabel = HLabel -{-# INLINABLE hlabel #-} +{-# INLINEABLE hlabel #-} hrelabel :: forall label' label t context. HLabel label t context -> HLabel label' t context hrelabel = hlabel . hunlabel -{-# INLINABLE hrelabel #-} +{-# INLINEABLE hrelabel #-} hunlabel :: forall label t context. HLabel label t context -> t context hunlabel (HLabel a) = a -{-# INLINABLE hunlabel #-} +{-# INLINEABLE hunlabel #-} -hproject :: () - => (forall ctx. t ctx -> t' ctx) - -> HLabel label t context -> HLabel label t' context +hproject :: + () => + (forall ctx. t ctx -> t' ctx) -> + HLabel label t context -> + HLabel label t' context hproject f (HLabel a) = HLabel (f a) diff --git a/src/Rel8/Schema/HTable/List.hs b/src/Rel8/Schema/HTable/List.hs index afba46c4..8f164ef8 100644 --- a/src/Rel8/Schema/HTable/List.hs +++ b/src/Rel8/Schema/HTable/List.hs @@ -1,17 +1,17 @@ -{-# language DataKinds #-} -{-# language StandaloneKindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} -module Rel8.Schema.HTable.List - ( HListTable - ) +module Rel8.Schema.HTable.List ( + HListTable, +) where -- base import Prelude () -- rel8 +import Rel8.Schema.HTable.Vectorize (HVectorize) import qualified Rel8.Schema.Kind as K -import Rel8.Schema.HTable.Vectorize ( HVectorize ) type HListTable :: K.HTable -> K.HTable diff --git a/src/Rel8/Schema/HTable/MapTable.hs b/src/Rel8/Schema/HTable/MapTable.hs index df7970a1..62cbd5ec 100644 --- a/src/Rel8/Schema/HTable/MapTable.hs +++ b/src/Rel8/Schema/HTable/MapTable.hs @@ -1,41 +1,47 @@ -{-# language AllowAmbiguousTypes #-} -{-# language BlockArguments #-} -{-# language ConstraintKinds #-} -{-# language DataKinds #-} -{-# language FlexibleInstances #-} -{-# language GADTs #-} -{-# language InstanceSigs #-} -{-# language MultiParamTypeClasses #-} -{-# language RankNTypes #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeApplications #-} -{-# language TypeFamilies #-} -{-# language UndecidableInstances #-} -{-# language UndecidableSuperClasses #-} - -module Rel8.Schema.HTable.MapTable - ( HMapTable(..) - , MapSpec(..) - , Precompose(..) - , HMapTableField(..) - , hproject - ) +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module Rel8.Schema.HTable.MapTable ( + HMapTable (..), + MapSpec (..), + Precompose (..), + HMapTableField (..), + hproject, +) where -- base -import Data.Kind ( Constraint, Type ) +import Data.Kind (Constraint, Type) import Prelude -- rel8 -import Rel8.FCF ( Exp, Eval ) -import Rel8.Schema.HTable - ( HTable, HConstrainTable, HField - , hfield, htabulate, htraverse, hdicts, hspecs - ) -import Rel8.Schema.Spec ( Spec ) +import Rel8.FCF (Eval, Exp) +import Rel8.Schema.Dict (Dict (Dict)) +import Rel8.Schema.HTable ( + HConstrainTable, + HField, + HTable, + hdicts, + hfield, + hspecs, + htabulate, + htraverse, + ) import qualified Rel8.Schema.Kind as K -import Rel8.Schema.Dict ( Dict( Dict ) ) +import Rel8.Schema.Spec (Spec) type HMapTable :: (Type -> Exp Type) -> K.HTable -> K.HTable @@ -56,31 +62,39 @@ data HMapTableField f t x where instance (HTable t, MapSpec f) => HTable (HMapTable f t) where - type HField (HMapTable f t) = - HMapTableField f t + type + HField (HMapTable f t) = + HMapTableField f t - type HConstrainTable (HMapTable f t) c = - HConstrainTable t (ComposeConstraint f c) - hfield (HMapTable x) (HMapTableField i) = - precomposed (hfield x i) + type + HConstrainTable (HMapTable f t) c = + HConstrainTable t (ComposeConstraint f c) - htabulate f = + + hfield (HMapTable x) (HMapTableField i) = + precomposed (hfield x i) + + + htabulate f = HMapTable $ htabulate (Precompose . f . HMapTableField) - htraverse f (HMapTable x) = + + htraverse f (HMapTable x) = HMapTable <$> htraverse (fmap Precompose . f . precomposed) x - {-# INLINABLE htraverse #-} + {-# INLINEABLE htraverse #-} + hdicts :: forall c. HConstrainTable (HMapTable f t) c => HMapTable f t (Dict c) - hdicts = + hdicts = htabulate \(HMapTableField j) -> case hfield (hdicts @_ @(ComposeConstraint f c)) j of Dict -> Dict - hspecs = + + hspecs = HMapTable $ htabulate $ Precompose . mapInfo @f . hfield hspecs - {-# INLINABLE hspecs #-} + {-# INLINEABLE hspecs #-} type MapSpec :: (Type -> Exp Type) -> Constraint @@ -93,7 +107,9 @@ class c (Eval (f a)) => ComposeConstraint f c a instance c (Eval (f a)) => ComposeConstraint f c a -hproject :: () - => (forall ctx. t ctx -> t' ctx) - -> HMapTable f t context -> HMapTable f t' context +hproject :: + () => + (forall ctx. t ctx -> t' ctx) -> + HMapTable f t context -> + HMapTable f t' context hproject f (HMapTable a) = HMapTable (f a) diff --git a/src/Rel8/Schema/HTable/Maybe.hs b/src/Rel8/Schema/HTable/Maybe.hs index f8f62e16..93b740fc 100644 --- a/src/Rel8/Schema/HTable/Maybe.hs +++ b/src/Rel8/Schema/HTable/Maybe.hs @@ -1,25 +1,25 @@ -{-# language DataKinds #-} -{-# language DeriveAnyClass #-} -{-# language DeriveGeneric #-} -{-# language DerivingStrategies #-} -{-# language StandaloneKindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE StandaloneKindSignatures #-} -module Rel8.Schema.HTable.Maybe - ( HMaybeTable(..) - ) +module Rel8.Schema.HTable.Maybe ( + HMaybeTable (..), +) where -- base -import GHC.Generics ( Generic ) +import GHC.Generics (Generic) import Prelude -- rel8 -import Rel8.Schema.HTable ( HTable ) -import Rel8.Schema.HTable.Identity ( HIdentity ) -import Rel8.Schema.HTable.Label ( HLabel ) -import Rel8.Schema.HTable.Nullify ( HNullify ) +import Rel8.Schema.HTable (HTable) +import Rel8.Schema.HTable.Identity (HIdentity) +import Rel8.Schema.HTable.Label (HLabel) +import Rel8.Schema.HTable.Nullify (HNullify) import qualified Rel8.Schema.Kind as K -import Rel8.Type.Tag ( MaybeTag ) +import Rel8.Type.Tag (MaybeTag) type HMaybeTable :: K.HTable -> K.HTable @@ -27,5 +27,5 @@ data HMaybeTable table context = HMaybeTable { htag :: HLabel "isJust" (HIdentity (Maybe MaybeTag)) context , hjust :: HLabel "Just" (HNullify table) context } - deriving stock Generic - deriving anyclass HTable + deriving stock (Generic) + deriving anyclass (HTable) diff --git a/src/Rel8/Schema/HTable/NonEmpty.hs b/src/Rel8/Schema/HTable/NonEmpty.hs index cfbc6877..76f32c7f 100644 --- a/src/Rel8/Schema/HTable/NonEmpty.hs +++ b/src/Rel8/Schema/HTable/NonEmpty.hs @@ -1,17 +1,17 @@ -{-# language DataKinds #-} -{-# language StandaloneKindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} -module Rel8.Schema.HTable.NonEmpty - ( HNonEmptyTable - ) +module Rel8.Schema.HTable.NonEmpty ( + HNonEmptyTable, +) where -- base -import Data.List.NonEmpty ( NonEmpty ) +import Data.List.NonEmpty (NonEmpty) import Prelude () -- rel8 -import Rel8.Schema.HTable.Vectorize ( HVectorize ) +import Rel8.Schema.HTable.Vectorize (HVectorize) import qualified Rel8.Schema.Kind as K diff --git a/src/Rel8/Schema/HTable/Nullify.hs b/src/Rel8/Schema/HTable/Nullify.hs index ab1479e6..9892fe1a 100644 --- a/src/Rel8/Schema/HTable/Nullify.hs +++ b/src/Rel8/Schema/HTable/Nullify.hs @@ -1,117 +1,129 @@ -{-# language ConstraintKinds #-} -{-# language DataKinds #-} -{-# language DeriveAnyClass #-} -{-# language DerivingStrategies #-} -{-# language DeriveGeneric #-} -{-# language FlexibleInstances #-} -{-# language GADTs #-} -{-# language LambdaCase #-} -{-# language MultiParamTypeClasses #-} -{-# language NamedFieldPuns #-} -{-# language QuantifiedConstraints #-} -{-# language RankNTypes #-} -{-# language RecordWildCards #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeFamilies #-} -{-# language UndecidableInstances #-} - -module Rel8.Schema.HTable.Nullify - ( HNullify( HNullify ) - , Nullify - , hguard - , hnulls - , hnullify - , hunnullify - , hproject - ) +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Rel8.Schema.HTable.Nullify ( + HNullify (HNullify), + Nullify, + hguard, + hnulls, + hnullify, + hunnullify, + hproject, +) where -- base -import Data.Kind ( Type ) -import GHC.Generics ( Generic ) -import Prelude hiding ( null ) +import Data.Kind (Type) +import GHC.Generics (Generic) +import Prelude hiding (null) -- rel8 -import Rel8.FCF ( Eval, Exp ) -import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs ) -import Rel8.Schema.HTable.MapTable - ( HMapTable, HMapTableField( HMapTableField ) - , MapSpec, mapInfo - ) -import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject ) +import Rel8.FCF (Eval, Exp) +import Rel8.Schema.HTable (HTable, hfield, hspecs, htabulate, htabulateA) +import Rel8.Schema.HTable.MapTable ( + HMapTable, + HMapTableField (HMapTableField), + MapSpec, + mapInfo, + ) +import qualified Rel8.Schema.HTable.MapTable as HMapTable (hproject) import qualified Rel8.Schema.Kind as K -import Rel8.Schema.Null ( Nullity( Null, NotNull ) ) -import qualified Rel8.Schema.Null as Type ( Nullify ) -import Rel8.Schema.Spec ( Spec(..) ) +import Rel8.Schema.Null (Nullity (NotNull, Null)) +import qualified Rel8.Schema.Null as Type (Nullify) +import Rel8.Schema.Spec (Spec (..)) -- semigroupoids -import Data.Functor.Apply ( Apply ) +import Data.Functor.Apply (Apply) type HNullify :: K.HTable -> K.HTable newtype HNullify table context = HNullify (HMapTable Nullify table context) - deriving stock Generic - deriving anyclass HTable + deriving stock (Generic) + deriving anyclass (HTable) -- | Transform a 'Type' by allowing it to be @null@. data Nullify :: Type -> Exp Type + + type instance Eval (Nullify a) = Type.Nullify a instance MapSpec Nullify where mapInfo = \case - Spec {nullity, ..} -> Spec - { nullity = case nullity of - Null -> Null - NotNull -> Null - , .. - } - - -hguard :: HTable t - => (forall a. context (Maybe a) -> context (Maybe a)) - -> HNullify t context -> HNullify t context + Spec{nullity, ..} -> + Spec + { nullity = case nullity of + Null -> Null + NotNull -> Null + , .. + } + + +hguard :: + HTable t => + (forall a. context (Maybe a) -> context (Maybe a)) -> + HNullify t context -> + HNullify t context hguard guarder (HNullify as) = HNullify $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of - Spec {nullity} -> case hfield as (HMapTableField field) of + Spec{nullity} -> case hfield as (HMapTableField field) of a -> case nullity of Null -> guarder a NotNull -> guarder a -hnulls :: HTable t - => (forall a. Spec a -> context (Type.Nullify a)) - -> HNullify t context +hnulls :: + HTable t => + (forall a. Spec a -> context (Type.Nullify a)) -> + HNullify t context hnulls null = HNullify $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of - spec@Spec {} -> null spec -{-# INLINABLE hnulls #-} + spec@Spec{} -> null spec +{-# INLINEABLE hnulls #-} -hnullify :: HTable t - => (forall a. Spec a -> context a -> context (Type.Nullify a)) - -> t context - -> HNullify t context +hnullify :: + HTable t => + (forall a. Spec a -> context a -> context (Type.Nullify a)) -> + t context -> + HNullify t context hnullify nullifier a = HNullify $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of - spec@Spec {} -> nullifier spec (hfield a field) -{-# INLINABLE hnullify #-} + spec@Spec{} -> nullifier spec (hfield a field) +{-# INLINEABLE hnullify #-} -hunnullify :: (HTable t, Apply m) - => (forall a. Spec a -> context (Type.Nullify a) -> m (context a)) - -> HNullify t context - -> m (t context) +hunnullify :: + (HTable t, Apply m) => + (forall a. Spec a -> context (Type.Nullify a) -> m (context a)) -> + HNullify t context -> + m (t context) hunnullify unnullifier (HNullify as) = htabulateA $ \field -> case hfield hspecs field of - spec@Spec {} -> case hfield as (HMapTableField field) of + spec@Spec{} -> case hfield as (HMapTableField field) of a -> unnullifier spec a -{-# INLINABLE hunnullify #-} +{-# INLINEABLE hunnullify #-} -hproject :: () - => (forall ctx. t ctx -> t' ctx) - -> HNullify t context -> HNullify t' context +hproject :: + () => + (forall ctx. t ctx -> t' ctx) -> + HNullify t context -> + HNullify t' context hproject f (HNullify a) = HNullify (HMapTable.hproject f a) diff --git a/src/Rel8/Schema/HTable/Product.hs b/src/Rel8/Schema/HTable/Product.hs index b1e779c5..92b79f3d 100644 --- a/src/Rel8/Schema/HTable/Product.hs +++ b/src/Rel8/Schema/HTable/Product.hs @@ -1,9 +1,9 @@ -{-# language DataKinds #-} -{-# language StandaloneKindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} -module Rel8.Schema.HTable.Product - ( HProduct(..) - ) +module Rel8.Schema.HTable.Product ( + HProduct (..), +) where -- base diff --git a/src/Rel8/Schema/HTable/These.hs b/src/Rel8/Schema/HTable/These.hs index 95282fea..87e3e2d6 100644 --- a/src/Rel8/Schema/HTable/These.hs +++ b/src/Rel8/Schema/HTable/These.hs @@ -1,25 +1,25 @@ -{-# language DataKinds #-} -{-# language DeriveAnyClass #-} -{-# language DeriveGeneric #-} -{-# language DerivingStrategies #-} -{-# language StandaloneKindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE StandaloneKindSignatures #-} -module Rel8.Schema.HTable.These - ( HTheseTable(..) - ) +module Rel8.Schema.HTable.These ( + HTheseTable (..), +) where -- base -import GHC.Generics ( Generic ) +import GHC.Generics (Generic) import Prelude -- rel8 -import Rel8.Schema.HTable ( HTable ) -import Rel8.Schema.HTable.Identity ( HIdentity ) -import Rel8.Schema.HTable.Label ( HLabel ) -import Rel8.Schema.HTable.Nullify ( HNullify ) +import Rel8.Schema.HTable (HTable) +import Rel8.Schema.HTable.Identity (HIdentity) +import Rel8.Schema.HTable.Label (HLabel) +import Rel8.Schema.HTable.Nullify (HNullify) import qualified Rel8.Schema.Kind as K -import Rel8.Type.Tag ( MaybeTag ) +import Rel8.Type.Tag (MaybeTag) type HTheseTable :: K.HTable -> K.HTable -> K.HTable @@ -29,5 +29,5 @@ data HTheseTable here there context = HTheseTable , hthereTag :: HLabel "thereTag" (HIdentity (Maybe MaybeTag)) context , hthere :: HLabel "There" (HNullify there) context } - deriving stock Generic - deriving anyclass HTable + deriving stock (Generic) + deriving anyclass (HTable) diff --git a/src/Rel8/Schema/HTable/Vectorize.hs b/src/Rel8/Schema/HTable/Vectorize.hs index 16efbfcc..2ba38b7f 100644 --- a/src/Rel8/Schema/HTable/Vectorize.hs +++ b/src/Rel8/Schema/HTable/Vectorize.hs @@ -1,61 +1,71 @@ -{-# language AllowAmbiguousTypes #-} -{-# language ConstraintKinds #-} -{-# language DataKinds #-} -{-# language DeriveAnyClass #-} -{-# language DeriveGeneric #-} -{-# language DerivingStrategies #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language GADTs #-} -{-# language LambdaCase #-} -{-# language MultiParamTypeClasses #-} -{-# language NamedFieldPuns #-} -{-# language RankNTypes #-} -{-# language RecordWildCards #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeApplications #-} -{-# language TypeFamilies #-} -{-# language UndecidableInstances #-} - -module Rel8.Schema.HTable.Vectorize - ( HVectorize - , hvectorize, hvectorizeA, hunvectorize - , hnullify - , happend, hempty - , hproject - , hcolumn - ) +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Rel8.Schema.HTable.Vectorize ( + HVectorize, + hvectorize, + hvectorizeA, + hunvectorize, + hnullify, + happend, + hempty, + hproject, + hcolumn, +) where -- base -import Data.Kind ( Constraint, Type ) -import Data.List.NonEmpty ( NonEmpty ) +import Data.Kind (Constraint, Type) +import Data.List.NonEmpty (NonEmpty) import GHC.Generics (Generic) import Prelude -- rel8 -import Rel8.FCF ( Eval, Exp ) -import Rel8.Schema.Dict ( Dict( Dict ) ) -import qualified Rel8.Schema.Kind as K -import Rel8.Schema.HTable - ( HField, HTable, hfield, htabulate, htabulateA, hspecs - ) -import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) ) -import Rel8.Schema.HTable.MapTable - ( HMapTable( HMapTable ), HMapTableField( HMapTableField ) - , MapSpec, mapInfo - , Precompose( Precompose ) - ) -import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject ) +import Rel8.FCF (Eval, Exp) +import Rel8.Schema.Dict (Dict (Dict)) +import Rel8.Schema.HTable ( + HField, + HTable, + hfield, + hspecs, + htabulate, + htabulateA, + ) +import Rel8.Schema.HTable.Identity (HIdentity (HIdentity)) +import Rel8.Schema.HTable.MapTable ( + HMapTable (HMapTable), + HMapTableField (HMapTableField), + MapSpec, + Precompose (Precompose), + mapInfo, + ) +import qualified Rel8.Schema.HTable.MapTable as HMapTable (hproject) import Rel8.Schema.HTable.Nullify (HNullify (HNullify)) -import Rel8.Schema.Null (Nullify, Unnullify, NotNull, Nullity (NotNull)) -import Rel8.Schema.Spec ( Spec(..) ) -import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation ) -import Rel8.Type.Information ( TypeInformation ) +import qualified Rel8.Schema.Kind as K +import Rel8.Schema.Null (NotNull, Nullify, Nullity (NotNull), Unnullify) +import Rel8.Schema.Spec (Spec (..)) +import Rel8.Type.Array (listTypeInformation, nonEmptyTypeInformation) +import Rel8.Type.Information (TypeInformation) -- semialign -import Data.Zip ( Unzip, Zip, Zippy(..) ) +import Data.Zip (Unzip, Zip, Zippy (..)) -- semigroupoids import Data.Functor.Apply (Apply) @@ -64,10 +74,11 @@ import Data.Functor.Apply (Apply) type Vector :: (Type -> Type) -> Constraint class Vector list where listNotNull :: proxy a -> Dict NotNull (list a) - vectorTypeInformation :: () - => Nullity a - -> TypeInformation (Unnullify a) - -> TypeInformation (list a) + vectorTypeInformation :: + () => + Nullity a -> + TypeInformation (Unnullify a) -> + TypeInformation (list a) instance Vector [] where @@ -82,8 +93,8 @@ instance Vector NonEmpty where type HVectorize :: (Type -> Type) -> K.HTable -> K.HTable newtype HVectorize list table context = HVectorize (HMapTable (Vectorize list) table context) - deriving stock Generic - deriving anyclass HTable + deriving stock (Generic) + deriving anyclass (HTable) data Vectorize :: (Type -> Type) -> Type -> Exp Type @@ -94,66 +105,74 @@ type instance Eval (Vectorize list a) = list a instance Vector list => MapSpec (Vectorize list) where mapInfo = \case - Spec {..} -> case listNotNull @list nullity of - Dict -> Spec - { nullity = NotNull - , info = vectorTypeInformation nullity info - , .. - } - - -hvectorize :: (HTable t, Unzip f, Vector list) - => (forall a. Spec a -> f (context a) -> context' (list a)) - -> f (t context) - -> HVectorize list t context' + Spec{..} -> case listNotNull @list nullity of + Dict -> + Spec + { nullity = NotNull + , info = vectorTypeInformation nullity info + , .. + } + + +hvectorize :: + (HTable t, Unzip f, Vector list) => + (forall a. Spec a -> f (context a) -> context' (list a)) -> + f (t context) -> + HVectorize list t context' hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of spec -> vectorizer spec (fmap (`hfield` field) as) -{-# INLINABLE hvectorize #-} +{-# INLINEABLE hvectorize #-} -hvectorizeA :: (HTable t, Apply f, Vector list) - => (forall a. Spec a -> HField t a -> f (context' (list a))) - -> f (HVectorize list t context') +hvectorizeA :: + (HTable t, Apply f, Vector list) => + (forall a. Spec a -> HField t a -> f (context' (list a))) -> + f (HVectorize list t context') hvectorizeA vectorizer = fmap HVectorize $ htabulateA $ \(HMapTableField field) -> case hfield hspecs field of spec -> vectorizer spec field -{-# INLINABLE hvectorizeA #-} +{-# INLINEABLE hvectorizeA #-} -hunvectorize :: (HTable t, Zip f, Vector list) - => (forall a. Spec a -> context (list a) -> f (context' a)) - -> HVectorize list t context - -> f (t context') +hunvectorize :: + (HTable t, Zip f, Vector list) => + (forall a. Spec a -> context (list a) -> f (context' a)) -> + HVectorize list t context -> + f (t context') hunvectorize unvectorizer (HVectorize table) = getZippy $ htabulateA $ \field -> case hfield hspecs field of spec -> case hfield table (HMapTableField field) of a -> Zippy (unvectorizer spec a) -{-# INLINABLE hunvectorize #-} +{-# INLINEABLE hunvectorize #-} -happend :: (HTable t, Vector list) - => (forall a. Spec a -> context (list a) -> context (list a) -> context (list a)) - -> HVectorize list t context - -> HVectorize list t context - -> HVectorize list t context +happend :: + (HTable t, Vector list) => + (forall a. Spec a -> context (list a) -> context (list a) -> context (list a)) -> + HVectorize list t context -> + HVectorize list t context -> + HVectorize list t context happend append (HVectorize as) (HVectorize bs) = HVectorize $ htabulate $ \field@(HMapTableField j) -> case (hfield as field, hfield bs field) of (a, b) -> case hfield hspecs j of spec -> append spec a b -hempty :: HTable t - => (forall a. Spec a -> context [a]) - -> HVectorize [] t context +hempty :: + HTable t => + (forall a. Spec a -> context [a]) -> + HVectorize [] t context hempty empty = HVectorize $ htabulate $ \(HMapTableField field) -> empty (hfield hspecs field) -hproject :: () - => (forall ctx. t ctx -> t' ctx) - -> HVectorize list t context -> HVectorize list t' context +hproject :: + () => + (forall ctx. t ctx -> t' ctx) -> + HVectorize list t context -> + HVectorize list t' context hproject f (HVectorize a) = HVectorize (HMapTable.hproject f a) @@ -161,10 +180,12 @@ hcolumn :: HVectorize list (HIdentity a) context -> context (list a) hcolumn (HVectorize (HMapTable (HIdentity (Precompose a)))) = a -hnullify :: forall t list context. (HTable t, Vector list) - => (forall a. Spec a -> context (list a) -> context (Nullify a)) - -> HVectorize list t context - -> HNullify t context +hnullify :: + forall t list context. + (HTable t, Vector list) => + (forall a. Spec a -> context (list a) -> context (Nullify a)) -> + HVectorize list t context -> + HNullify t context hnullify f (HVectorize table) = HNullify $ htabulate $ \(HMapTableField field) -> case hfield hspecs field of spec -> case hfield table (HMapTableField field) of diff --git a/src/Rel8/Schema/Kind.hs b/src/Rel8/Schema/Kind.hs index 9ef74cc2..6a76afd3 100644 --- a/src/Rel8/Schema/Kind.hs +++ b/src/Rel8/Schema/Kind.hs @@ -1,14 +1,14 @@ -{-# language StandaloneKindSignatures #-} +{-# LANGUAGE StandaloneKindSignatures #-} -module Rel8.Schema.Kind - ( Rel8able - , Context - , HTable - ) +module Rel8.Schema.Kind ( + Rel8able, + Context, + HTable, +) where -- base -import Data.Kind ( Type ) +import Data.Kind (Type) import Prelude () diff --git a/src/Rel8/Schema/Name.hs b/src/Rel8/Schema/Name.hs index 1ceac682..a436b236 100644 --- a/src/Rel8/Schema/Name.hs +++ b/src/Rel8/Schema/Name.hs @@ -1,26 +1,26 @@ -{-# language DataKinds #-} -{-# language DerivingStrategies #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language GADTs #-} -{-# language GeneralizedNewtypeDeriving #-} -{-# language MultiParamTypeClasses #-} -{-# language RankNTypes #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeFamilies #-} -{-# language UndecidableInstances #-} - -module Rel8.Schema.Name - ( Name(..) - , Selects - , ppColumn - ) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Rel8.Schema.Name ( + Name (..), + Selects, + ppColumn, +) where -- base -import Data.Functor.Identity ( Identity( Identity ) ) -import Data.Kind ( Constraint, Type ) -import Data.String ( IsString ) +import Data.Functor.Identity (Identity (Identity)) +import Data.Kind (Constraint, Type) +import Data.String (IsString) import Prelude -- opaleye @@ -28,30 +28,37 @@ import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye -- pretty -import Text.PrettyPrint ( Doc ) +import Text.PrettyPrint (Doc) -- rel8 -import Rel8.Expr ( Expr ) +import Rel8.Expr (Expr) +import Rel8.Schema.HTable.Identity (HIdentity (HIdentity)) import qualified Rel8.Schema.Kind as K -import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) ) -import Rel8.Schema.Null ( Sql ) -import Rel8.Table - ( Table, Columns, Context, fromColumns, toColumns - , FromExprs, fromResult, toResult - , Transpose - ) -import Rel8.Table.Transpose ( Transposes ) -import Rel8.Type ( DBType ) - - --- | A @Name@ is the name of a column, as it would be defined in a table's --- schema definition. You can construct names by using the @OverloadedStrings@ --- extension and writing string literals. This is typically done when providing --- a 'TableSchema' value. +import Rel8.Schema.Null (Sql) +import Rel8.Table ( + Columns, + Context, + FromExprs, + Table, + Transpose, + fromColumns, + fromResult, + toColumns, + toResult, + ) +import Rel8.Table.Transpose (Transposes) +import Rel8.Type (DBType) + + +{- | A @Name@ is the name of a column, as it would be defined in a table's +schema definition. You can construct names by using the @OverloadedStrings@ +extension and writing string literals. This is typically done when providing +a 'TableSchema' value. +-} type Name :: K.Context newtype Name a = Name String - deriving stock Show - deriving newtype IsString + deriving stock (Show) + deriving newtype (IsString) instance Sql DBType a => Table Name (Name a) where @@ -60,16 +67,20 @@ instance Sql DBType a => Table Name (Name a) where type FromExprs (Name a) = a type Transpose to (Name a) = to a + toColumns a = HIdentity a fromColumns (HIdentity a) = a toResult a = HIdentity (Identity a) fromResult (HIdentity (Identity a)) = a --- | @Selects a b@ means that @a@ is a schema (i.e., a 'Table' of 'Name's) for --- the 'Expr' columns in @b@. +{- | @Selects a b@ means that @a@ is a schema (i.e., a 'Table' of 'Name's) for +the 'Expr' columns in @b@. +-} type Selects :: Type -> Type -> Constraint class Transposes Name Expr names exprs => Selects names exprs + + instance Transposes Name Expr names exprs => Selects names exprs diff --git a/src/Rel8/Schema/Null.hs b/src/Rel8/Schema/Null.hs index 9f1c0492..2c9b931d 100644 --- a/src/Rel8/Schema/Null.hs +++ b/src/Rel8/Schema/Null.hs @@ -1,28 +1,30 @@ -{-# language ConstraintKinds #-} -{-# language DataKinds #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language GADTs #-} -{-# language MultiParamTypeClasses #-} -{-# language RankNTypes #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeFamilies #-} -{-# language TypeOperators #-} -{-# language UndecidableInstances #-} -{-# language UndecidableSuperClasses #-} - -module Rel8.Schema.Null - ( Nullify, Unnullify - , NotNull - , Homonullable - , Nullity( Null, NotNull ) - , Nullable, nullable - , Sql - ) +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module Rel8.Schema.Null ( + Nullify, + Unnullify, + NotNull, + Homonullable, + Nullity (Null, NotNull), + Nullable, + nullable, + Sql, +) where -- base -import Data.Kind ( Constraint, Type ) +import Data.Kind (Constraint, Type) import Prelude @@ -55,13 +57,18 @@ type Nullify a = Maybe (Unnullify a) -- | @nullify a@ means @a@ cannot take @null@ as a value. type NotNull :: Type -> Constraint class (Nullable a, IsMaybe a ~ 'False) => NotNull a + + instance (Nullable a, IsMaybe a ~ 'False) => NotNull a --- | @Homonullable a b@ means that both @a@ and @b@ can be @null@, or neither --- @a@ or @b@ can be @null@. +{- | @Homonullable a b@ means that both @a@ and @b@ can be @null@, or neither +@a@ or @b@ can be @null@. +-} type Homonullable :: Type -> Type -> Constraint class IsMaybe a ~ IsMaybe b => Homonullable a b + + instance IsMaybe a ~ IsMaybe b => Homonullable a b @@ -76,8 +83,9 @@ class ( IsMaybe a ~ isMaybe , IsMaybe (Unnullify a) ~ 'False , Nullify' isMaybe (Unnullify a) ~ a - ) => Nullable' isMaybe a - where + ) => + Nullable' isMaybe a + where nullable' :: Nullity a @@ -89,10 +97,13 @@ instance IsMaybe a ~ 'False => Nullable' 'True (Maybe a) where nullable' = Null --- | @Nullable a@ means that @rel8@ is able to check if the type @a@ is a --- type that can take @null@ values or not. +{- | @Nullable a@ means that @rel8@ is able to check if the type @a@ is a +type that can take @null@ values or not. +-} type Nullable :: Type -> Constraint class Nullable' (IsMaybe a) a => Nullable a + + instance Nullable' (IsMaybe a) a => Nullable a @@ -100,12 +111,15 @@ nullable :: Nullable a => Nullity a nullable = nullable' --- | The @Sql@ type class describes both null and not null database values, --- constrained by a specific class. --- --- For example, if you see @Sql DBEq a@, this means any database type that --- supports equality, and @a@ can either be exactly an @a@, or it could also be --- @Maybe a@. +{- | The @Sql@ type class describes both null and not null database values, +constrained by a specific class. + +For example, if you see @Sql DBEq a@, this means any database type that +supports equality, and @a@ can either be exactly an @a@, or it could also be +@Maybe a@. +-} type Sql :: (Type -> Constraint) -> Type -> Constraint class (constraint (Unnullify a), Nullable a) => Sql constraint a + + instance (constraint (Unnullify a), Nullable a) => Sql constraint a diff --git a/src/Rel8/Schema/Result.hs b/src/Rel8/Schema/Result.hs index 6801a43e..6ea41900 100644 --- a/src/Rel8/Schema/Result.hs +++ b/src/Rel8/Schema/Result.hs @@ -1,30 +1,34 @@ -{-# language DataKinds #-} -{-# language GADTs #-} -{-# language NamedFieldPuns #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeFamilies #-} - -module Rel8.Schema.Result - ( Result - , null, nullifier, unnullifier - , vectorizer, unvectorizer - ) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} + +module Rel8.Schema.Result ( + Result, + null, + nullifier, + unnullifier, + vectorizer, + unvectorizer, +) where -- base -import Data.Functor.Identity ( Identity( Identity), runIdentity ) -import Prelude hiding ( null ) +import Data.Functor.Identity (Identity (Identity), runIdentity) +import Prelude hiding (null) -- rel8 -import Rel8.Schema.Kind ( Context ) -import Rel8.Schema.Null ( Nullify, Nullity( Null, NotNull ) ) -import Rel8.Schema.Spec ( Spec(..) ) +import Rel8.Schema.Kind (Context) +import Rel8.Schema.Null (Nullify, Nullity (NotNull, Null)) +import Rel8.Schema.Spec (Spec (..)) --- | The @Result@ context is the context used for decoded query results. --- --- When a query is executed against a PostgreSQL database, Rel8 parses the --- returned rows, decoding each row into the @Result@ context. +{- | The @Result@ context is the context used for decoded query results. + +When a query is executed against a PostgreSQL database, Rel8 parses the +returned rows, decoding each row into the @Result@ context. +-} type Result :: Context type Result = Identity @@ -34,13 +38,13 @@ null = Identity Nothing nullifier :: Spec a -> Result a -> Result (Nullify a) -nullifier Spec {nullity} (Identity a) = Identity $ case nullity of +nullifier Spec{nullity} (Identity a) = Identity $ case nullity of Null -> a NotNull -> Just a unnullifier :: Spec a -> Result (Nullify a) -> Maybe (Result a) -unnullifier Spec {nullity} (Identity a) = +unnullifier Spec{nullity} (Identity a) = case nullity of Null -> pure $ Identity a NotNull -> Identity <$> a diff --git a/src/Rel8/Schema/Spec.hs b/src/Rel8/Schema/Spec.hs index 0d41f655..b9c1c2c2 100644 --- a/src/Rel8/Schema/Spec.hs +++ b/src/Rel8/Schema/Spec.hs @@ -1,21 +1,21 @@ -{-# language FlexibleContexts #-} -{-# language MonoLocalBinds #-} -{-# language StandaloneKindSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} -module Rel8.Schema.Spec - ( Spec( Spec, labels, info, nullity ) - , specification - ) +module Rel8.Schema.Spec ( + Spec (Spec, labels, info, nullity), + specification, +) where -- base -import Data.Kind ( Type ) +import Data.Kind (Type) import Prelude -- rel8 -import Rel8.Schema.Null ( Nullity, Sql, Unnullify, nullable ) -import Rel8.Type ( DBType, typeInformation ) -import Rel8.Type.Information ( TypeInformation ) +import Rel8.Schema.Null (Nullity, Sql, Unnullify, nullable) +import Rel8.Type (DBType, typeInformation) +import Rel8.Type.Information (TypeInformation) type Spec :: Type -> Type @@ -27,8 +27,9 @@ data Spec a = Spec specification :: Sql DBType a => Spec a -specification = Spec - { labels = [] - , info = typeInformation - , nullity = nullable - } +specification = + Spec + { labels = [] + , info = typeInformation + , nullity = nullable + } diff --git a/src/Rel8/Schema/Table.hs b/src/Rel8/Schema/Table.hs index 3aed5d4a..2f7a8695 100644 --- a/src/Rel8/Schema/Table.hs +++ b/src/Rel8/Schema/Table.hs @@ -1,17 +1,17 @@ -{-# language DeriveFunctor #-} -{-# language DerivingStrategies #-} -{-# language DisambiguateRecordFields #-} -{-# language NamedFieldPuns #-} -{-# language StandaloneKindSignatures #-} - -module Rel8.Schema.Table - ( TableSchema(..) - , ppTable - ) +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE StandaloneKindSignatures #-} + +module Rel8.Schema.Table ( + TableSchema (..), + ppTable, +) where -- base -import Data.Kind ( Type ) +import Data.Kind (Type) import Prelude -- opaleye @@ -19,31 +19,34 @@ import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye -- pretty -import Text.PrettyPrint ( Doc ) +import Text.PrettyPrint (Doc) --- | The schema for a table. This is used to specify the name and schema that a --- table belongs to (the @FROM@ part of a SQL query), along with the schema of --- the columns within this table. --- --- For each selectable table in your database, you should provide a --- @TableSchema@ in order to interact with the table via Rel8. +{- | The schema for a table. This is used to specify the name and schema that a +table belongs to (the @FROM@ part of a SQL query), along with the schema of +the columns within this table. + +For each selectable table in your database, you should provide a +@TableSchema@ in order to interact with the table via Rel8. +-} type TableSchema :: Type -> Type data TableSchema names = TableSchema { name :: String - -- ^ The name of the table. + -- ^ The name of the table. , schema :: Maybe String - -- ^ The schema that this table belongs to. If 'Nothing', whatever is on - -- the connection's @search_path@ will be used. + -- ^ The schema that this table belongs to. If 'Nothing', whatever is on + -- the connection's @search_path@ will be used. , columns :: names - -- ^ The columns of the table. Typically you would use a a higher-kinded - -- data type here, parameterized by the 'Rel8.ColumnSchema.ColumnSchema' functor. + -- ^ The columns of the table. Typically you would use a a higher-kinded + -- data type here, parameterized by the 'Rel8.ColumnSchema.ColumnSchema' functor. } - deriving stock Functor + deriving stock (Functor) ppTable :: TableSchema a -> Doc -ppTable TableSchema {name, schema} = Opaleye.ppTable Opaleye.SqlTable - { sqlTableSchemaName = schema - , sqlTableName = name - } +ppTable TableSchema{name, schema} = + Opaleye.ppTable + Opaleye.SqlTable + { sqlTableSchemaName = schema + , sqlTableName = name + } diff --git a/src/Rel8/Statement/Delete.hs b/src/Rel8/Statement/Delete.hs index 7e8c9bcb..11fc3347 100644 --- a/src/Rel8/Statement/Delete.hs +++ b/src/Rel8/Statement/Delete.hs @@ -1,20 +1,20 @@ -{-# language DuplicateRecordFields #-} -{-# language GADTs #-} -{-# language NamedFieldPuns #-} -{-# language RankNTypes #-} -{-# language RecordWildCards #-} -{-# language StandaloneKindSignatures #-} -{-# language StrictData #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE StrictData #-} -module Rel8.Statement.Delete - ( Delete(..) - , delete - , ppDelete - ) +module Rel8.Statement.Delete ( + Delete (..), + delete, + ppDelete, +) where -- base -import Data.Kind ( Type ) +import Data.Kind (Type) import Prelude -- hasql @@ -22,54 +22,57 @@ import qualified Hasql.Encoders as Hasql import qualified Hasql.Statement as Hasql -- pretty -import Text.PrettyPrint ( Doc, (<+>), ($$), text ) +import Text.PrettyPrint (Doc, text, ($$), (<+>)) -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Query ( Query ) -import Rel8.Schema.Name ( Selects ) -import Rel8.Schema.Table ( TableSchema, ppTable ) -import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning ) -import Rel8.Statement.Using ( ppUsing ) -import Rel8.Statement.Where ( ppWhere ) +import Rel8.Expr (Expr) +import Rel8.Query (Query) +import Rel8.Schema.Name (Selects) +import Rel8.Schema.Table (TableSchema, ppTable) +import Rel8.Statement.Returning (Returning, decodeReturning, ppReturning) +import Rel8.Statement.Using (ppUsing) +import Rel8.Statement.Where (ppWhere) -- text import qualified Data.Text as Text -import Data.Text.Encoding ( encodeUtf8 ) +import Data.Text.Encoding (encodeUtf8) -- | The constituent parts of a @DELETE@ statement. type Delete :: Type -> Type data Delete a where - Delete :: Selects names exprs => + Delete :: + Selects names exprs => { from :: TableSchema names - -- ^ Which table to delete from. + -- ^ Which table to delete from. , using :: Query using - -- ^ @USING@ clause — this can be used to join against other tables, - -- and its results can be referenced in the @WHERE@ clause + -- ^ @USING@ clause — this can be used to join against other tables, + -- and its results can be referenced in the @WHERE@ clause , deleteWhere :: using -> exprs -> Expr Bool - -- ^ Which rows should be selected for deletion. + -- ^ Which rows should be selected for deletion. , returning :: Returning names a - -- ^ What to return from the @DELETE@ statement. - } - -> Delete a + -- ^ What to return from the @DELETE@ statement. + } -> + Delete a ppDelete :: Delete a -> Doc -ppDelete Delete {..} = case ppUsing using of +ppDelete Delete{..} = case ppUsing using of Nothing -> - text "DELETE FROM" <+> ppTable from $$ - text "WHERE false" + text "DELETE FROM" + <+> ppTable from + $$ text "WHERE false" Just (usingDoc, i) -> - text "DELETE FROM" <+> ppTable from $$ - usingDoc $$ - ppWhere from (deleteWhere i) $$ - ppReturning from returning + text "DELETE FROM" + <+> ppTable from + $$ usingDoc + $$ ppWhere from (deleteWhere i) + $$ ppReturning from returning -- | Run a 'Delete' statement. delete :: Delete a -> Hasql.Statement () a -delete d@Delete {returning} = Hasql.Statement bytes params decode prepare +delete d@Delete{returning} = Hasql.Statement bytes params decode prepare where bytes = encodeUtf8 $ Text.pack sql params = Hasql.noParams diff --git a/src/Rel8/Statement/Insert.hs b/src/Rel8/Statement/Insert.hs index 096ed2f4..ae5abad1 100644 --- a/src/Rel8/Statement/Insert.hs +++ b/src/Rel8/Statement/Insert.hs @@ -1,22 +1,22 @@ -{-# language DuplicateRecordFields #-} -{-# language FlexibleContexts #-} -{-# language GADTs #-} -{-# language NamedFieldPuns #-} -{-# language RecordWildCards #-} -{-# language StandaloneKindSignatures #-} -{-# language StrictData #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE StrictData #-} -module Rel8.Statement.Insert - ( Insert(..) - , insert - , ppInsert - , ppInto - ) +module Rel8.Statement.Insert ( + Insert (..), + insert, + ppInsert, + ppInto, +) where -- base -import Data.Foldable ( toList ) -import Data.Kind ( Type ) +import Data.Foldable (toList) +import Data.Kind (Type) import Prelude -- hasql @@ -27,59 +27,60 @@ import qualified Hasql.Statement as Hasql import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye -- pretty -import Text.PrettyPrint ( Doc, (<+>), ($$), parens, text ) +import Text.PrettyPrint (Doc, parens, text, ($$), (<+>)) -- rel8 -import Rel8.Query ( Query ) -import Rel8.Schema.Name ( Name, Selects, ppColumn ) -import Rel8.Schema.Table ( TableSchema(..), ppTable ) -import Rel8.Statement.OnConflict ( OnConflict, ppOnConflict ) -import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning ) -import Rel8.Statement.Select ( ppRows ) -import Rel8.Table ( Table ) -import Rel8.Table.Name ( showNames ) +import Rel8.Query (Query) +import Rel8.Schema.Name (Name, Selects, ppColumn) +import Rel8.Schema.Table (TableSchema (..), ppTable) +import Rel8.Statement.OnConflict (OnConflict, ppOnConflict) +import Rel8.Statement.Returning (Returning, decodeReturning, ppReturning) +import Rel8.Statement.Select (ppRows) +import Rel8.Table (Table) +import Rel8.Table.Name (showNames) -- text -import qualified Data.Text as Text ( pack ) -import Data.Text.Encoding ( encodeUtf8 ) +import qualified Data.Text as Text (pack) +import Data.Text.Encoding (encodeUtf8) -- | The constituent parts of a SQL @INSERT@ statement. type Insert :: Type -> Type data Insert a where - Insert :: Selects names exprs => + Insert :: + Selects names exprs => { into :: TableSchema names - -- ^ Which table to insert into. + -- ^ Which table to insert into. , rows :: Query exprs - -- ^ The rows to insert. This can be an arbitrary query — use - -- 'Rel8.values' insert a static list of rows. + -- ^ The rows to insert. This can be an arbitrary query — use + -- 'Rel8.values' insert a static list of rows. , onConflict :: OnConflict names - -- ^ What to do if the inserted rows conflict with data already in the - -- table. + -- ^ What to do if the inserted rows conflict with data already in the + -- table. , returning :: Returning names a - -- ^ What information to return on completion. - } - -> Insert a + -- ^ What information to return on completion. + } -> + Insert a ppInsert :: Insert a -> Doc -ppInsert Insert {..} = - text "INSERT INTO" <+> - ppInto into $$ - ppRows rows $$ - ppOnConflict into onConflict $$ - ppReturning into returning +ppInsert Insert{..} = + text "INSERT INTO" + <+> ppInto into + $$ ppRows rows + $$ ppOnConflict into onConflict + $$ ppReturning into returning ppInto :: Table Name a => TableSchema a -> Doc -ppInto table@TableSchema {columns} = - ppTable table <+> - parens (Opaleye.commaV ppColumn (toList (showNames columns))) +ppInto table@TableSchema{columns} = + ppTable table + <+> parens (Opaleye.commaV ppColumn (toList (showNames columns))) -- | Run an 'Insert' statement. insert :: Insert a -> Hasql.Statement () a -insert i@Insert {returning} = Hasql.Statement bytes params decode prepare +insert i@Insert{returning} = Hasql.Statement bytes params decode prepare where bytes = encodeUtf8 $ Text.pack sql params = Hasql.noParams diff --git a/src/Rel8/Statement/OnConflict.hs b/src/Rel8/Statement/OnConflict.hs index d6ee2e67..8e0834f0 100644 --- a/src/Rel8/Statement/OnConflict.hs +++ b/src/Rel8/Statement/OnConflict.hs @@ -1,81 +1,84 @@ -{-# language DuplicateRecordFields #-} -{-# language FlexibleContexts #-} -{-# language GADTs #-} -{-# language LambdaCase #-} -{-# language NamedFieldPuns #-} -{-# language RecordWildCards #-} -{-# language StandaloneKindSignatures #-} -{-# language StrictData #-} -{-# language TypeOperators #-} - -module Rel8.Statement.OnConflict - ( OnConflict(..) - , Upsert(..) - , ppOnConflict - ) +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeOperators #-} + +module Rel8.Statement.OnConflict ( + OnConflict (..), + Upsert (..), + ppOnConflict, +) where -- base -import Data.Foldable ( toList ) -import Data.Kind ( Type ) +import Data.Foldable (toList) +import Data.Kind (Type) import Prelude -- opaleye import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye -- pretty -import Text.PrettyPrint ( Doc, (<+>), ($$), parens, text ) +import Text.PrettyPrint (Doc, parens, text, ($$), (<+>)) -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Schema.Name ( Name, Selects, ppColumn ) -import Rel8.Schema.Table ( TableSchema(..) ) -import Rel8.Statement.Set ( ppSet ) -import Rel8.Statement.Where ( ppWhere ) -import Rel8.Table ( Table, toColumns ) -import Rel8.Table.Cols ( Cols( Cols ) ) -import Rel8.Table.Name ( showNames ) -import Rel8.Table.Opaleye ( attributes ) -import Rel8.Table.Projection ( Projecting, Projection, apply ) - - --- | 'OnConflict' represents the @ON CONFLICT@ clause of an @INSERT@ --- statement. This specifies what ought to happen when one or more of the --- rows proposed for insertion conflict with an existing row in the table. +import Rel8.Expr (Expr) +import Rel8.Schema.Name (Name, Selects, ppColumn) +import Rel8.Schema.Table (TableSchema (..)) +import Rel8.Statement.Set (ppSet) +import Rel8.Statement.Where (ppWhere) +import Rel8.Table (Table, toColumns) +import Rel8.Table.Cols (Cols (Cols)) +import Rel8.Table.Name (showNames) +import Rel8.Table.Opaleye (attributes) +import Rel8.Table.Projection (Projecting, Projection, apply) + + +{- | 'OnConflict' represents the @ON CONFLICT@ clause of an @INSERT@ +statement. This specifies what ought to happen when one or more of the +rows proposed for insertion conflict with an existing row in the table. +-} type OnConflict :: Type -> Type data OnConflict names - = Abort - -- ^ Abort the transaction if there are conflicting rows (Postgres' default) - | DoNothing - -- ^ @ON CONFLICT DO NOTHING@ - | DoUpdate (Upsert names) - -- ^ @ON CONFLICT DO UPDATE@ - - --- | The @ON CONFLICT (...) DO UPDATE@ clause of an @INSERT@ statement, also --- known as \"upsert\". --- --- When an existing row conflicts with a row proposed for insertion, --- @ON CONFLICT DO UPDATE@ allows you to instead update this existing row. The --- conflicting row proposed for insertion is then \"excluded\", but its values --- can still be referenced from the @SET@ and @WHERE@ clauses of the @UPDATE@ --- statement. --- --- Upsert in Postgres requires an explicit set of \"conflict targets\" — the --- set of columns comprising the @UNIQUE@ index from conflicts with which we --- would like to recover. + = -- | Abort the transaction if there are conflicting rows (Postgres' default) + Abort + | -- | @ON CONFLICT DO NOTHING@ + DoNothing + | -- | @ON CONFLICT DO UPDATE@ + DoUpdate (Upsert names) + + +{- | The @ON CONFLICT (...) DO UPDATE@ clause of an @INSERT@ statement, also +known as \"upsert\". + +When an existing row conflicts with a row proposed for insertion, +@ON CONFLICT DO UPDATE@ allows you to instead update this existing row. The +conflicting row proposed for insertion is then \"excluded\", but its values +can still be referenced from the @SET@ and @WHERE@ clauses of the @UPDATE@ +statement. + +Upsert in Postgres requires an explicit set of \"conflict targets\" — the +set of columns comprising the @UNIQUE@ index from conflicts with which we +would like to recover. +-} type Upsert :: Type -> Type data Upsert names where - Upsert :: (Selects names exprs, Projecting names index, excluded ~ exprs) => + Upsert :: + (Selects names exprs, Projecting names index, excluded ~ exprs) => { index :: Projection names index - -- ^ The set of conflict targets, projected from the set of columns for - -- the whole table + -- ^ The set of conflict targets, projected from the set of columns for + -- the whole table , set :: excluded -> exprs -> exprs - -- ^ How to update each selected row. + -- ^ How to update each selected row. , updateWhere :: excluded -> exprs -> Expr Bool - -- ^ Which rows to select for update. - } - -> Upsert names + -- ^ Which rows to select for update. + } -> + Upsert names ppOnConflict :: TableSchema names -> OnConflict names -> Doc @@ -86,22 +89,32 @@ ppOnConflict schema = \case ppUpsert :: TableSchema names -> Upsert names -> Doc -ppUpsert schema@TableSchema {columns} Upsert {..} = - text "ON CONFLICT" <+> - ppIndex schema index <+> - text "DO UPDATE" $$ - ppSet schema (set excluded) $$ - ppWhere schema (updateWhere excluded) +ppUpsert schema@TableSchema{columns} Upsert{..} = + text "ON CONFLICT" + <+> ppIndex schema index + <+> text "DO UPDATE" + $$ ppSet schema (set excluded) + $$ ppWhere schema (updateWhere excluded) where - excluded = attributes TableSchema - { schema = Nothing - , name = "excluded" - , columns - } - - -ppIndex :: (Table Name names, Projecting names index) - => TableSchema names -> Projection names index -> Doc -ppIndex TableSchema {columns} index = - parens $ Opaleye.commaV ppColumn $ toList $ - showNames $ Cols $ apply index $ toColumns columns + excluded = + attributes + TableSchema + { schema = Nothing + , name = "excluded" + , columns + } + + +ppIndex :: + (Table Name names, Projecting names index) => + TableSchema names -> + Projection names index -> + Doc +ppIndex TableSchema{columns} index = + parens $ + Opaleye.commaV ppColumn $ + toList $ + showNames $ + Cols $ + apply index $ + toColumns columns diff --git a/src/Rel8/Statement/Returning.hs b/src/Rel8/Statement/Returning.hs index ecdb3dcf..3659ed40 100644 --- a/src/Rel8/Statement/Returning.hs +++ b/src/Rel8/Statement/Returning.hs @@ -1,25 +1,25 @@ -{-# language GADTs #-} -{-# language LambdaCase #-} -{-# language NamedFieldPuns #-} -{-# language RankNTypes #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language StrictData #-} -{-# language TypeApplications #-} - -module Rel8.Statement.Returning - ( Returning( NumberOfRowsAffected, Projection ) - , decodeReturning - , ppReturning - ) +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeApplications #-} + +module Rel8.Statement.Returning ( + Returning (NumberOfRowsAffected, Projection), + decodeReturning, + ppReturning, +) where -- base -import Control.Applicative ( liftA2 ) -import Data.Foldable ( toList ) -import Data.Int ( Int64 ) -import Data.Kind ( Type ) -import Data.List.NonEmpty ( NonEmpty ) +import Control.Applicative (liftA2) +import Data.Foldable (toList) +import Data.Int (Int64) +import Data.Kind (Type) +import Data.List.NonEmpty (NonEmpty) import Prelude -- hasql @@ -31,35 +31,35 @@ import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye import qualified Opaleye.Internal.Sql as Opaleye -- pretty -import Text.PrettyPrint ( Doc, (<+>), text ) +import Text.PrettyPrint (Doc, text, (<+>)) -- rel8 -import Rel8.Schema.Name ( Selects ) -import Rel8.Schema.Table ( TableSchema(..) ) -import Rel8.Table.Opaleye ( castTable, exprs, view ) -import Rel8.Table.Serialize ( Serializable, parse ) +import Rel8.Schema.Name (Selects) +import Rel8.Schema.Table (TableSchema (..)) +import Rel8.Table.Opaleye (castTable, exprs, view) +import Rel8.Table.Serialize (Serializable, parse) --- semigropuoids -import Data.Functor.Apply ( Apply, (<.>) ) +-- semigroupoids +import Data.Functor.Apply (Apply, (<.>)) --- | 'Rel8.Insert', 'Rel8.Update' and 'Rel8.Delete' all support returning either --- the number of rows affected, or the actual rows modified. +{- | 'Rel8.Insert', 'Rel8.Update' and 'Rel8.Delete' all support returning either +the number of rows affected, or the actual rows modified. +-} type Returning :: Type -> Type -> Type data Returning names a where Pure :: a -> Returning names a Ap :: Returning names (a -> b) -> Returning names a -> Returning names b - -- | Return the number of rows affected. NumberOfRowsAffected :: Returning names Int64 - -- | 'Projection' allows you to project out of the affected rows, which can -- be useful if you want to log exactly which rows were deleted, or to view -- a generated id (for example, if using a column with an autoincrementing -- counter via 'Rel8.nextval'). - Projection :: (Selects names exprs, Serializable returning a) - => (exprs -> returning) - -> Returning names [a] + Projection :: + (Selects names exprs, Serializable returning a) => + (exprs -> returning) -> + Returning names [a] instance Functor (Returning names) where @@ -78,36 +78,43 @@ instance Applicative (Returning names) where (<*>) = Ap -projections :: () - => TableSchema names -> Returning names a -> Maybe (NonEmpty Opaleye.PrimExpr) -projections schema@TableSchema {columns} = \case +projections :: + () => + TableSchema names -> + Returning names a -> + Maybe (NonEmpty Opaleye.PrimExpr) +projections schema@TableSchema{columns} = \case Pure _ -> Nothing Ap f a -> projections schema f <> projections schema a NumberOfRowsAffected -> Nothing Projection f -> Just (exprs (castTable (f (view columns)))) -runReturning :: () - => ((Int64 -> a) -> r) - -> (forall x. Hasql.Row x -> ([x] -> a) -> r) - -> Returning names a - -> r +runReturning :: + () => + ((Int64 -> a) -> r) -> + (forall x. Hasql.Row x -> ([x] -> a) -> r) -> + Returning names a -> + r runReturning rowCount rowList = \case Pure a -> rowCount (const a) Ap fs as -> runReturning - (\withCount -> - runReturning - (\withCount' -> rowCount (withCount <*> withCount')) - (\decoder -> rowList decoder . liftA2 withCount length64) - as) - (\decoder withRows -> - runReturning - (\withCount -> rowList decoder $ withRows <*> withCount . length64) - (\decoder' withRows' -> - rowList (liftA2 (,) decoder decoder') $ - withRows <$> fmap fst <*> withRows' . fmap snd) - as) + ( \withCount -> + runReturning + (\withCount' -> rowCount (withCount <*> withCount')) + (\decoder -> rowList decoder . liftA2 withCount length64) + as + ) + ( \decoder withRows -> + runReturning + (\withCount -> rowList decoder $ withRows <*> withCount . length64) + ( \decoder' withRows' -> + rowList (liftA2 (,) decoder decoder') $ + withRows <$> fmap fst <*> withRows' . fmap snd + ) + as + ) fs NumberOfRowsAffected -> rowCount id Projection (_ :: exprs -> returning) -> rowList decoder' id @@ -119,9 +126,10 @@ runReturning rowCount rowList = \case decodeReturning :: Returning names a -> Hasql.Result a -decodeReturning = runReturning - (<$> Hasql.rowsAffected) - (\decoder withRows -> withRows <$> Hasql.rowList decoder) +decodeReturning = + runReturning + (<$> Hasql.rowsAffected) + (\decoder withRows -> withRows <$> Hasql.rowList decoder) ppReturning :: TableSchema names -> Returning names a -> Doc diff --git a/src/Rel8/Statement/SQL.hs b/src/Rel8/Statement/SQL.hs index 1ee41ff8..de2f3d6e 100644 --- a/src/Rel8/Statement/SQL.hs +++ b/src/Rel8/Statement/SQL.hs @@ -1,17 +1,17 @@ -module Rel8.Statement.SQL - ( showDelete - , showInsert - , showUpdate - ) +module Rel8.Statement.SQL ( + showDelete, + showInsert, + showUpdate, +) where -- base import Prelude -- rel8 -import Rel8.Statement.Delete ( Delete, ppDelete ) -import Rel8.Statement.Insert ( Insert, ppInsert ) -import Rel8.Statement.Update ( Update, ppUpdate ) +import Rel8.Statement.Delete (Delete, ppDelete) +import Rel8.Statement.Insert (Insert, ppInsert) +import Rel8.Statement.Update (Update, ppUpdate) -- | Convert a 'Delete' to a 'String' containing a @DELETE@ statement. diff --git a/src/Rel8/Statement/Select.hs b/src/Rel8/Statement/Select.hs index 43e66eeb..e14a6633 100644 --- a/src/Rel8/Statement/Select.hs +++ b/src/Rel8/Statement/Select.hs @@ -1,26 +1,25 @@ -{-# language DeriveTraversable #-} -{-# language DerivingStrategies #-} -{-# language FlexibleContexts #-} -{-# language MonoLocalBinds #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeApplications #-} - -module Rel8.Statement.Select - ( select - , ppSelect - - , Optimized(..) - , ppPrimSelect - , ppRows - ) +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} + +module Rel8.Statement.Select ( + select, + ppSelect, + Optimized (..), + ppPrimSelect, + ppRows, +) where -- base -import Data.Foldable ( toList ) -import Data.Kind ( Type ) -import Data.Void ( Void ) -import Prelude hiding ( undefined ) +import Data.Foldable (toList) +import Data.Kind (Type) +import Data.Void (Void) +import Prelude hiding (undefined) -- hasql import qualified Hasql.Decoders as Hasql @@ -31,39 +30,42 @@ import qualified Hasql.Statement as Hasql import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye +import qualified Opaleye.Internal.Optimize 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 hiding ( Values ) +import qualified Opaleye.Internal.QueryArr as Opaleye hiding (Select) +import qualified Opaleye.Internal.Sql as Opaleye hiding (Values) import qualified Opaleye.Internal.Tag as Opaleye -- pretty -import Text.PrettyPrint ( Doc ) +import Text.PrettyPrint (Doc) -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Expr.Bool ( false ) -import Rel8.Expr.Opaleye ( toPrimExpr ) -import Rel8.Query ( Query ) -import Rel8.Query.Opaleye ( toOpaleye ) -import Rel8.Schema.Name ( Selects ) -import Rel8.Table ( Table ) -import Rel8.Table.Cols ( toCols ) -import Rel8.Table.Name ( namesFromLabels ) -import Rel8.Table.Opaleye ( castTable, exprsWithNames ) +import Rel8.Expr (Expr) +import Rel8.Expr.Bool (false) +import Rel8.Expr.Opaleye (toPrimExpr) +import Rel8.Query (Query) +import Rel8.Query.Opaleye (toOpaleye) +import Rel8.Schema.Name (Selects) +import Rel8.Table (Table) +import Rel8.Table.Cols (toCols) +import Rel8.Table.Name (namesFromLabels) +import Rel8.Table.Opaleye (castTable, exprsWithNames) import qualified Rel8.Table.Opaleye as T -import Rel8.Table.Serialize ( Serializable, parse ) -import Rel8.Table.Undefined ( undefined ) +import Rel8.Table.Serialize (Serializable, parse) +import Rel8.Table.Undefined (undefined) -- text import qualified Data.Text as Text -import Data.Text.Encoding ( encodeUtf8 ) +import Data.Text.Encoding (encodeUtf8) -- | Run a @SELECT@ statement, returning all rows. -select :: forall exprs a. Serializable exprs a - => Query exprs -> Hasql.Statement () [a] +select :: + forall exprs a. + Serializable exprs a => + Query exprs -> + Hasql.Statement () [a] select query = Hasql.Statement bytes params decode prepare where bytes = encodeUtf8 (Text.pack sql) @@ -106,8 +108,8 @@ ppRows query = case optimize primQuery of eqSymbol (Opaleye.Symbol name (Opaleye.UnsafeTag tag)) - (Opaleye.Symbol name' (Opaleye.UnsafeTag tag')) - = name == name' && tag == tag' + (Opaleye.Symbol name' (Opaleye.UnsafeTag tag')) = + name == name' && tag == tag' ppPrimSelect :: Query a -> (Optimized Doc, a) @@ -133,13 +135,18 @@ primSelect :: Opaleye.PrimQuery' Void -> Opaleye.Select primSelect = Opaleye.foldPrimQuery Opaleye.sqlQueryGenerator -primSelectWith :: Selects names exprs - => names -> exprs -> Opaleye.PrimQuery' Void -> Opaleye.Select +primSelectWith :: + Selects names exprs => + names -> + exprs -> + Opaleye.PrimQuery' Void -> + Opaleye.Select primSelectWith names exprs query = - Opaleye.SelectFrom $ Opaleye.newSelect - { Opaleye.attrs = Opaleye.SelectAttrs attrs - , Opaleye.tables = Opaleye.oneTable (primSelect query) - } + Opaleye.SelectFrom $ + Opaleye.newSelect + { Opaleye.attrs = Opaleye.SelectAttrs attrs + , Opaleye.tables = Opaleye.oneTable (primSelect query) + } where attrs = makeAttr <$> exprsWithNames names (castTable exprs) where diff --git a/src/Rel8/Statement/Set.hs b/src/Rel8/Statement/Set.hs index 8ff687d7..23354732 100644 --- a/src/Rel8/Statement/Set.hs +++ b/src/Rel8/Statement/Set.hs @@ -1,13 +1,13 @@ -{-# language MonoLocalBinds #-} -{-# language NamedFieldPuns #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE NamedFieldPuns #-} -module Rel8.Statement.Set - ( ppSet - ) +module Rel8.Statement.Set ( + ppSet, +) where -- base -import Data.Foldable ( toList ) +import Data.Foldable (toList) import Prelude () -- opaleye @@ -15,17 +15,20 @@ import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye import qualified Opaleye.Internal.Sql as Opaleye -- pretty -import Text.PrettyPrint ( Doc, (<+>), equals, text ) +import Text.PrettyPrint (Doc, equals, text, (<+>)) -- rel8 -import Rel8.Schema.Name ( Selects, ppColumn ) -import Rel8.Schema.Table ( TableSchema(..) ) -import Rel8.Table.Opaleye ( attributes, exprsWithNames ) +import Rel8.Schema.Name (Selects, ppColumn) +import Rel8.Schema.Table (TableSchema (..)) +import Rel8.Table.Opaleye (attributes, exprsWithNames) -ppSet :: Selects names exprs - => TableSchema names -> (exprs -> exprs) -> Doc -ppSet schema@TableSchema {columns} f = +ppSet :: + Selects names exprs => + TableSchema names -> + (exprs -> exprs) -> + Doc +ppSet schema@TableSchema{columns} f = text "SET" <+> Opaleye.commaV ppAssign (toList assigns) where assigns = exprsWithNames columns (f (attributes schema)) diff --git a/src/Rel8/Statement/Update.hs b/src/Rel8/Statement/Update.hs index 7c615210..217b517a 100644 --- a/src/Rel8/Statement/Update.hs +++ b/src/Rel8/Statement/Update.hs @@ -1,19 +1,19 @@ -{-# language DuplicateRecordFields #-} -{-# language GADTs #-} -{-# language NamedFieldPuns #-} -{-# language RecordWildCards #-} -{-# language StandaloneKindSignatures #-} -{-# language StrictData #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE StrictData #-} -module Rel8.Statement.Update - ( Update(..) - , update - , ppUpdate - ) +module Rel8.Statement.Update ( + Update (..), + update, + ppUpdate, +) where -- base -import Data.Kind ( Type ) +import Data.Kind (Type) import Prelude -- hasql @@ -21,59 +21,62 @@ import qualified Hasql.Encoders as Hasql import qualified Hasql.Statement as Hasql -- pretty -import Text.PrettyPrint ( Doc, (<+>), ($$), text ) +import Text.PrettyPrint (Doc, text, ($$), (<+>)) -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Query ( Query ) -import Rel8.Schema.Name ( Selects ) -import Rel8.Schema.Table ( TableSchema(..), ppTable ) -import Rel8.Statement.Returning ( Returning, decodeReturning, ppReturning ) -import Rel8.Statement.Set ( ppSet ) -import Rel8.Statement.Using ( ppFrom ) -import Rel8.Statement.Where ( ppWhere ) +import Rel8.Expr (Expr) +import Rel8.Query (Query) +import Rel8.Schema.Name (Selects) +import Rel8.Schema.Table (TableSchema (..), ppTable) +import Rel8.Statement.Returning (Returning, decodeReturning, ppReturning) +import Rel8.Statement.Set (ppSet) +import Rel8.Statement.Using (ppFrom) +import Rel8.Statement.Where (ppWhere) -- text import qualified Data.Text as Text -import Data.Text.Encoding ( encodeUtf8 ) +import Data.Text.Encoding (encodeUtf8) -- | The constituent parts of an @UPDATE@ statement. type Update :: Type -> Type data Update a where - Update :: Selects names exprs => + Update :: + Selects names exprs => { target :: TableSchema names - -- ^ Which table to update. + -- ^ Which table to update. , from :: Query from - -- ^ @FROM@ clause — this can be used to join against other tables, - -- and its results can be referenced in the @SET@ and @WHERE@ clauses. + -- ^ @FROM@ clause — this can be used to join against other tables, + -- and its results can be referenced in the @SET@ and @WHERE@ clauses. , set :: from -> exprs -> exprs - -- ^ How to update each selected row. + -- ^ How to update each selected row. , updateWhere :: from -> exprs -> Expr Bool - -- ^ Which rows to select for update. + -- ^ Which rows to select for update. , returning :: Returning names a - -- ^ What to return from the @UPDATE@ statement. - } - -> Update a + -- ^ What to return from the @UPDATE@ statement. + } -> + Update a ppUpdate :: Update a -> Doc -ppUpdate Update {..} = case ppFrom from of +ppUpdate Update{..} = case ppFrom from of Nothing -> - text "UPDATE" <+> ppTable target $$ - ppSet target id $$ - text "WHERE false" + text "UPDATE" + <+> ppTable target + $$ ppSet target id + $$ text "WHERE false" Just (fromDoc, i) -> - text "UPDATE" <+> ppTable target $$ - ppSet target (set i) $$ - fromDoc $$ - ppWhere target (updateWhere i) $$ - ppReturning target returning + text "UPDATE" + <+> ppTable target + $$ ppSet target (set i) + $$ fromDoc + $$ ppWhere target (updateWhere i) + $$ ppReturning target returning -- | Run an @UPDATE@ statement. update :: Update a -> Hasql.Statement () a -update u@Update {returning} = Hasql.Statement bytes params decode prepare +update u@Update{returning} = Hasql.Statement bytes params decode prepare where bytes = encodeUtf8 $ Text.pack sql params = Hasql.noParams diff --git a/src/Rel8/Statement/Using.hs b/src/Rel8/Statement/Using.hs index c8dc00cd..5f13a2c4 100644 --- a/src/Rel8/Statement/Using.hs +++ b/src/Rel8/Statement/Using.hs @@ -1,19 +1,19 @@ -module Rel8.Statement.Using - ( ppFrom - , ppUsing - ) +module Rel8.Statement.Using ( + ppFrom, + ppUsing, +) where -- base import Prelude -- pretty -import Text.PrettyPrint ( Doc, (<+>), parens, text ) +import Text.PrettyPrint (Doc, parens, text, (<+>)) -- rel8 -import Rel8.Query ( Query ) -import Rel8.Schema.Table ( TableSchema(..), ppTable ) -import Rel8.Statement.Select ( Optimized(..), ppPrimSelect ) +import Rel8.Query (Query) +import Rel8.Schema.Table (TableSchema (..), ppTable) +import Rel8.Statement.Select (Optimized (..), ppPrimSelect) ppFrom :: Query a -> Maybe (Doc, a) @@ -32,5 +32,5 @@ ppJoin clause join = do Optimized doc -> Just $ text clause <+> parens doc <+> ppTable alias pure (doc, a) where - alias = TableSchema {name = "T1", schema = Nothing, columns = ()} + alias = TableSchema{name = "T1", schema = Nothing, columns = ()} (ofrom, a) = ppPrimSelect join diff --git a/src/Rel8/Statement/View.hs b/src/Rel8/Statement/View.hs index a4fa09b4..0a21d699 100644 --- a/src/Rel8/Statement/View.hs +++ b/src/Rel8/Statement/View.hs @@ -1,10 +1,10 @@ -{-# language FlexibleContexts #-} -{-# language MonoLocalBinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} -module Rel8.Statement.View - ( createView - , createOrReplaceView - ) +module Rel8.Statement.View ( + createView, + createOrReplaceView, +) where -- base @@ -15,46 +15,58 @@ import qualified Hasql.Decoders as Hasql import qualified Hasql.Encoders as Hasql import qualified Hasql.Statement as Hasql --- rel8 -import Rel8.Query ( Query ) -import Rel8.Schema.Name ( Selects ) -import Rel8.Schema.Table ( TableSchema ) -import Rel8.Statement.Insert ( ppInto ) -import Rel8.Statement.Select ( ppSelect ) - -- pretty -import Text.PrettyPrint ( Doc, (<+>), ($$), text ) +import Text.PrettyPrint (Doc, text, ($$), (<+>)) + +-- rel8 +import Rel8.Query (Query) +import Rel8.Schema.Name (Selects) +import Rel8.Schema.Table (TableSchema) +import Rel8.Statement.Insert (ppInto) +import Rel8.Statement.Select (ppSelect) -- text import qualified Data.Text as Text -import Data.Text.Encoding ( encodeUtf8 ) +import Data.Text.Encoding (encodeUtf8) data CreateView = Create | CreateOrReplace --- | Given a 'TableSchema' and 'Query', @createView@ runs a @CREATE VIEW@ --- statement that will save the given query as a view. This can be useful if --- you want to share Rel8 queries with other applications. -createView :: Selects names exprs - => TableSchema names -> Query exprs -> Hasql.Statement () () +{- | Given a 'TableSchema' and 'Query', @createView@ runs a @CREATE VIEW@ +statement that will save the given query as a view. This can be useful if +you want to share Rel8 queries with other applications. +-} +createView :: + Selects names exprs => + TableSchema names -> + Query exprs -> + Hasql.Statement () () createView = createViewGeneric Create --- | Given a 'TableSchema' and 'Query', @createOrReplaceView@ runs a --- @CREATE OR REPLACE VIEW@ statement that will save the given query --- as a view, replacing the current view definition if it exists and --- adheres to the restrictions in place for replacing a view in --- PostgreSQL. -createOrReplaceView :: Selects names exprs - => TableSchema names -> Query exprs -> Hasql.Statement () () +{- | Given a 'TableSchema' and 'Query', @createOrReplaceView@ runs a +@CREATE OR REPLACE VIEW@ statement that will save the given query +as a view, replacing the current view definition if it exists and +adheres to the restrictions in place for replacing a view in +PostgreSQL. +-} +createOrReplaceView :: + Selects names exprs => + TableSchema names -> + Query exprs -> + Hasql.Statement () () createOrReplaceView = createViewGeneric CreateOrReplace -createViewGeneric :: Selects names exprs - => CreateView -> TableSchema names -> Query exprs -> Hasql.Statement () () +createViewGeneric :: + Selects names exprs => + CreateView -> + TableSchema names -> + Query exprs -> + Hasql.Statement () () createViewGeneric replace schema query = Hasql.Statement bytes params decode prepare where @@ -66,13 +78,17 @@ createViewGeneric replace schema query = doc = ppCreateView schema query replace -ppCreateView :: Selects names exprs - => TableSchema names -> Query exprs -> CreateView -> Doc +ppCreateView :: + Selects names exprs => + TableSchema names -> + Query exprs -> + CreateView -> + Doc ppCreateView schema query replace = - createOrReplace replace <+> - ppInto schema $$ - text "AS" <+> - ppSelect query + createOrReplace replace + <+> ppInto schema + $$ text "AS" + <+> ppSelect query where createOrReplace Create = text "CREATE VIEW" createOrReplace CreateOrReplace = text "CREATE OR REPLACE VIEW" diff --git a/src/Rel8/Statement/Where.hs b/src/Rel8/Statement/Where.hs index 5d6578ad..9bce68eb 100644 --- a/src/Rel8/Statement/Where.hs +++ b/src/Rel8/Statement/Where.hs @@ -1,8 +1,8 @@ -{-# language MonoLocalBinds #-} +{-# LANGUAGE MonoLocalBinds #-} -module Rel8.Statement.Where - ( ppWhere - ) +module Rel8.Statement.Where ( + ppWhere, +) where -- base @@ -13,18 +13,21 @@ import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye import qualified Opaleye.Internal.Sql as Opaleye -- pretty -import Text.PrettyPrint ( Doc, (<+>), text ) +import Text.PrettyPrint (Doc, text, (<+>)) -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Expr.Opaleye ( toPrimExpr ) -import Rel8.Schema.Name ( Selects ) -import Rel8.Schema.Table ( TableSchema ) -import Rel8.Table.Opaleye ( attributes ) +import Rel8.Expr (Expr) +import Rel8.Expr.Opaleye (toPrimExpr) +import Rel8.Schema.Name (Selects) +import Rel8.Schema.Table (TableSchema) +import Rel8.Table.Opaleye (attributes) -ppWhere :: Selects names exprs - => TableSchema names -> (exprs -> Expr Bool) -> Doc +ppWhere :: + Selects names exprs => + TableSchema names -> + (exprs -> Expr Bool) -> + Doc ppWhere schema where_ = text "WHERE" <+> ppExpr condition where ppExpr = Opaleye.ppSqlExpr . Opaleye.sqlExpr . toPrimExpr diff --git a/src/Rel8/Table.hs b/src/Rel8/Table.hs index 40278ac7..ac5a0a25 100644 --- a/src/Rel8/Table.hs +++ b/src/Rel8/Table.hs @@ -1,146 +1,176 @@ -{-# language AllowAmbiguousTypes #-} -{-# language DataKinds #-} -{-# language DefaultSignatures #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language FunctionalDependencies #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeApplications #-} -{-# language TypeFamilies #-} -{-# language TypeOperators #-} -{-# language UndecidableInstances #-} - -module Rel8.Table - ( Table - ( Columns, Context, fromColumns, toColumns - , FromExprs, fromResult, toResult - , Transpose - ) - , Congruent - , TTable, TColumns, TContext, TFromExprs, TTranspose - , TSerialize - ) +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Rel8.Table ( + Table ( + Columns, + Context, + fromColumns, + toColumns, + FromExprs, + fromResult, + toResult, + Transpose + ), + Congruent, + TTable, + TColumns, + TContext, + TFromExprs, + TTranspose, + TSerialize, +) where -- base -import Data.Functor.Identity ( Identity( Identity ) ) -import Data.Kind ( Constraint, Type ) -import GHC.Generics ( Generic, Rep, from, to ) -import Prelude hiding ( null ) +import Data.Functor.Identity (Identity (Identity)) +import Data.Kind (Constraint, Type) +import GHC.Generics (Generic, Rep, from, to) +import Prelude hiding (null) -- rel8 -import Rel8.FCF ( Eval, Exp ) -import Rel8.Generic.Map ( Map ) -import Rel8.Generic.Table.Record - ( GTable, GColumns, GContext, gfromColumns, gtoColumns - , GSerialize, gfromResult, gtoResult - ) -import Rel8.Generic.Record ( Record(..) ) -import Rel8.Schema.HTable ( HTable ) -import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) ) +import Rel8.FCF (Eval, Exp) +import Rel8.Generic.Map (Map) +import Rel8.Generic.Record (Record (..)) +import Rel8.Generic.Table.Record ( + GColumns, + GContext, + GSerialize, + GTable, + gfromColumns, + gfromResult, + gtoColumns, + gtoResult, + ) +import Rel8.Schema.HTable (HTable) +import Rel8.Schema.HTable.Identity (HIdentity (HIdentity)) import qualified Rel8.Schema.Kind as K -import Rel8.Schema.Null ( Sql ) -import Rel8.Schema.Result ( Result ) -import Rel8.Type ( DBType ) - - --- | @Table@s are one of the foundational elements of Rel8, and describe data --- types that have a finite number of columns. Each of these columns contains --- data under a shared context, and contexts describe how to interpret the --- metadata about a column to a particular Haskell type. In Rel8, we have --- contexts for expressions (the 'Rel8.Expr' context), aggregations (the --- 'Rel8.Aggregate' context), insert values (the 'Rel8.Insert' contex), among --- others. --- --- In typical usage of Rel8 you don't need to derive instances of 'Table' --- yourself, as anything that's an instance of 'Rel8.Rel8able' is always a --- 'Table'. +import Rel8.Schema.Null (Sql) +import Rel8.Schema.Result (Result) +import Rel8.Type (DBType) + + +{- | @Table@s are one of the foundational elements of Rel8, and describe data +types that have a finite number of columns. Each of these columns contains +data under a shared context, and contexts describe how to interpret the +metadata about a column to a particular Haskell type. In Rel8, we have +contexts for expressions (the 'Rel8.Expr' context), aggregations (the +'Rel8.Aggregate' context), insert values (the 'Rel8.Insert' contex), among +others. + +In typical usage of Rel8 you don't need to derive instances of 'Table' +yourself, as anything that's an instance of 'Rel8.Rel8able' is always a +'Table'. +-} type Table :: K.Context -> Type -> Constraint class ( HTable (Columns a) , context ~ Context a , a ~ Transpose context a - ) - => Table context a | a -> context - where + ) => + Table context a + | a -> context + where -- | The 'HTable' functor that describes the schema of this table. type Columns a :: K.HTable + -- | The common context that all columns use as an interpretation. type Context a :: K.Context + -- | The @FromExprs@ type family maps a type in the @Expr@ context to the -- corresponding Haskell type. type FromExprs a :: Type + type Transpose (context' :: K.Context) a :: Type toColumns :: a -> Columns a context fromColumns :: Columns a context -> a + fromResult :: Columns a Result -> FromExprs a toResult :: FromExprs a -> Columns a Result + type Columns a = GColumns TColumns (Rep (Record a)) type Context a = GContext TContext (Rep (Record a)) type FromExprs a = Map TFromExprs a type Transpose context a = Map (TTranspose context) a + default toColumns :: ( Generic (Record a) , GTable (TTable context) TColumns (Rep (Record a)) , Columns a ~ GColumns TColumns (Rep (Record a)) - ) - => a -> Columns a context + ) => + a -> + Columns a context toColumns = - gtoColumns @(TTable context) @TColumns toColumns . - from . - Record + gtoColumns @(TTable context) @TColumns toColumns + . from + . Record + default fromColumns :: ( Generic (Record a) , GTable (TTable context) TColumns (Rep (Record a)) , Columns a ~ GColumns TColumns (Rep (Record a)) - ) - => Columns a context -> a + ) => + Columns a context -> + a fromColumns = - unrecord . - to . - gfromColumns @(TTable context) @TColumns fromColumns + unrecord + . to + . gfromColumns @(TTable context) @TColumns fromColumns + default toResult :: ( Generic (Record (FromExprs a)) , GSerialize TSerialize TColumns (Rep (Record a)) (Rep (Record (FromExprs a))) , Columns a ~ GColumns TColumns (Rep (Record a)) - ) - => FromExprs a -> Columns a Result + ) => + FromExprs a -> + Columns a Result toResult = gtoResult @TSerialize @TColumns @(Rep (Record a)) @(Rep (Record (FromExprs a))) - (\(_ :: proxy x) -> toResult @(Context x) @x) . - from . - Record + (\(_ :: proxy x) -> toResult @(Context x) @x) + . from + . Record + default fromResult :: ( Generic (Record (FromExprs a)) , GSerialize TSerialize TColumns (Rep (Record a)) (Rep (Record (FromExprs a))) , Columns a ~ GColumns TColumns (Rep (Record a)) - ) - => Columns a Result -> FromExprs a + ) => + Columns a Result -> + FromExprs a fromResult = - unrecord . - to . - gfromResult - @TSerialize - @TColumns - @(Rep (Record a)) - @(Rep (Record (FromExprs a))) - (\(_ :: proxy x) -> fromResult @(Context x) @x) + unrecord + . to + . gfromResult + @TSerialize + @TColumns + @(Rep (Record a)) + @(Rep (Record (FromExprs a))) + (\(_ :: proxy x) -> fromResult @(Context x) @x) instance Sql DBType a => Table Result (Identity a) where @@ -149,6 +179,7 @@ instance Sql DBType a => Table Result (Identity a) where type FromExprs (Identity a) = a type Transpose to (Identity a) = to a + toColumns = HIdentity fromColumns (HIdentity a) = a toResult a = HIdentity (Identity a) @@ -176,46 +207,64 @@ type instance Eval (TTranspose context a) = Transpose context a data TSerialize :: Type -> Type -> Exp Constraint -type instance Eval (TSerialize expr a) = - ( Table (Context expr) expr - , a ~ FromExprs expr - ) +type instance + Eval (TSerialize expr a) = + ( Table (Context expr) expr + , a ~ FromExprs expr + ) instance (Table context a, Table context b) => Table context (a, b) instance - ( Table context a, Table context b, Table context c - ) - => Table context (a, b, c) + ( Table context a + , Table context b + , Table context c + ) => + Table context (a, b, c) instance - ( Table context a, Table context b, Table context c, Table context d - ) - => Table context (a, b, c, d) + ( Table context a + , Table context b + , Table context c + , Table context d + ) => + Table context (a, b, c, d) instance - ( Table context a, Table context b, Table context c, Table context d + ( Table context a + , Table context b + , Table context c + , Table context d , Table context e - ) - => Table context (a, b, c, d, e) + ) => + Table context (a, b, c, d, e) instance - ( Table context a, Table context b, Table context c, Table context d - , Table context e, Table context f - ) - => Table context (a, b, c, d, e, f) + ( Table context a + , Table context b + , Table context c + , Table context d + , Table context e + , Table context f + ) => + Table context (a, b, c, d, e, f) instance - ( Table context a, Table context b, Table context c, Table context d - , Table context e, Table context f, Table context g - ) - => Table context (a, b, c, d, e, f, g) + ( Table context a + , Table context b + , Table context c + , Table context d + , Table context e + , Table context f + , Table context g + ) => + Table context (a, b, c, d, e, f, g) type Congruent :: Type -> Type -> Constraint diff --git a/src/Rel8/Table/ADT.hs b/src/Rel8/Table/ADT.hs index dfd4f237..5c158449 100644 --- a/src/Rel8/Table/ADT.hs +++ b/src/Rel8/Table/ADT.hs @@ -1,60 +1,77 @@ -{-# language AllowAmbiguousTypes #-} -{-# language DataKinds #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language MultiParamTypeClasses #-} -{-# language RankNTypes #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeApplications #-} -{-# language TypeFamilyDependencies #-} -{-# language UndecidableInstances #-} -{-# language UndecidableSuperClasses #-} - -module Rel8.Table.ADT - ( ADT( ADT ) - , ADTable - , BuildableADT - , BuildADT, buildADT - , ConstructableADT - , ConstructADT, constructADT - , DeconstructADT, deconstructADT, deconstructAADT - , NameADT, nameADT - , ADTRep - ) +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module Rel8.Table.ADT ( + ADT (ADT), + ADTable, + BuildableADT, + BuildADT, + buildADT, + ConstructableADT, + ConstructADT, + constructADT, + DeconstructADT, + deconstructADT, + deconstructAADT, + NameADT, + nameADT, + ADTRep, +) where -- base -import Data.Kind ( Constraint, Type ) -import GHC.Generics ( Generic, from, to ) -import GHC.TypeLits ( Symbol ) +import Data.Kind (Constraint, Type) +import GHC.Generics (Generic, from, to) +import GHC.TypeLits (Symbol) import Prelude -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.FCF ( Eval, Exp ) -import Rel8.Generic.Construction - ( GGBuildable - , GGBuild, ggbuild - , GGConstructable - , GGConstruct, ggconstruct - , GGDeconstruct, ggdeconstruct, ggdeconstructA - , GGName, ggname - ) -import Rel8.Generic.Record ( Record( Record ), unrecord ) -import Rel8.Generic.Rel8able - ( Rel8able - , GRep, GColumns, gfromColumns, gtoColumns - , GFromExprs, gfromResult, gtoResult - , TSerialize, deserialize, serialize - ) +import Rel8.Expr (Expr) +import Rel8.FCF (Eval, Exp) +import Rel8.Generic.Construction ( + GGBuild, + GGBuildable, + GGConstruct, + GGConstructable, + GGDeconstruct, + GGName, + ggbuild, + ggconstruct, + ggdeconstruct, + ggdeconstructA, + ggname, + ) +import Rel8.Generic.Record (Record (Record), unrecord) +import Rel8.Generic.Rel8able ( + GColumns, + GFromExprs, + GRep, + Rel8able, + TSerialize, + deserialize, + gfromColumns, + gfromResult, + gtoColumns, + gtoResult, + serialize, + ) import qualified Rel8.Generic.Table.ADT as G import qualified Rel8.Kind.Algebra as K -import Rel8.Schema.HTable ( HTable ) +import Rel8.Schema.HTable (HTable) import qualified Rel8.Schema.Kind as K -import Rel8.Schema.Name ( Name ) -import Rel8.Schema.Result ( Result ) -import Rel8.Table ( Table, TColumns ) +import Rel8.Schema.Name (Name) +import Rel8.Schema.Result (Result) +import Rel8.Table (TColumns, Table) -- semigroupoids import Data.Functor.Apply (Apply) @@ -68,18 +85,21 @@ instance ADTable t => Rel8able (ADT t) where type GColumns (ADT t) = GColumnsADT t type GFromExprs (ADT t) = t Result + gfromColumns _ = ADT gtoColumns _ (ADT a) = a + gfromResult = - unrecord . - to . - G.gfromResultADT - @TSerialize - @TColumns - @(Eval (ADTRep t Expr)) - @(Eval (ADTRep t Result)) - (\(_ :: proxy x) -> deserialize @_ @x) + unrecord + . to + . G.gfromResultADT + @TSerialize + @TColumns + @(Eval (ADTRep t Expr)) + @(Eval (ADTRep t Result)) + (\(_ :: proxy x) -> deserialize @_ @x) + gtoResult = G.gtoResultADT @@ -87,9 +107,9 @@ instance ADTable t => Rel8able (ADT t) where @TColumns @(Eval (ADTRep t Expr)) @(Eval (ADTRep t Result)) - (\(_ :: proxy x) -> serialize @_ @x) . - from . - Record + (\(_ :: proxy x) -> serialize @_ @x) + . from + . Record type ADTable :: K.Rel8able -> Constraint @@ -97,14 +117,14 @@ class ( Generic (Record (t Result)) , HTable (GColumnsADT t) , G.GSerializeADT TSerialize TColumns (Eval (ADTRep t Expr)) (Eval (ADTRep t Result)) - ) - => ADTable t + ) => + ADTable t instance ( Generic (Record (t Result)) , HTable (GColumnsADT t) , G.GSerializeADT TSerialize TColumns (Eval (ADTRep t Expr)) (Eval (ADTRep t Result)) - ) - => ADTable t + ) => + ADTable t type BuildableADT :: K.Rel8able -> Symbol -> Constraint @@ -132,7 +152,8 @@ type ConstructADT t = forall r. GGConstruct 'K.Sum (ADTRep t) r constructADT :: forall t. ConstructableADT t => ConstructADT t -> ADT t Expr constructADT f = - ggconstruct @'K.Sum @(ADTRep t) @(ADT t Expr) ADT + ggconstruct @'K.Sum @(ADTRep t) @(ADT t Expr) + ADT (f @(ADT t Expr)) @@ -140,14 +161,18 @@ type DeconstructADT :: K.Rel8able -> Type -> Type type DeconstructADT t r = GGDeconstruct 'K.Sum (ADTRep t) (ADT t Expr) r -deconstructADT :: forall t r. (ConstructableADT t, Table Expr r) - => DeconstructADT t r +deconstructADT :: + forall t r. + (ConstructableADT t, Table Expr r) => + DeconstructADT t r deconstructADT = ggdeconstruct @'K.Sum @(ADTRep t) @(ADT t Expr) @r (\(ADT a) -> a) -deconstructAADT :: forall t f r. (ConstructableADT t, Apply f, Table Expr r) - => DeconstructADT t (f r) +deconstructAADT :: + forall t f r. + (ConstructableADT t, Apply f, Table Expr r) => + DeconstructADT t (f r) deconstructAADT = ggdeconstructA @'K.Sum @(ADTRep t) @(ADT t Expr) @f @r (\(ADT a) -> a) diff --git a/src/Rel8/Table/Aggregate.hs b/src/Rel8/Table/Aggregate.hs index 50185550..be24b00b 100644 --- a/src/Rel8/Table/Aggregate.hs +++ b/src/Rel8/Table/Aggregate.hs @@ -1,17 +1,22 @@ -{-# language BlockArguments #-} -{-# language FlexibleContexts #-} -{-# language NamedFieldPuns #-} -{-# language ScopedTypeVariables #-} -{-# language TypeApplications #-} -{-# language TypeFamilies #-} - -module Rel8.Table.Aggregate - ( groupBy, groupByOn - , listAgg, listAggOn, nonEmptyAgg, nonEmptyAggOn - , filterWhere, filterWhereOptional - , orderAggregateBy - , optionalAggregate - ) +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Rel8.Table.Aggregate ( + groupBy, + groupByOn, + listAgg, + listAggOn, + nonEmptyAgg, + nonEmptyAggOn, + filterWhere, + filterWhereOptional, + orderAggregateBy, + optionalAggregate, +) where -- base @@ -24,51 +29,54 @@ import qualified Opaleye.Internal.Aggregate as Opaleye import Data.Profunctor (dimap, lmap) -- rel8 -import Rel8.Aggregate - ( Aggregator, Aggregator' (Aggregator), Aggregator1 - , toAggregator - ) +import Rel8.Aggregate ( + Aggregator, + Aggregator' (Aggregator), + Aggregator1, + toAggregator, + ) import Rel8.Aggregate.Fold (Fallback (Fallback)) -import Rel8.Expr ( Expr ) -import Rel8.Expr.Aggregate - ( filterWhereExplicit - , groupByExprOn - , slistAggExpr - , snonEmptyAggExpr - ) +import Rel8.Expr (Expr) +import Rel8.Expr.Aggregate ( + filterWhereExplicit, + groupByExprOn, + slistAggExpr, + snonEmptyAggExpr, + ) import Rel8.Expr.Opaleye (toColumn, toPrimExpr) import Rel8.Order (Order (Order)) -import Rel8.Schema.Dict ( Dict( Dict ) ) +import Rel8.Schema.Dict (Dict (Dict)) import Rel8.Schema.HTable (HTable, hfield, htabulateA) import Rel8.Schema.HTable.Vectorize (hvectorizeA) -import Rel8.Schema.Null ( Sql ) -import Rel8.Schema.Spec ( Spec( Spec, info ) ) -import Rel8.Table (Table, toColumns, fromColumns) -import Rel8.Table.Eq ( EqTable, eqTable ) -import Rel8.Table.List ( ListTable ) -import Rel8.Table.Maybe (MaybeTable, makeMaybeTable, justTable, nothingTable) -import Rel8.Table.NonEmpty ( NonEmptyTable ) +import Rel8.Schema.Null (Sql) +import Rel8.Schema.Spec (Spec (Spec, info)) +import Rel8.Table (Table, fromColumns, toColumns) +import Rel8.Table.Eq (EqTable, eqTable) +import Rel8.Table.List (ListTable) +import Rel8.Table.Maybe (MaybeTable, justTable, makeMaybeTable, nothingTable) +import Rel8.Table.NonEmpty (NonEmptyTable) import Rel8.Table.Opaleye (ifPP) -import Rel8.Type.Eq ( DBEq ) - - --- | Group equal tables together. This works by aggregating each column in the --- given table with 'groupByExpr'. --- --- For example, if we have a table of items, we could group the items by the --- order they belong to: --- --- @ --- itemsByOrder :: Query (OrderId Expr, ListTable Expr (Item Expr)) --- itemsByOrder = --- aggregate --- do --- orderId <- groupByOn (.orderId) --- items <- listAgg --- pure (orderId, items) --- do --- each itemSchema --- @ +import Rel8.Type.Eq (DBEq) + + +{- | Group equal tables together. This works by aggregating each column in the +given table with 'groupByExpr'. + +For example, if we have a table of items, we could group the items by the +order they belong to: + +@ +itemsByOrder :: Query (OrderId Expr, ListTable Expr (Item Expr)) +itemsByOrder = + aggregate + do + orderId <- groupByOn (.orderId) + items <- listAgg + pure (orderId, items) + do + each itemSchema +@ +-} groupBy :: forall a. EqTable a => Aggregator1 a a groupBy = dimap toColumns fromColumns (hgroupBy (eqTable @a)) @@ -83,48 +91,57 @@ hgroupBy eqs = htabulateA $ \field -> case hfield eqs field of Dict -> groupByExprOn (`hfield` field) --- | 'filterWhere' allows an 'Aggregator' to filter out rows from the input --- query before considering them for aggregation. Note that because the --- predicate supplied to 'filterWhere' could return 'Rel8.false' for every --- row, 'filterWhere' needs an 'Aggregator' as opposed to an 'Aggregator1', so --- that it can return a default value in such a case. For a variant of --- 'filterWhere' that can work with 'Aggregator1's, see 'filterWhereOptional'. -filterWhere :: Table Expr a - => (i -> Expr Bool) -> Aggregator i a -> Aggregator' fold i a +{- | 'filterWhere' allows an 'Aggregator' to filter out rows from the input +query before considering them for aggregation. Note that because the +predicate supplied to 'filterWhere' could return 'Rel8.false' for every +row, 'filterWhere' needs an 'Aggregator' as opposed to an 'Aggregator1', so +that it can return a default value in such a case. For a variant of +'filterWhere' that can work with 'Aggregator1's, see 'filterWhereOptional'. +-} +filterWhere :: + Table Expr a => + (i -> Expr Bool) -> + Aggregator i a -> + Aggregator' fold i a filterWhere = filterWhereExplicit ifPP --- | A variant of 'filterWhere' that can be used with an 'Aggregator1' --- (upgrading it to an 'Aggregator' in the process). It returns --- 'nothingTable' in the case where the predicate matches zero rows. -filterWhereOptional :: Table Expr a - => (i -> Expr Bool) -> Aggregator' fold i a -> Aggregator' fold' i (MaybeTable Expr a) +{- | A variant of 'filterWhere' that can be used with an 'Aggregator1' +(upgrading it to an 'Aggregator' in the process). It returns +'nothingTable' in the case where the predicate matches zero rows. +-} +filterWhereOptional :: + Table Expr a => + (i -> Expr Bool) -> + Aggregator' fold i a -> + Aggregator' fold' i (MaybeTable Expr a) filterWhereOptional f (Aggregator _ aggregator) = Aggregator (Fallback nothingTable) $ Opaleye.filterWhereInternal makeMaybeTable (toColumn . toPrimExpr . f) aggregator --- | Aggregate rows into a single row containing an array of all aggregated --- rows. This can be used to associate multiple rows with a single row, without --- changing the over cardinality of the query. This allows you to essentially --- return a tree-like structure from queries. --- --- For example, if we have a table of orders and each orders contains multiple --- items, we could aggregate the table of orders, pairing each order with its --- items: --- --- @ --- ordersWithItems :: Query (Order Expr, ListTable Expr (Item Expr)) --- ordersWithItems = do --- order <- each orderSchema --- items <- aggregate listAgg (itemsFromOrder order) --- return (order, items) --- @ +{- | Aggregate rows into a single row containing an array of all aggregated +rows. This can be used to associate multiple rows with a single row, without +changing the over cardinality of the query. This allows you to essentially +return a tree-like structure from queries. + +For example, if we have a table of orders and each orders contains multiple +items, we could aggregate the table of orders, pairing each order with its +items: + +@ +ordersWithItems :: Query (Order Expr, ListTable Expr (Item Expr)) +ordersWithItems = do + order <- each orderSchema + items <- aggregate listAgg (itemsFromOrder order) + return (order, items) +@ +-} listAgg :: Table Expr a => Aggregator' fold a (ListTable Expr a) listAgg = - fromColumns <$> - hvectorizeA \Spec {info} field -> - lmap ((`hfield` field) . toColumns) $ slistAggExpr info + fromColumns + <$> hvectorizeA \Spec{info} field -> + lmap ((`hfield` field) . toColumns) $ slistAggExpr info -- | Applies 'listAgg' to the columns selected by the given function. @@ -135,28 +152,34 @@ listAggOn f = lmap f listAgg -- | Like 'listAgg', but the result is guaranteed to be a non-empty list. nonEmptyAgg :: Table Expr a => Aggregator1 a (NonEmptyTable Expr a) nonEmptyAgg = - fromColumns <$> - hvectorizeA \Spec {info} field -> - lmap ((`hfield` field) . toColumns) $ snonEmptyAggExpr info + fromColumns + <$> hvectorizeA \Spec{info} field -> + lmap ((`hfield` field) . toColumns) $ snonEmptyAggExpr info -- | Applies 'nonEmptyAgg' to the columns selected by the given function. -nonEmptyAggOn :: Table Expr a - => (i -> a) -> Aggregator1 i (NonEmptyTable Expr a) +nonEmptyAggOn :: + Table Expr a => + (i -> a) -> + Aggregator1 i (NonEmptyTable Expr a) nonEmptyAggOn f = lmap f nonEmptyAgg --- | Order the values within each aggregation in an `Aggregator` using the --- given ordering. This is only relevant for aggregations that depend on the --- order they get their elements, like `Rel8.listAgg` and `Rel8.stringAgg`. +{- | Order the values within each aggregation in an `Aggregator` using the +given ordering. This is only relevant for aggregations that depend on the +order they get their elements, like `Rel8.listAgg` and `Rel8.stringAgg`. +-} orderAggregateBy :: Order i -> Aggregator' fold i a -> Aggregator' fold i a orderAggregateBy (Order order) (Aggregator fallback aggregator) = Aggregator fallback $ Opaleye.orderAggregate order aggregator --- | 'optionalAggregate' upgrades an 'Aggregator1' into an 'Aggregator' by --- having it return 'nothingTable' when aggregating over an empty collection --- of rows. -optionalAggregate :: Table Expr a - => Aggregator' fold i a -> Aggregator' fold' i (MaybeTable Expr a) +{- | 'optionalAggregate' upgrades an 'Aggregator1' into an 'Aggregator' by +having it return 'nothingTable' when aggregating over an empty collection +of rows. +-} +optionalAggregate :: + Table Expr a => + Aggregator' fold i a -> + Aggregator' fold' i (MaybeTable Expr a) optionalAggregate = toAggregator nothingTable . fmap justTable diff --git a/src/Rel8/Table/Alternative.hs b/src/Rel8/Table/Alternative.hs index cf331ecd..9126dc65 100644 --- a/src/Rel8/Table/Alternative.hs +++ b/src/Rel8/Table/Alternative.hs @@ -1,36 +1,40 @@ -{-# language FlexibleContexts #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeFamilies #-} - -module Rel8.Table.Alternative - ( AltTable ( (<|>:) ) - , AlternativeTable ( emptyTable ) - ) +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} + +module Rel8.Table.Alternative ( + AltTable ((<|>:)), + AlternativeTable (emptyTable), +) where -- base -import Data.Kind ( Constraint, Type ) +import Data.Kind (Constraint, Type) import Prelude () -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Table ( Table ) +import Rel8.Expr (Expr) +import Rel8.Table (Table) + +{- | Like 'Alt' in Haskell. This class is purely a Rel8 concept, and allows you +to take a choice between two tables. See also 'AlternativeTable'. --- | Like 'Alt' in Haskell. This class is purely a Rel8 concept, and allows you --- to take a choice between two tables. See also 'AlternativeTable'. --- --- For example, using '<|>:' on 'Rel8.MaybeTable' allows you to combine two --- tables and to return the first one that is a "just" MaybeTable. +For example, using '<|>:' on 'Rel8.MaybeTable' allows you to combine two +tables and to return the first one that is a "just" MaybeTable. +-} type AltTable :: (Type -> Type) -> Constraint class AltTable f where -- | An associative binary operation on 'Table's. (<|>:) :: Table Expr a => f a -> f a -> f a + + infixl 3 <|>: --- | Like 'Alternative' in Haskell, some 'Table's form a monoid on applicative --- functors. +{- | Like 'Alternative' in Haskell, some 'Table's form a monoid on applicative +functors. +-} type AlternativeTable :: (Type -> Type) -> Constraint class AltTable f => AlternativeTable f where -- | The identity of '<|>:'. diff --git a/src/Rel8/Table/Bool.hs b/src/Rel8/Table/Bool.hs index 557c27fa..6100a77f 100644 --- a/src/Rel8/Table/Bool.hs +++ b/src/Rel8/Table/Bool.hs @@ -1,40 +1,42 @@ -{-# language FlexibleContexts #-} -{-# language TypeFamilies #-} -{-# language ViewPatterns #-} - -module Rel8.Table.Bool - ( bool - , case_ - , nullable - ) +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module Rel8.Table.Bool ( + bool, + case_, + nullable, +) where -- base import Prelude -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Expr.Bool ( boolExpr, caseExpr ) -import Rel8.Expr.Null ( isNull, unsafeUnnullify ) -import Rel8.Schema.HTable ( htabulate, hfield ) -import Rel8.Table ( Table, fromColumns, toColumns ) +import Rel8.Expr (Expr) +import Rel8.Expr.Bool (boolExpr, caseExpr) +import Rel8.Expr.Null (isNull, unsafeUnnullify) +import Rel8.Schema.HTable (hfield, htabulate) +import Rel8.Table (Table, fromColumns, toColumns) --- | An if-then-else expression on tables. --- --- @bool x y p@ returns @x@ if @p@ is @False@, and returns @y@ if @p@ is --- @True@. +{- | An if-then-else expression on tables. + +@bool x y p@ returns @x@ if @p@ is @False@, and returns @y@ if @p@ is +@True@. +-} bool :: Table Expr a => a -> a -> Expr Bool -> a bool (toColumns -> false) (toColumns -> true) condition = fromColumns $ htabulate $ \field -> case (hfield false field, hfield true field) of (falseExpr, trueExpr) -> boolExpr falseExpr trueExpr condition -{-# INLINABLE bool #-} +{-# INLINEABLE bool #-} --- | Produce a table expression from a list of alternatives. Returns the first --- table where the @Expr Bool@ expression is @True@. If no alternatives are --- true, the given default is returned. +{- | Produce a table expression from a list of alternatives. Returns the first +table where the @Expr Bool@ expression is @True@. If no alternatives are +true, the given default is returned. +-} case_ :: Table Expr a => [(Expr Bool, a)] -> a -> a case_ (map (fmap toColumns) -> branches) (toColumns -> fallback) = fromColumns $ htabulate $ \field -> case hfield fallback field of diff --git a/src/Rel8/Table/Cols.hs b/src/Rel8/Table/Cols.hs index 2a98500b..82cef135 100644 --- a/src/Rel8/Table/Cols.hs +++ b/src/Rel8/Table/Cols.hs @@ -1,44 +1,47 @@ -{-# language DataKinds #-} -{-# language FlexibleInstances #-} -{-# language MultiParamTypeClasses #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeFamilies #-} -{-# language TypeOperators #-} -{-# language UndecidableInstances #-} - -module Rel8.Table.Cols - ( Cols( Cols ) - , fromCols - , toCols - ) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Rel8.Table.Cols ( + Cols (Cols), + fromCols, + toCols, +) where -- base -import Data.Kind ( Type ) +import Data.Kind (Type) import Prelude -- rel8 +import Rel8.Schema.HTable (HTable) import qualified Rel8.Schema.Kind as K -import Rel8.Schema.HTable ( HTable ) -import Rel8.Schema.Result ( Result ) -import Rel8.Table ( Table(..) ) +import Rel8.Schema.Result (Result) +import Rel8.Table (Table (..)) type Cols :: K.Context -> K.HTable -> Type newtype Cols context columns = Cols (columns context) -instance (HTable columns, context ~ context') => +instance + (HTable columns, context ~ context') => Table context' (Cols context columns) - where + where type Columns (Cols context columns) = columns type Context (Cols context columns) = context type FromExprs (Cols context columns) = Cols Result columns type Transpose to (Cols context columns) = Cols to columns + toColumns (Cols a) = a fromColumns = Cols + toResult (Cols a) = a fromResult = Cols diff --git a/src/Rel8/Table/Either.hs b/src/Rel8/Table/Either.hs index 3e5c24c2..0b8659fd 100644 --- a/src/Rel8/Table/Either.hs +++ b/src/Rel8/Table/Either.hs @@ -1,86 +1,95 @@ -{-# language DataKinds #-} -{-# language DeriveFunctor #-} -{-# language DerivingStrategies #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language LambdaCase #-} -{-# language MultiParamTypeClasses #-} -{-# language NamedFieldPuns #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeApplications #-} -{-# language TypeFamilies #-} -{-# language TypeOperators #-} -{-# language UndecidableInstances #-} - -{-# options_ghc -fno-warn-orphans #-} - -module Rel8.Table.Either - ( EitherTable(..) - , eitherTable, leftTable, rightTable - , isLeftTable, isRightTable - , aggregateEitherTable - , nameEitherTable - ) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Rel8.Table.Either ( + EitherTable (..), + eitherTable, + leftTable, + rightTable, + isLeftTable, + isRightTable, + aggregateEitherTable, + nameEitherTable, +) where -- base -import Data.Bifunctor ( Bifunctor, bimap ) -import Data.Functor.Identity ( Identity( Identity ) ) -import Data.Kind ( Type ) -import Prelude hiding ( undefined ) +import Data.Bifunctor (Bifunctor, bimap) +import Data.Functor.Identity (Identity (Identity)) +import Data.Kind (Type) +import Prelude hiding (undefined) -- comonad -import Control.Comonad ( extract ) +import Control.Comonad (extract) -- profunctors import Data.Profunctor (lmap) -- rel8 import Rel8.Aggregate (Aggregator', Aggregator1, toAggregator1) -import Rel8.Expr ( Expr ) +import Rel8.Expr (Expr) import Rel8.Expr.Aggregate (groupByExprOn) -import Rel8.Expr.Serialize ( litExpr ) -import Rel8.Kind.Context ( Reifiable ) -import Rel8.Schema.Context.Nullify ( Nullifiable ) -import Rel8.Schema.Dict ( Dict( Dict ) ) -import Rel8.Schema.HTable.Either ( HEitherTable(..) ) -import Rel8.Schema.HTable.Identity ( HIdentity(..) ) -import Rel8.Schema.HTable.Label ( hlabel, hunlabel ) +import Rel8.Expr.Serialize (litExpr) +import Rel8.Kind.Context (Reifiable) +import Rel8.Schema.Context.Nullify (Nullifiable) +import Rel8.Schema.Dict (Dict (Dict)) +import Rel8.Schema.HTable.Either (HEitherTable (..)) +import Rel8.Schema.HTable.Identity (HIdentity (..)) +import Rel8.Schema.HTable.Label (hlabel, hunlabel) import qualified Rel8.Schema.Kind as K -import Rel8.Schema.Name ( Name ) -import Rel8.Table - ( Table, Columns, Context, fromColumns, toColumns - , FromExprs, fromResult, toResult - , Transpose - ) -import Rel8.Table.Bool ( bool ) -import Rel8.Table.Eq ( EqTable, eqTable ) -import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard ) -import Rel8.Table.Ord ( OrdTable, ordTable ) -import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project ) -import Rel8.Table.Serialize ( ToExprs ) -import Rel8.Table.Undefined ( undefined ) -import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight ) +import Rel8.Schema.Name (Name) +import Rel8.Table ( + Columns, + Context, + FromExprs, + Table, + Transpose, + fromColumns, + fromResult, + toColumns, + toResult, + ) +import Rel8.Table.Bool (bool) +import Rel8.Table.Eq (EqTable, eqTable) +import Rel8.Table.Nullify (Nullify, aggregateNullify, guard) +import Rel8.Table.Ord (OrdTable, ordTable) +import Rel8.Table.Projection (Biprojectable, Projectable, biproject, project) +import Rel8.Table.Serialize (ToExprs) +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, (>>-) ) +import Data.Functor.Apply (Apply, (<.>)) +import Data.Functor.Bind (Bind, (>>-)) --- | An @EitherTable a b@ is a Rel8 table that contains either the table @a@ or --- the table @b@. You can construct an @EitherTable@ using 'leftTable' and --- 'rightTable', and eliminate/pattern match using 'eitherTable'. --- --- An @EitherTable@ is operationally the same as Haskell's 'Either' type, but --- adapted to work with Rel8. +{- | An @EitherTable a b@ is a Rel8 table that contains either the table @a@ or +the table @b@. You can construct an @EitherTable@ using 'leftTable' and +'rightTable', and eliminate/pattern match using 'eitherTable'. + +An @EitherTable@ is operationally the same as Haskell's 'Either' type, but +adapted to work with Rel8. +-} type EitherTable :: K.Context -> Type -> Type -> Type data EitherTable context a b = EitherTable { tag :: context EitherTag , left :: Nullify context a , right :: Nullify context b } - deriving stock Functor + deriving stock (Functor) instance Biprojectable (EitherTable context) where @@ -116,49 +125,61 @@ instance (context ~ Expr, Table Expr a) => Monad (EitherTable context a) where (>>=) = (>>-) -instance (context ~ Expr, Table Expr a, Table Expr b) => +instance + (context ~ Expr, Table Expr a, Table Expr b) => Semigroup (EitherTable context a b) - where + where a <> b = bool a b (isRightTable a) instance - ( Table context a, Table context b - , Reifiable context, context ~ context' - ) - => Table context' (EitherTable context a b) - where + ( Table context a + , Table context b + , Reifiable context + , context ~ context' + ) => + Table context' (EitherTable context a b) + where type Columns (EitherTable context a b) = HEitherTable (Columns a) (Columns b) type Context (EitherTable context a b) = Context a type FromExprs (EitherTable context a b) = Either (FromExprs a) (FromExprs b) - type Transpose to (EitherTable context a b) = - EitherTable to (Transpose to a) (Transpose to b) + type + Transpose to (EitherTable context a b) = + EitherTable to (Transpose to a) (Transpose to b) - toColumns EitherTable {tag, left, right} = HEitherTable - { htag = hlabel $ HIdentity tag - , hleft = hlabel $ guard tag (== IsLeft) isLeft $ toColumns left - , hright = hlabel $ guard tag (== IsRight) isRight $ toColumns right - } - fromColumns HEitherTable {htag, hleft, hright} = EitherTable - { tag = unHIdentity $ hunlabel htag - , left = fromColumns $ hunlabel hleft - , right = fromColumns $ hunlabel hright - } - - toResult = \case - Left table -> HEitherTable - { htag = hlabel (HIdentity (Identity IsLeft)) - , hleft = hlabel (toResult @_ @(Nullify context a) (Just table)) - , hright = hlabel (toResult @_ @(Nullify context b) Nothing) + toColumns EitherTable{tag, left, right} = + HEitherTable + { htag = hlabel $ HIdentity tag + , hleft = hlabel $ guard tag (== IsLeft) isLeft $ toColumns left + , hright = hlabel $ guard tag (== IsRight) isRight $ toColumns right } - Right table -> HEitherTable - { htag = hlabel (HIdentity (Identity IsRight)) - , hleft = hlabel (toResult @_ @(Nullify context a) Nothing) - , hright = hlabel (toResult @_ @(Nullify context b) (Just table)) + + + fromColumns HEitherTable{htag, hleft, hright} = + EitherTable + { tag = unHIdentity $ hunlabel htag + , left = fromColumns $ hunlabel hleft + , right = fromColumns $ hunlabel hright } - fromResult HEitherTable {htag, hleft, hright} = case hunlabel htag of + + toResult = \case + Left table -> + HEitherTable + { htag = hlabel (HIdentity (Identity IsLeft)) + , hleft = hlabel (toResult @_ @(Nullify context a) (Just table)) + , hright = hlabel (toResult @_ @(Nullify context b) Nothing) + } + Right table -> + HEitherTable + { htag = hlabel (HIdentity (Identity IsRight)) + , hleft = hlabel (toResult @_ @(Nullify context a) Nothing) + , hright = hlabel (toResult @_ @(Nullify context b) (Just table)) + } + + + fromResult HEitherTable{htag, hleft, hright} = case hunlabel htag of HIdentity (Identity tag) -> case tag of IsLeft -> maybe err Left $ fromResult @_ @(Nullify context a) (hunlabel hleft) IsRight -> maybe err Right $ fromResult @_ @(Nullify context b) (hunlabel hright) @@ -166,45 +187,55 @@ instance err = error "Either.fromColumns: mismatch between tag and data" -instance (EqTable a, EqTable b, context ~ Expr) => +instance + (EqTable a, EqTable b, context ~ Expr) => EqTable (EitherTable context a b) - where - eqTable = HEitherTable - { htag = hlabel (HIdentity Dict) - , hleft = hlabel (eqTable @(Nullify context a)) - , hright = hlabel (eqTable @(Nullify context b)) - } + where + eqTable = + HEitherTable + { htag = hlabel (HIdentity Dict) + , hleft = hlabel (eqTable @(Nullify context a)) + , hright = hlabel (eqTable @(Nullify context b)) + } -instance (OrdTable a, OrdTable b, context ~ Expr) => +instance + (OrdTable a, OrdTable b, context ~ Expr) => OrdTable (EitherTable context a b) - where - ordTable = HEitherTable - { htag = hlabel (HIdentity Dict) - , hleft = hlabel (ordTable @(Nullify context a)) - , hright = hlabel (ordTable @(Nullify context b)) - } + where + ordTable = + HEitherTable + { htag = hlabel (HIdentity Dict) + , hleft = hlabel (ordTable @(Nullify context a)) + , hright = hlabel (ordTable @(Nullify context b)) + } -instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable Expr exprs1 exprs2) => +instance + (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable Expr exprs1 exprs2) => ToExprs x (Either a b) -- | Test if an 'EitherTable' is a 'leftTable'. isLeftTable :: EitherTable Expr a b -> Expr Bool -isLeftTable EitherTable {tag} = isLeft tag +isLeftTable EitherTable{tag} = isLeft tag -- | Test if an 'EitherTable' is a 'rightTable'. isRightTable :: EitherTable Expr a b -> Expr Bool -isRightTable EitherTable {tag} = isRight tag - - --- | Pattern match/eliminate an 'EitherTable', by providing mappings from a --- 'leftTable' and 'rightTable'. -eitherTable :: Table Expr c - => (a -> c) -> (b -> c) -> EitherTable Expr a b -> c -eitherTable f g EitherTable {tag, left, right} = +isRightTable EitherTable{tag} = isRight tag + + +{- | Pattern match/eliminate an 'EitherTable', by providing mappings from a +'leftTable' and 'rightTable'. +-} +eitherTable :: + Table Expr c => + (a -> c) -> + (b -> c) -> + EitherTable Expr a b -> + c +eitherTable f g EitherTable{tag, left, right} = bool (f (extract left)) (g (extract right)) (isRight tag) @@ -218,12 +249,14 @@ rightTable :: Table Expr a => b -> EitherTable Expr a b rightTable = EitherTable (litExpr IsRight) undefined . pure --- | Lift a pair aggregators to operate on an 'EitherTable'. @leftTable@s and --- @rightTable@s are grouped separately. -aggregateEitherTable :: () - => Aggregator' fold i a - -> Aggregator' fold' i' b - -> Aggregator1 (EitherTable Expr i i') (EitherTable Expr a b) +{- | Lift a pair aggregators to operate on an 'EitherTable'. @leftTable@s and +@rightTable@s are grouped separately. +-} +aggregateEitherTable :: + () => + Aggregator' fold i a -> + Aggregator' fold' i' b -> + Aggregator1 (EitherTable Expr i i') (EitherTable Expr a b) aggregateEitherTable a b = EitherTable <$> groupByExprOn tag @@ -231,16 +264,17 @@ aggregateEitherTable a b = <*> lmap right (toAggregator1 (aggregateNullify b)) --- | Construct a 'EitherTable' in the 'Name' context. This can be useful if you --- have a 'EitherTable' that you are storing in a table and need to construct a --- 'TableSchema'. -nameEitherTable - :: Name EitherTag - -- ^ The name of the column to track whether a row is a 'leftTable' or - -- 'rightTable'. - -> a - -- ^ Names of the columns in the @a@ table. - -> b - -- ^ Names of the columns in the @b@ table. - -> EitherTable Name a b +{- | Construct a 'EitherTable' in the 'Name' context. This can be useful if you +have a 'EitherTable' that you are storing in a table and need to construct a +'TableSchema'. +-} +nameEitherTable :: + -- | The name of the column to track whether a row is a 'leftTable' or + -- 'rightTable'. + Name EitherTag -> + -- | Names of the columns in the @a@ table. + a -> + -- | Names of the columns in the @b@ table. + b -> + EitherTable Name a b nameEitherTable tag left right = EitherTable tag (pure left) (pure right) diff --git a/src/Rel8/Table/Eq.hs b/src/Rel8/Table/Eq.hs index 84a36def..48aeefb8 100644 --- a/src/Rel8/Table/Eq.hs +++ b/src/Rel8/Table/Eq.hs @@ -1,58 +1,60 @@ -{-# language AllowAmbiguousTypes #-} -{-# language BlockArguments #-} -{-# language DataKinds #-} -{-# language DefaultSignatures #-} -{-# language DisambiguateRecordFields #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeApplications #-} -{-# language TypeFamilies #-} -{-# language TypeOperators #-} -{-# language UndecidableInstances #-} -{-# language ViewPatterns #-} - -module Rel8.Table.Eq - ( EqTable( eqTable ), (==:), (/=:) - ) +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +module Rel8.Table.Eq ( + EqTable (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 GHC.Generics ( Rep ) +import Data.Foldable (foldl') +import Data.Functor.Const (Const (Const), getConst) +import Data.Kind (Constraint, Type) +import Data.List.NonEmpty (NonEmpty ((:|))) +import GHC.Generics (Rep) import Prelude -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Expr.Bool ( (||.), (&&.) ) -import Rel8.Expr.Eq ( (==.), (/=.) ) -import Rel8.FCF ( Eval, Exp ) -import Rel8.Generic.Record ( Record ) -import Rel8.Generic.Table.Record ( GTable, GColumns, gtable ) -import Rel8.Schema.Dict ( Dict( Dict ) ) -import Rel8.Schema.HTable ( htabulateA, hfield ) -import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) ) -import Rel8.Schema.Null ( Sql ) -import Rel8.Table ( Table, Columns, toColumns, TColumns ) -import Rel8.Type.Eq ( DBEq ) - - --- | The class of 'Table's that can be compared for equality. Equality on --- tables is defined by equality of all columns all columns, so this class --- means "all columns in a 'Table' have an instance of 'DBEq'". +import Rel8.Expr (Expr) +import Rel8.Expr.Bool ((&&.), (||.)) +import Rel8.Expr.Eq ((/=.), (==.)) +import Rel8.FCF (Eval, Exp) +import Rel8.Generic.Record (Record) +import Rel8.Generic.Table.Record (GColumns, GTable, gtable) +import Rel8.Schema.Dict (Dict (Dict)) +import Rel8.Schema.HTable (hfield, htabulateA) +import Rel8.Schema.HTable.Identity (HIdentity (HIdentity)) +import Rel8.Schema.Null (Sql) +import Rel8.Table (Columns, TColumns, Table, toColumns) +import Rel8.Type.Eq (DBEq) + + +{- | The class of 'Table's that can be compared for equality. Equality on +tables is defined by equality of all columns all columns, so this class +means "all columns in a 'Table' have an instance of 'DBEq'". +-} type EqTable :: Type -> Constraint class Table Expr a => EqTable a where eqTable :: Columns a (Dict (Sql DBEq)) - default eqTable :: ( GTable TEqTable TColumns (Rep (Record a)) , Columns a ~ GColumns TColumns (Rep (Record a)) - ) - => Columns a (Dict (Sql DBEq)) + ) => + Columns a (Dict (Sql DBEq)) eqTable = gtable @TEqTable @TColumns @(Rep (Record a)) table where table (_ :: proxy x) = eqTable @x @@ -75,42 +77,55 @@ instance (EqTable a, EqTable b, EqTable c) => EqTable (a, b, c) instance (EqTable a, EqTable b, EqTable c, EqTable d) => EqTable (a, b, c, d) -instance (EqTable a, EqTable b, EqTable c, EqTable d, EqTable e) => +instance + (EqTable a, EqTable b, EqTable c, EqTable d, EqTable e) => EqTable (a, b, c, d, e) -instance (EqTable a, EqTable b, EqTable c, EqTable d, EqTable e, EqTable f) => +instance + (EqTable a, EqTable b, EqTable c, EqTable d, EqTable e, EqTable f) => EqTable (a, b, c, d, e, f) instance - ( EqTable a, EqTable b, EqTable c, EqTable d, EqTable e, EqTable f + ( EqTable a + , EqTable b + , EqTable c + , EqTable d + , EqTable e + , EqTable f , EqTable g - ) - => EqTable (a, b, c, d, e, f, g) + ) => + EqTable (a, b, c, d, e, f, g) --- | Compare two 'Table's for equality. This corresponds to comparing all --- columns inside each table for equality, and combining all comparisons with --- @AND@. +{- | Compare two 'Table's for equality. This corresponds to comparing all +columns inside each table for equality, and combining all comparisons with +@AND@. +-} (==:) :: forall a. EqTable a => a -> a -> Expr Bool (toColumns -> as) ==: (toColumns -> bs) = foldl1' (&&.) $ getConst $ htabulateA $ \field -> case (hfield as field, hfield bs field) of (a, b) -> case hfield (eqTable @a) field of Dict -> Const (pure (a ==. b)) + + infix 4 ==: --- | Test if two 'Table's are different. This corresponds to comparing all --- columns inside each table for inequality, and combining all comparisons with --- @OR@. +{- | Test if two 'Table's are different. This corresponds to comparing all +columns inside each table for inequality, and combining all comparisons with +@OR@. +-} (/=:) :: forall a. EqTable a => a -> a -> Expr Bool (toColumns -> as) /=: (toColumns -> bs) = foldl1' (||.) $ getConst $ htabulateA $ \field -> case (hfield as field, hfield bs field) of (a, b) -> case hfield (eqTable @a) field of Dict -> Const (pure (a /=. b)) + + infix 4 /=: diff --git a/src/Rel8/Table/HKD.hs b/src/Rel8/Table/HKD.hs index c10500de..9f0d5144 100644 --- a/src/Rel8/Table/HKD.hs +++ b/src/Rel8/Table/HKD.hs @@ -1,73 +1,101 @@ -{-# language AllowAmbiguousTypes #-} -{-# language DataKinds #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language MultiParamTypeClasses #-} -{-# language RankNTypes #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeApplications #-} -{-# language TypeFamilies #-} -{-# language TypeOperators #-} -{-# language UndecidableInstances #-} -{-# language UndecidableSuperClasses #-} - -module Rel8.Table.HKD - ( HKD( HKD ) - , HKDable - , BuildableHKD - , BuildHKD, buildHKD - , ConstructableHKD - , ConstructHKD, constructHKD - , DeconstructHKD, deconstructHKD, deconstructAHKD - , NameHKD, nameHKD - , HKDRep - ) +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module Rel8.Table.HKD ( + HKD (HKD), + HKDable, + BuildableHKD, + BuildHKD, + buildHKD, + ConstructableHKD, + ConstructHKD, + constructHKD, + DeconstructHKD, + deconstructHKD, + deconstructAHKD, + NameHKD, + nameHKD, + HKDRep, +) where -- base -import Data.Kind ( Constraint, Type ) -import GHC.Generics ( Generic, Rep, from, to ) -import GHC.TypeLits ( Symbol ) +import Data.Kind (Constraint, Type) +import GHC.Generics (Generic, Rep, from, to) +import GHC.TypeLits (Symbol) import Prelude -- rel8 -import Rel8.Column ( TColumn ) -import Rel8.Expr ( Expr ) -import Rel8.FCF ( Eval, Exp ) -import Rel8.Kind.Algebra ( KnownAlgebra ) -import Rel8.Generic.Construction - ( GGBuildable - , GGBuild, ggbuild - , GGConstructable - , GGConstruct, ggconstruct - , GGDeconstruct, ggdeconstruct, ggdeconstructA - , GGName, ggname - ) -import Rel8.Generic.Map ( GMap ) -import Rel8.Generic.Record - ( GRecord, GRecordable, grecord, gunrecord - , Record( Record ), unrecord - ) -import Rel8.Generic.Rel8able - ( Rel8able - , GColumns, gfromColumns, gtoColumns - , GFromExprs, gfromResult, gtoResult - ) -import Rel8.Generic.Table - ( GGSerialize, GGColumns, GAlgebra, ggfromResult, ggtoResult - ) -import Rel8.Generic.Table.Record ( GTable, GContext ) +import Rel8.Column (TColumn) +import Rel8.Expr (Expr) +import Rel8.FCF (Eval, Exp) +import Rel8.Generic.Construction ( + GGBuild, + GGBuildable, + GGConstruct, + GGConstructable, + GGDeconstruct, + GGName, + ggbuild, + ggconstruct, + ggdeconstruct, + ggdeconstructA, + ggname, + ) +import Rel8.Generic.Map (GMap) +import Rel8.Generic.Record ( + GRecord, + GRecordable, + Record (Record), + grecord, + gunrecord, + unrecord, + ) +import Rel8.Generic.Rel8able ( + GColumns, + GFromExprs, + Rel8able, + gfromColumns, + gfromResult, + gtoColumns, + gtoResult, + ) +import Rel8.Generic.Table ( + GAlgebra, + GGColumns, + GGSerialize, + ggfromResult, + ggtoResult, + ) +import Rel8.Generic.Table.Record (GContext, GTable) import qualified Rel8.Generic.Table.Record as G +import Rel8.Kind.Algebra (KnownAlgebra) +import Rel8.Schema.HTable (HTable) import qualified Rel8.Schema.Kind as K -import Rel8.Schema.HTable ( HTable ) -import Rel8.Schema.Name ( Name ) -import Rel8.Schema.Result ( Result ) -import Rel8.Table - ( Table, fromColumns, toColumns, fromResult, toResult - , TTable, TColumns, TContext - , TSerialize - ) +import Rel8.Schema.Name (Name) +import Rel8.Schema.Result (Result) +import Rel8.Table ( + TColumns, + TContext, + TSerialize, + TTable, + Table, + fromColumns, + fromResult, + toColumns, + toResult, + ) -- semigroupoids import Data.Functor.Apply (Apply) @@ -86,19 +114,22 @@ instance HKDable a => Rel8able (HKD a) where type GColumns (HKD a) = GColumnsHKD a type GFromExprs (HKD a) = a + gfromColumns _ = HKD gtoColumns _ (HKD a) = a + gfromResult = - unrecord . - to . - ggfromResult - @(GAlgebra (Rep a)) - @TSerialize - @TColumns - @(Eval (HKDRep a Expr)) - @(Eval (HKDRep a Result)) - (\(_ :: proxy x) -> fromResult @_ @x) + unrecord + . to + . ggfromResult + @(GAlgebra (Rep a)) + @TSerialize + @TColumns + @(Eval (HKDRep a Expr)) + @(Eval (HKDRep a Result)) + (\(_ :: proxy x) -> fromResult @_ @x) + gtoResult = ggtoResult @@ -107,9 +138,9 @@ instance HKDable a => Rel8able (HKD a) where @TColumns @(Eval (HKDRep a Expr)) @(Eval (HKDRep a Result)) - (\(_ :: proxy x) -> toResult @_ @x) . - from . - Record + (\(_ :: proxy x) -> toResult @_ @x) + . from + . Record instance @@ -117,26 +148,28 @@ instance , G.GColumns TColumns (GRecord (GMap (TColumn f) (Rep a))) ~ GColumnsHKD a , GContext TContext (GRecord (GMap (TColumn f) (Rep a))) ~ f , GRecordable (GMap (TColumn f) (Rep a)) - ) - => Generic (HKD a f) - where + ) => + Generic (HKD a f) + where type Rep (HKD a f) = GMap (TColumn f) (Rep a) + from = - gunrecord @(GMap (TColumn f) (Rep a)) . - G.gfromColumns - @(TTable f) - @TColumns - fromColumns . - (\(HKD a) -> a) + gunrecord @(GMap (TColumn f) (Rep a)) + . G.gfromColumns + @(TTable f) + @TColumns + fromColumns + . (\(HKD a) -> a) + to = - HKD . - G.gtoColumns - @(TTable f) - @TColumns - toColumns . - grecord @(GMap (TColumn f) (Rep a)) + HKD + . G.gtoColumns + @(TTable f) + @TColumns + toColumns + . grecord @(GMap (TColumn f) (Rep a)) type HKDable :: Type -> Constraint @@ -146,16 +179,16 @@ class , KnownAlgebra (GAlgebra (Rep a)) , Eval (GGSerialize (GAlgebra (Rep a)) TSerialize TColumns (Eval (HKDRep a Expr)) (Eval (HKDRep a Result))) , GRecord (GMap (TColumn Result) (Rep a)) ~ Rep (Record a) - ) - => HKDable a + ) => + HKDable a instance ( Generic (Record a) , HTable (GColumns (HKD a)) , KnownAlgebra (GAlgebra (Rep a)) , Eval (GGSerialize (GAlgebra (Rep a)) TSerialize TColumns (Eval (HKDRep a Expr)) (Eval (HKDRep a Result))) , GRecord (GMap (TColumn Result) (Rep a)) ~ Rep (Record a) - ) - => HKDable a + ) => + HKDable a type Top_ :: Constraint @@ -192,7 +225,8 @@ type ConstructHKD a = forall r. GGConstruct (GAlgebra (Rep a)) (HKDRep a) r constructHKD :: forall a. ConstructableHKD a => ConstructHKD a -> HKD a Expr constructHKD f = - ggconstruct @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Expr) HKD + ggconstruct @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Expr) + HKD (f @(HKD a Expr)) @@ -200,13 +234,17 @@ type DeconstructHKD :: Type -> Type -> Type type DeconstructHKD a r = GGDeconstruct (GAlgebra (Rep a)) (HKDRep a) (HKD a Expr) r -deconstructHKD :: forall a r. (ConstructableHKD a, Table Expr r) - => DeconstructHKD a r +deconstructHKD :: + forall a r. + (ConstructableHKD a, Table Expr r) => + DeconstructHKD a r deconstructHKD = ggdeconstruct @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Expr) @r (\(HKD a) -> a) -deconstructAHKD :: forall a f r. (ConstructableHKD a, Apply f, Table Expr r) - => DeconstructHKD a (f r) +deconstructAHKD :: + forall a f r. + (ConstructableHKD a, Apply f, Table Expr r) => + DeconstructHKD a (f r) deconstructAHKD = ggdeconstructA @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Expr) @f @r (\(HKD a) -> a) @@ -219,5 +257,6 @@ nameHKD = ggname @(GAlgebra (Rep a)) @(HKDRep a) @(HKD a Name) HKD data HKDRep :: Type -> K.Context -> Exp (Type -> Type) -type instance Eval (HKDRep a context) = - GRecord (GMap (TColumn context) (Rep a)) +type instance + Eval (HKDRep a context) = + GRecord (GMap (TColumn context) (Rep a)) diff --git a/src/Rel8/Table/List.hs b/src/Rel8/Table/List.hs index 369f4693..e535be86 100644 --- a/src/Rel8/Table/List.hs +++ b/src/Rel8/Table/List.hs @@ -1,84 +1,102 @@ -{-# language DataKinds #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language MultiParamTypeClasses #-} -{-# language NamedFieldPuns #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeApplications #-} -{-# language TypeFamilies #-} -{-# language TypeOperators #-} -{-# language UndecidableInstances #-} - -module Rel8.Table.List - ( ListTable(..) - , ($*) - , listTable - , nameListTable - , head - , last - ) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Rel8.Table.List ( + ListTable (..), + ($*), + listTable, + nameListTable, + head, + last, +) where -- base import Data.Functor.Identity (Identity (Identity)) -import Data.Kind ( Type ) +import Data.Kind (Type) import Prelude hiding (head, last) -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Expr.Array ( sappend, sempty, slistOf ) +import Rel8.Expr (Expr) +import Rel8.Expr.Array (sappend, sempty, slistOf) import Rel8.Expr.List (headExpr, lastExpr) -import Rel8.Schema.Dict ( Dict( Dict ) ) -import Rel8.Schema.HTable.List ( HListTable ) -import Rel8.Schema.HTable.Vectorize - ( hvectorize, hunvectorize - , hnullify - , happend, hempty - , hproject, hcolumn - ) +import Rel8.Schema.Dict (Dict (Dict)) +import Rel8.Schema.HTable.List (HListTable) +import Rel8.Schema.HTable.Vectorize ( + happend, + hcolumn, + hempty, + hnullify, + hproject, + hunvectorize, + hvectorize, + ) import qualified Rel8.Schema.Kind as K -import Rel8.Schema.Name ( Name( Name ) ) -import Rel8.Schema.Null ( Nullity( Null, NotNull ) ) -import Rel8.Schema.Result ( vectorizer, unvectorizer ) -import Rel8.Schema.Spec ( Spec(..) ) -import Rel8.Table - ( Table, Context, Columns, fromColumns, toColumns - , FromExprs, fromResult, toResult - , Transpose - ) -import Rel8.Table.Alternative - ( AltTable, (<|>:) - , AlternativeTable, emptyTable - ) -import Rel8.Table.Eq ( EqTable, eqTable ) +import Rel8.Schema.Name (Name (Name)) +import Rel8.Schema.Null (Nullity (NotNull, Null)) +import Rel8.Schema.Result (unvectorizer, vectorizer) +import Rel8.Schema.Spec (Spec (..)) +import Rel8.Table ( + Columns, + Context, + FromExprs, + Table, + Transpose, + fromColumns, + fromResult, + toColumns, + toResult, + ) +import Rel8.Table.Alternative ( + AltTable, + AlternativeTable, + emptyTable, + (<|>:), + ) +import Rel8.Table.Eq (EqTable, eqTable) import Rel8.Table.Null (NullTable) -import Rel8.Table.Ord ( OrdTable, ordTable ) -import Rel8.Table.Projection - ( Projectable, Projecting, Projection, project, apply - ) -import Rel8.Table.Serialize ( ToExprs ) - - --- | A @ListTable@ value contains zero or more instances of @a@. You construct --- @ListTable@s with 'Rel8.many' or 'Rel8.listAgg'. +import Rel8.Table.Ord (OrdTable, ordTable) +import Rel8.Table.Projection ( + Projectable, + Projecting, + Projection, + apply, + project, + ) +import Rel8.Table.Serialize (ToExprs) + + +{- | A @ListTable@ value contains zero or more instances of @a@. You construct +@ListTable@s with 'Rel8.many' or 'Rel8.listAgg'. +-} type ListTable :: K.Context -> Type -> Type -newtype ListTable context a = - ListTable (HListTable (Columns a) (Context a)) +newtype ListTable context a + = ListTable (HListTable (Columns a) (Context a)) instance Projectable (ListTable context) where project f (ListTable a) = ListTable (hproject (apply f) a) -instance (Table context a, context ~ context') => +instance + (Table context a, context ~ context') => Table context' (ListTable context a) - where + where type Columns (ListTable context a) = HListTable (Columns a) type Context (ListTable context a) = Context a type FromExprs (ListTable context a) = [FromExprs a] type Transpose to (ListTable context a) = ListTable to (Transpose to a) + fromColumns = ListTable toColumns (ListTable a) = a fromResult = fmap (fromResult @_ @a) . hunvectorize unvectorizer @@ -88,22 +106,25 @@ instance (Table context a, context ~ context') => instance (EqTable a, context ~ Expr) => EqTable (ListTable context a) where eqTable = hvectorize - (\Spec {nullity} (Identity Dict) -> case nullity of - Null -> Dict - NotNull -> Dict) + ( \Spec{nullity} (Identity Dict) -> case nullity of + Null -> Dict + NotNull -> Dict + ) (Identity (eqTable @a)) instance (OrdTable a, context ~ Expr) => OrdTable (ListTable context a) where ordTable = hvectorize - (\Spec {nullity} (Identity Dict) -> case nullity of - Null -> Dict - NotNull -> Dict) + ( \Spec{nullity} (Identity Dict) -> case nullity of + Null -> Dict + NotNull -> Dict + ) (Identity (ordTable @a)) -instance (ToExprs exprs a, context ~ Expr) => +instance + (ToExprs exprs a, context ~ Expr) => ToExprs (ListTable context exprs) [a] @@ -115,57 +136,64 @@ instance context ~ Expr => AlternativeTable (ListTable context) where emptyTable = mempty -instance (context ~ Expr, Table Expr a) => Semigroup (ListTable context a) - where +instance (context ~ Expr, Table Expr a) => Semigroup (ListTable context a) where ListTable as <> ListTable bs = ListTable $ happend (const sappend) as bs -instance (context ~ Expr, Table Expr a) => +instance + (context ~ Expr, Table Expr a) => Monoid (ListTable context a) - where - mempty = ListTable $ hempty $ \Spec {info} -> sempty info + where + mempty = ListTable $ hempty $ \Spec{info} -> sempty info -- | Project a single expression out of a 'ListTable'. -($*) :: Projecting a (Expr b) - => Projection a (Expr b) -> ListTable Expr a -> Expr [b] +($*) :: + Projecting a (Expr b) => + Projection a (Expr b) -> + ListTable Expr a -> + Expr [b] f $* ListTable a = hcolumn $ hproject (apply f) a + + infixl 4 $* -- | Construct a @ListTable@ from a list of expressions. listTable :: Table Expr a => [a] -> ListTable Expr a listTable = - ListTable . - hvectorize (\Spec {info} -> slistOf info) . - fmap toColumns - - --- | Construct a 'ListTable' in the 'Name' context. This can be useful if you --- have a 'ListTable' that you are storing in a table and need to construct a --- 'TableSchema'. -nameListTable - :: Table Name a - => a -- ^ The names of the columns of elements of the list. - -> ListTable Name a + ListTable + . hvectorize (\Spec{info} -> slistOf info) + . fmap toColumns + + +{- | Construct a 'ListTable' in the 'Name' context. This can be useful if you +have a 'ListTable' that you are storing in a table and need to construct a +'TableSchema'. +-} +nameListTable :: + Table Name a => + -- | The names of the columns of elements of the list. + a -> + ListTable Name a nameListTable = - ListTable . - hvectorize (\_ (Identity (Name a)) -> Name a) . - pure . - toColumns + ListTable + . hvectorize (\_ (Identity (Name a)) -> Name a) + . pure + . toColumns -- | Get the first element of a 'ListTable' (or 'Rel8.nullTable' if empty). head :: Table Expr a => ListTable Expr a -> NullTable Expr a head = - fromColumns . - hnullify (const headExpr) . - toColumns + fromColumns + . hnullify (const headExpr) + . toColumns -- | Get the last element of a 'ListTable' (or 'Rel8.nullTable' if empty). last :: Table Expr a => ListTable Expr a -> NullTable Expr a last = - fromColumns . - hnullify (const lastExpr) . - toColumns + fromColumns + . hnullify (const lastExpr) + . toColumns diff --git a/src/Rel8/Table/Maybe.hs b/src/Rel8/Table/Maybe.hs index 90f6e862..775fe814 100644 --- a/src/Rel8/Table/Maybe.hs +++ b/src/Rel8/Table/Maybe.hs @@ -1,38 +1,41 @@ -{-# language DataKinds #-} -{-# language DeriveFunctor #-} -{-# language DerivingStrategies #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language MultiParamTypeClasses #-} -{-# language NamedFieldPuns #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeApplications #-} -{-# language TypeFamilies #-} -{-# language TypeOperators #-} -{-# language UndecidableInstances #-} - -module Rel8.Table.Maybe - ( MaybeTable(..) - , maybeTable, nothingTable, justTable - , isNothingTable, isJustTable - , fromMaybeTable - , ($?) - , aggregateMaybeTable - , nameMaybeTable - , makeMaybeTable - ) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Rel8.Table.Maybe ( + MaybeTable (..), + maybeTable, + nothingTable, + justTable, + isNothingTable, + isJustTable, + fromMaybeTable, + ($?), + aggregateMaybeTable, + nameMaybeTable, + makeMaybeTable, +) where -- base -import Data.Functor ( ($>) ) -import Data.Functor.Identity ( Identity( Identity ) ) -import Data.Kind ( Type ) -import Data.Maybe ( fromMaybe, isJust ) -import Prelude hiding ( null, undefined ) +import Data.Functor (($>)) +import Data.Functor.Identity (Identity (Identity)) +import Data.Kind (Type) +import Data.Maybe (fromMaybe, isJust) +import Prelude hiding (null, undefined) -- comonad -import Control.Comonad ( extract ) +import Control.Comonad (extract) -- opaleye import qualified Opaleye.Field as Opaleye @@ -43,58 +46,67 @@ import Data.Profunctor (lmap) -- rel8 import Rel8.Aggregate (Aggregator', Aggregator1, toAggregator1) -import Rel8.Expr ( Expr ) +import Rel8.Expr (Expr) import Rel8.Expr.Aggregate (groupByExprOn) -import Rel8.Expr.Bool ( boolExpr ) -import Rel8.Expr.Null ( isNull, isNonNull, null, nullify ) +import Rel8.Expr.Bool (boolExpr) +import Rel8.Expr.Null (isNonNull, isNull, null, nullify) import Rel8.Expr.Opaleye (fromColumn, fromPrimExpr) -import Rel8.Kind.Context ( Reifiable ) -import Rel8.Schema.Dict ( Dict( Dict ) ) +import Rel8.Kind.Context (Reifiable) +import Rel8.Schema.Dict (Dict (Dict)) +import Rel8.Schema.HTable.Identity (HIdentity (..)) +import Rel8.Schema.HTable.Label (hlabel, hunlabel) +import Rel8.Schema.HTable.Maybe (HMaybeTable (..)) import qualified Rel8.Schema.Kind as K -import Rel8.Schema.HTable.Identity ( HIdentity(..) ) -import Rel8.Schema.HTable.Label ( hlabel, hunlabel ) -import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) ) -import Rel8.Schema.Name ( Name ) -import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable ) +import Rel8.Schema.Name (Name) +import Rel8.Schema.Null (Nullity (NotNull, Null), Sql, nullable) import qualified Rel8.Schema.Null as N -import Rel8.Table - ( Table, Columns, Context, fromColumns, toColumns - , FromExprs, fromResult, toResult - , Transpose - ) -import Rel8.Table.Alternative - ( AltTable, (<|>:) - , AlternativeTable, emptyTable - ) -import Rel8.Table.Bool ( bool ) -import Rel8.Table.Eq ( EqTable, eqTable ) -import Rel8.Table.Ord ( OrdTable, ordTable ) -import Rel8.Table.Projection ( Projectable, project ) -import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard ) -import Rel8.Table.Serialize ( ToExprs ) -import Rel8.Table.Undefined ( undefined ) -import Rel8.Type ( DBType ) -import Rel8.Type.Tag ( MaybeTag( IsJust ) ) +import Rel8.Table ( + Columns, + Context, + FromExprs, + Table, + Transpose, + fromColumns, + fromResult, + toColumns, + toResult, + ) +import Rel8.Table.Alternative ( + AltTable, + AlternativeTable, + emptyTable, + (<|>:), + ) +import Rel8.Table.Bool (bool) +import Rel8.Table.Eq (EqTable, eqTable) +import Rel8.Table.Nullify (Nullify, aggregateNullify, guard) +import Rel8.Table.Ord (OrdTable, ordTable) +import Rel8.Table.Projection (Projectable, project) +import Rel8.Table.Serialize (ToExprs) +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, (>>-) ) - - --- | @MaybeTable t@ is the table @t@, but as the result of an outer join. If --- the outer join fails to match any rows, this is essentialy @Nothing@, and if --- the outer join does match rows, this is like @Just@. Unfortunately, SQL --- makes it impossible to distinguish whether or not an outer join matched any --- rows based generally on the row contents - if you were to join a row --- entirely of nulls, you can't distinguish if you matched an all null row, or --- if the match failed. For this reason @MaybeTable@ contains an extra field - --- a "nullTag" - to track whether or not the outer join produced any rows. +import Data.Functor.Apply (Apply, (<.>)) +import Data.Functor.Bind (Bind, (>>-)) + + +{- | @MaybeTable t@ is the table @t@, but as the result of an outer join. If +the outer join fails to match any rows, this is essentialy @Nothing@, and if +the outer join does match rows, this is like @Just@. Unfortunately, SQL +makes it impossible to distinguish whether or not an outer join matched any +rows based generally on the row contents - if you were to join a row +entirely of nulls, you can't distinguish if you matched an all null row, or +if the match failed. For this reason @MaybeTable@ contains an extra field - +a "nullTag" - to track whether or not the outer join produced any rows. +-} type MaybeTable :: K.Context -> Type -> Type data MaybeTable context a = MaybeTable { tag :: context (Maybe MaybeTag) , just :: Nullify context a } - deriving stock Functor + deriving stock (Functor) instance Projectable (MaybeTable context) where @@ -105,8 +117,9 @@ instance context ~ Expr => Apply (MaybeTable context) where MaybeTable tag f <.> MaybeTable tag' a = MaybeTable (tag <> tag') (f <.> a) --- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also: --- 'Rel8.traverseMaybeTable'. +{- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also: +'Rel8.traverseMaybeTable'. +-} instance context ~ Expr => Applicative (MaybeTable context) where (<*>) = (<.>) pure = justTable @@ -130,63 +143,77 @@ instance context ~ Expr => AlternativeTable (MaybeTable context) where emptyTable = nothingTable -instance (context ~ Expr, Table Expr a, Semigroup a) => +instance + (context ~ Expr, Table Expr a, Semigroup a) => Semigroup (MaybeTable context a) - where + where ma <> mb = maybeTable mb (\a -> maybeTable ma (justTable . (a <>)) mb) ma -instance (context ~ Expr, Table Expr a, Semigroup a) => +instance + (context ~ Expr, Table Expr a, Semigroup a) => Monoid (MaybeTable context a) - where + where mempty = nothingTable -instance (Table context a, Reifiable context, context ~ context') => +instance + (Table context a, Reifiable context, context ~ context') => Table context' (MaybeTable context a) - where + where type Columns (MaybeTable context a) = HMaybeTable (Columns a) type Context (MaybeTable context a) = Context a type FromExprs (MaybeTable context a) = Maybe (FromExprs a) type Transpose to (MaybeTable context a) = MaybeTable to (Transpose to a) - toColumns MaybeTable {tag, just} = HMaybeTable - { htag = hlabel $ HIdentity tag - , hjust = hlabel $ guard tag isJust isNonNull $ toColumns just - } - fromColumns HMaybeTable {htag, hjust} = MaybeTable - { tag = unHIdentity $ hunlabel htag - , just = fromColumns $ hunlabel hjust - } + toColumns MaybeTable{tag, just} = + HMaybeTable + { htag = hlabel $ HIdentity tag + , hjust = hlabel $ guard tag isJust isNonNull $ toColumns just + } + + + fromColumns HMaybeTable{htag, hjust} = + MaybeTable + { tag = unHIdentity $ hunlabel htag + , just = fromColumns $ hunlabel hjust + } + + + toResult ma = + HMaybeTable + { htag = hlabel (HIdentity (Identity (IsJust <$ ma))) + , hjust = hlabel (toResult @_ @(Nullify context a) ma) + } - toResult ma = HMaybeTable - { htag = hlabel (HIdentity (Identity (IsJust <$ ma))) - , hjust = hlabel (toResult @_ @(Nullify context a) ma) - } - fromResult HMaybeTable {htag, hjust} = case hunlabel htag of - HIdentity (Identity tag) -> tag $> - fromMaybe err (fromResult @_ @(Nullify context a) (hunlabel hjust)) + fromResult HMaybeTable{htag, hjust} = case hunlabel htag of + HIdentity (Identity tag) -> + tag + $> fromMaybe err (fromResult @_ @(Nullify context a) (hunlabel hjust)) where err = error "Maybe.fromColumns: mismatch between tag and data" instance (EqTable a, context ~ Expr) => EqTable (MaybeTable context a) where - eqTable = HMaybeTable - { htag = hlabel (HIdentity Dict) - , hjust = hlabel (eqTable @(Nullify context a)) - } + eqTable = + HMaybeTable + { htag = hlabel (HIdentity Dict) + , hjust = hlabel (eqTable @(Nullify context a)) + } instance (OrdTable a, context ~ Expr) => OrdTable (MaybeTable context a) where - ordTable = HMaybeTable - { htag = hlabel (HIdentity Dict) - , hjust = hlabel (ordTable @(Nullify context a)) - } + ordTable = + HMaybeTable + { htag = hlabel (HIdentity Dict) + , hjust = hlabel (ordTable @(Nullify context a)) + } -instance (ToExprs exprs a, context ~ Expr) => +instance + (ToExprs exprs a, context ~ Expr) => ToExprs (MaybeTable context exprs) (Maybe a) @@ -203,7 +230,7 @@ isJustTable (MaybeTable tag _) = isNonNull tag -- | Perform case analysis on a 'MaybeTable'. Like 'maybe'. maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable Expr a -> b maybeTable b f ma@(MaybeTable _ a) = bool (f (extract a)) b (isNothingTable ma) -{-# INLINABLE maybeTable #-} +{-# INLINEABLE maybeTable #-} -- | The null table. Like 'Nothing'. @@ -211,8 +238,9 @@ nothingTable :: Table Expr a => MaybeTable Expr a nothingTable = MaybeTable null (pure undefined) --- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use --- 'pure'. +{- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use +'pure'. +-} justTable :: a -> MaybeTable Expr a justTable = MaybeTable mempty . pure @@ -222,43 +250,54 @@ fromMaybeTable :: Table Expr a => a -> MaybeTable Expr a -> a fromMaybeTable fallback = maybeTable fallback id --- | Project a single expression out of a 'MaybeTable'. You can think of this --- operator like the '$' operator, but it also has the ability to return --- @null@. -($?) :: forall a b. Sql DBType b - => (a -> Expr b) -> MaybeTable Expr a -> Expr (N.Nullify b) +{- | Project a single expression out of a 'MaybeTable'. You can think of this +operator like the '$' operator, but it also has the ability to return +@null@. +-} +($?) :: + forall a b. + Sql DBType b => + (a -> Expr b) -> + MaybeTable Expr a -> + Expr (N.Nullify b) f $? ma@(MaybeTable _ a) = case nullable @b of Null -> boolExpr (f (extract a)) null (isNothingTable ma) NotNull -> boolExpr (nullify (f (extract a))) null (isNothingTable ma) + + infixl 4 $? --- | Lift an aggregator to operate on a 'MaybeTable'. @nothingTable@s and --- @justTable@s are grouped separately. -aggregateMaybeTable :: () - => Aggregator' fold i a - -> Aggregator1 (MaybeTable Expr i) (MaybeTable Expr a) +{- | Lift an aggregator to operate on a 'MaybeTable'. @nothingTable@s and +@justTable@s are grouped separately. +-} +aggregateMaybeTable :: + () => + Aggregator' fold i a -> + Aggregator1 (MaybeTable Expr i) (MaybeTable Expr a) aggregateMaybeTable aggregator = MaybeTable <$> groupByExprOn tag <*> lmap just (toAggregator1 (aggregateNullify aggregator)) --- | Construct a 'MaybeTable' in the 'Name' context. This can be useful if you --- have a 'MaybeTable' that you are storing in a table and need to construct a --- 'TableSchema'. -nameMaybeTable - :: Name (Maybe MaybeTag) - -- ^ The name of the column to track whether a row is a 'justTable' or - -- 'nothingTable'. - -> a - -- ^ Names of the columns in @a@. - -> MaybeTable Name a +{- | Construct a 'MaybeTable' in the 'Name' context. This can be useful if you +have a 'MaybeTable' that you are storing in a table and need to construct a +'TableSchema'. +-} +nameMaybeTable :: + -- | The name of the column to track whether a row is a 'justTable' or + -- 'nothingTable'. + Name (Maybe MaybeTag) -> + -- | Names of the columns in @a@. + a -> + MaybeTable Name a nameMaybeTable tag = MaybeTable tag . pure makeMaybeTable :: Opaleye.FieldNullable Opaleye.SqlBool -> a -> MaybeTable Expr a -makeMaybeTable tag a = MaybeTable - { tag = fromPrimExpr $ fromColumn tag - , just = pure a - } +makeMaybeTable tag a = + MaybeTable + { tag = fromPrimExpr $ fromColumn tag + , just = pure a + } diff --git a/src/Rel8/Table/Name.hs b/src/Rel8/Table/Name.hs index 51c35382..12103cd7 100644 --- a/src/Rel8/Table/Name.hs +++ b/src/Rel8/Table/Name.hs @@ -1,72 +1,76 @@ -{-# language DataKinds #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language MultiParamTypeClasses #-} -{-# language NamedFieldPuns #-} -{-# language ScopedTypeVariables #-} -{-# language TypeApplications #-} -{-# language TypeFamilies #-} -{-# language UndecidableInstances #-} -{-# language ViewPatterns #-} - -module Rel8.Table.Name - ( namesFromLabels - , namesFromLabelsWith - , showLabels - , showNames - ) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# 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, nonEmpty ) -import Data.Maybe ( fromMaybe ) +import Data.Foldable (fold) +import Data.Functor.Const (Const (Const), getConst) +import Data.List.NonEmpty (NonEmpty, intersperse, nonEmpty) +import Data.Maybe (fromMaybe) import Prelude -- rel8 -import Rel8.Schema.HTable ( htabulate, htabulateA, hfield, hspecs ) -import Rel8.Schema.Name ( Name( Name ) ) -import Rel8.Schema.Spec ( Spec(..) ) -import Rel8.Table ( Table(..) ) +import Rel8.Schema.HTable (hfield, hspecs, htabulate, htabulateA) +import Rel8.Schema.Name (Name (Name)) +import Rel8.Schema.Spec (Spec (..)) +import Rel8.Table (Table (..)) + +{- | Construct a table in the 'Name' context containing the names of all +columns. Nested column names will be combined with @/@. --- | Construct a table in the 'Name' context containing the names of all --- columns. Nested column names will be combined with @/@. --- --- See also: 'namesFromLabelsWith'. +See also: 'namesFromLabelsWith'. +-} namesFromLabels :: Table Name a => a namesFromLabels = namesFromLabelsWith go where go = fold . intersperse "/" --- | Construct a table in the 'Name' context containing the names of all --- columns. The supplied function can be used to transform column names. --- --- This function can be used to generically derive the columns for a --- 'TableSchema'. For example, --- --- @ --- myTableSchema :: TableSchema (MyTable Name) --- myTableSchema = TableSchema --- { columns = namesFromLabelsWith last --- } --- @ --- --- will construct a 'TableSchema' where each columns names exactly corresponds --- to the name of the Haskell field. -namesFromLabelsWith :: Table Name a - => (NonEmpty String -> String) -> a +{- | Construct a table in the 'Name' context containing the names of all +columns. The supplied function can be used to transform column names. + +This function can be used to generically derive the columns for a +'TableSchema'. For example, + +@ +myTableSchema :: TableSchema (MyTable Name) +myTableSchema = TableSchema + { columns = namesFromLabelsWith last + } +@ + +will construct a 'TableSchema' where each columns names exactly corresponds +to the name of the Haskell field. +-} +namesFromLabelsWith :: + Table Name a => + (NonEmpty String -> String) -> + a namesFromLabelsWith f = fromColumns $ htabulate $ \field -> case hfield hspecs field of - Spec {labels} -> Name (f (renderLabels labels)) + Spec{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 - Spec {labels} -> Const (pure (renderLabels labels)) + Spec{labels} -> Const (pure (renderLabels labels)) showNames :: forall a. Table Name a => a -> NonEmpty String @@ -76,4 +80,4 @@ showNames (toColumns -> names) = getConst $ renderLabels :: [String] -> NonEmpty String -renderLabels labels = fromMaybe (pure "anon") (nonEmpty labels ) +renderLabels labels = fromMaybe (pure "anon") (nonEmpty labels) diff --git a/src/Rel8/Table/NonEmpty.hs b/src/Rel8/Table/NonEmpty.hs index 4100ee72..7ccd0a59 100644 --- a/src/Rel8/Table/NonEmpty.hs +++ b/src/Rel8/Table/NonEmpty.hs @@ -1,80 +1,96 @@ -{-# language DataKinds #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language MultiParamTypeClasses #-} -{-# language NamedFieldPuns #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeApplications #-} -{-# language TypeFamilies #-} -{-# language TypeOperators #-} -{-# language UndecidableInstances #-} - -module Rel8.Table.NonEmpty - ( NonEmptyTable(..) - , ($+) - , nonEmptyTable - , nameNonEmptyTable - , head1 - , last1 - ) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Rel8.Table.NonEmpty ( + NonEmptyTable (..), + ($+), + nonEmptyTable, + nameNonEmptyTable, + head1, + last1, +) where -- base import Data.Functor.Identity (Identity (Identity), runIdentity) -import Data.Kind ( Type ) -import Data.List.NonEmpty ( NonEmpty ) -import Prelude hiding ( id ) +import Data.Kind (Type) +import Data.List.NonEmpty (NonEmpty) +import Prelude hiding (id) -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Expr.Array ( sappend1, snonEmptyOf ) +import Rel8.Expr (Expr) +import Rel8.Expr.Array (sappend1, snonEmptyOf) import Rel8.Expr.NonEmpty (head1Expr, last1Expr) -import Rel8.Schema.Dict ( Dict( Dict ) ) -import Rel8.Schema.HTable.NonEmpty ( HNonEmptyTable ) -import Rel8.Schema.HTable.Vectorize - ( hvectorize, hunvectorize - , happend - , hproject, hcolumn - ) +import Rel8.Schema.Dict (Dict (Dict)) +import Rel8.Schema.HTable.NonEmpty (HNonEmptyTable) +import Rel8.Schema.HTable.Vectorize ( + happend, + hcolumn, + hproject, + hunvectorize, + hvectorize, + ) import qualified Rel8.Schema.Kind as K -import Rel8.Schema.Name ( Name( Name ) ) -import Rel8.Schema.Null ( Nullity( Null, NotNull ) ) -import Rel8.Schema.Result ( vectorizer, unvectorizer ) -import Rel8.Schema.Spec ( Spec(..) ) -import Rel8.Table - ( Table, Context, Columns, fromColumns, toColumns - , FromExprs, fromResult, toResult - , Transpose - ) -import Rel8.Table.Alternative ( AltTable, (<|>:) ) -import Rel8.Table.Eq ( EqTable, eqTable ) -import Rel8.Table.Ord ( OrdTable, ordTable ) -import Rel8.Table.Projection - ( Projectable, Projecting, Projection, project, apply - ) -import Rel8.Table.Serialize ( ToExprs ) - - --- | A @NonEmptyTable@ value contains one or more instances of @a@. You --- construct @NonEmptyTable@s with 'Rel8.some' or 'nonEmptyAgg'. +import Rel8.Schema.Name (Name (Name)) +import Rel8.Schema.Null (Nullity (NotNull, Null)) +import Rel8.Schema.Result (unvectorizer, vectorizer) +import Rel8.Schema.Spec (Spec (..)) +import Rel8.Table ( + Columns, + Context, + FromExprs, + Table, + Transpose, + fromColumns, + fromResult, + toColumns, + toResult, + ) +import Rel8.Table.Alternative (AltTable, (<|>:)) +import Rel8.Table.Eq (EqTable, eqTable) +import Rel8.Table.Ord (OrdTable, ordTable) +import Rel8.Table.Projection ( + Projectable, + Projecting, + Projection, + apply, + project, + ) +import Rel8.Table.Serialize (ToExprs) + + +{- | A @NonEmptyTable@ value contains one or more instances of @a@. You +construct @NonEmptyTable@s with 'Rel8.some' or 'nonEmptyAgg'. +-} type NonEmptyTable :: K.Context -> Type -> Type -newtype NonEmptyTable context a = - NonEmptyTable (HNonEmptyTable (Columns a) (Context a)) +newtype NonEmptyTable context a + = NonEmptyTable (HNonEmptyTable (Columns a) (Context a)) instance Projectable (NonEmptyTable context) where project f (NonEmptyTable a) = NonEmptyTable (hproject (apply f) a) -instance (Table context a, context ~ context') => +instance + (Table context a, context ~ context') => Table context' (NonEmptyTable context a) - where + where type Columns (NonEmptyTable context a) = HNonEmptyTable (Columns a) type Context (NonEmptyTable context a) = Context a type FromExprs (NonEmptyTable context a) = NonEmpty (FromExprs a) - type Transpose to (NonEmptyTable context a) = - NonEmptyTable to (Transpose to a) + type + Transpose to (NonEmptyTable context a) = + NonEmptyTable to (Transpose to a) + fromColumns = NonEmptyTable toColumns (NonEmptyTable a) = a @@ -82,29 +98,34 @@ instance (Table context a, context ~ context') => toResult = hvectorize vectorizer . fmap (toResult @_ @a) -instance (EqTable a, context ~ Expr) => +instance + (EqTable a, context ~ Expr) => EqTable (NonEmptyTable context a) - where + where eqTable = hvectorize - (\Spec {nullity} (Identity Dict) -> case nullity of - Null -> Dict - NotNull -> Dict) + ( \Spec{nullity} (Identity Dict) -> case nullity of + Null -> Dict + NotNull -> Dict + ) (Identity (eqTable @a)) -instance (OrdTable a, context ~ Expr) => +instance + (OrdTable a, context ~ Expr) => OrdTable (NonEmptyTable context a) - where + where ordTable = hvectorize - (\Spec {nullity} (Identity Dict) -> case nullity of - Null -> Dict - NotNull -> Dict) + ( \Spec{nullity} (Identity Dict) -> case nullity of + Null -> Dict + NotNull -> Dict + ) (Identity (ordTable @a)) -instance (ToExprs exprs a, context ~ Expr) => +instance + (ToExprs exprs a, context ~ Expr) => ToExprs (NonEmptyTable context exprs) (NonEmpty a) @@ -112,54 +133,61 @@ instance context ~ Expr => AltTable (NonEmptyTable context) where (<|>:) = (<>) -instance (Table Expr a, context ~ Expr) => Semigroup (NonEmptyTable context a) - where - NonEmptyTable as <> NonEmptyTable bs = NonEmptyTable $ - happend (const sappend1) as bs +instance (Table Expr a, context ~ Expr) => Semigroup (NonEmptyTable context a) where + NonEmptyTable as <> NonEmptyTable bs = + NonEmptyTable $ + happend (const sappend1) as bs -- | Project a single expression out of a 'NonEmptyTable'. -($+) :: Projecting a (Expr b) - => Projection a (Expr b) -> NonEmptyTable Expr a -> Expr (NonEmpty b) +($+) :: + Projecting a (Expr b) => + Projection a (Expr b) -> + NonEmptyTable Expr a -> + Expr (NonEmpty b) f $+ NonEmptyTable a = hcolumn $ hproject (apply f) a + + infixl 4 $+ -- | Construct a @NonEmptyTable@ from a non-empty list of expressions. nonEmptyTable :: Table Expr a => NonEmpty a -> NonEmptyTable Expr a nonEmptyTable = - NonEmptyTable . - hvectorize (\Spec {info} -> snonEmptyOf info) . - fmap toColumns - - --- | Construct a 'NonEmptyTable' in the 'Name' context. This can be useful if --- you have a 'NonEmptyTable' that you are storing in a table and need to --- construct a 'TableSchema'. -nameNonEmptyTable - :: Table Name a - => a -- ^ The names of the columns of elements of the list. - -> NonEmptyTable Name a + NonEmptyTable + . hvectorize (\Spec{info} -> snonEmptyOf info) + . fmap toColumns + + +{- | Construct a 'NonEmptyTable' in the 'Name' context. This can be useful if +you have a 'NonEmptyTable' that you are storing in a table and need to +construct a 'TableSchema'. +-} +nameNonEmptyTable :: + Table Name a => + -- | The names of the columns of elements of the list. + a -> + NonEmptyTable Name a nameNonEmptyTable = - NonEmptyTable . - hvectorize (\_ (Identity (Name a)) -> Name a) . - pure . - toColumns + NonEmptyTable + . hvectorize (\_ (Identity (Name a)) -> Name a) + . pure + . toColumns -- | Get the first element of a 'NonEmptyTable'. head1 :: Table Expr a => NonEmptyTable Expr a -> a head1 = - fromColumns . - runIdentity . - hunvectorize (\_ -> Identity . head1Expr) . - toColumns + fromColumns + . runIdentity + . hunvectorize (\_ -> Identity . head1Expr) + . toColumns -- | Get the last element of a 'NonEmptyTable'. last1 :: Table Expr a => NonEmptyTable Expr a -> a last1 = - fromColumns . - runIdentity . - hunvectorize (\_ -> Identity . last1Expr) . - toColumns + fromColumns + . runIdentity + . hunvectorize (\_ -> Identity . last1Expr) + . toColumns diff --git a/src/Rel8/Table/Null.hs b/src/Rel8/Table/Null.hs index 0e9e68c5..67004cf4 100644 --- a/src/Rel8/Table/Null.hs +++ b/src/Rel8/Table/Null.hs @@ -1,61 +1,75 @@ -{-# language DataKinds #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language MultiParamTypeClasses #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeApplications #-} -{-# language TypeFamilies #-} -{-# language TypeOperators #-} -{-# language UndecidableInstances #-} - -module Rel8.Table.Null - ( NullTable(..) - , nullableTable, nullTable, nullifyTable, unsafeUnnullifyTable - , isNullTable, isNonNullTable - , nameNullTable - , toMaybeTable, toNullTable - ) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Rel8.Table.Null ( + NullTable (..), + nullableTable, + nullTable, + nullifyTable, + unsafeUnnullifyTable, + isNullTable, + isNonNullTable, + nameNullTable, + toMaybeTable, + toNullTable, +) where -- base -import Data.Kind ( Type ) -import Prelude hiding ( null, undefined ) +import Data.Kind (Type) +import Prelude hiding (null, undefined) -- comonad -import Control.Comonad ( extract ) +import Control.Comonad (extract) -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Expr.Bool ( not_ ) -import Rel8.Kind.Context ( Reifiable ) +import Rel8.Expr (Expr) +import Rel8.Expr.Bool (not_) +import Rel8.Kind.Context (Reifiable) import qualified Rel8.Schema.Kind as K -import Rel8.Schema.Name ( Name ) -import Rel8.Table - ( Table, Columns, Context, fromColumns, toColumns - , FromExprs, fromResult, toResult - , Transpose - ) -import Rel8.Table.Alternative - ( AltTable, (<|>:) - , AlternativeTable, emptyTable - ) -import Rel8.Table.Bool ( bool ) -import Rel8.Table.Eq ( EqTable, eqTable ) -import Rel8.Table.Maybe ( MaybeTable, justTable, maybeTable, nothingTable ) -import Rel8.Table.Nullify ( Nullify, isNull ) -import Rel8.Table.Ord ( OrdTable, ordTable ) -import Rel8.Table.Projection ( Projectable, project ) -import Rel8.Table.Serialize ( ToExprs ) -import Rel8.Table.Undefined ( undefined ) - - --- | @NullTable t@ is the table @t@, but where all the columns in @t@ have the --- possibility of being 'Rel8.null'. This is very similar to --- 'Rel8.MaybeTable', except that it does not use an extra tag field, so it --- cannot distinguish between @Nothing@ and @Just Nothing@ if nested. In other --- words, if all of the columns of the @t@ passed to @NullTable@ are already --- nullable, then @NullTable@ has no effect. +import Rel8.Schema.Name (Name) +import Rel8.Table ( + Columns, + Context, + FromExprs, + Table, + Transpose, + fromColumns, + fromResult, + toColumns, + toResult, + ) +import Rel8.Table.Alternative ( + AltTable, + AlternativeTable, + emptyTable, + (<|>:), + ) +import Rel8.Table.Bool (bool) +import Rel8.Table.Eq (EqTable, eqTable) +import Rel8.Table.Maybe (MaybeTable, justTable, maybeTable, nothingTable) +import Rel8.Table.Nullify (Nullify, isNull) +import Rel8.Table.Ord (OrdTable, ordTable) +import Rel8.Table.Projection (Projectable, project) +import Rel8.Table.Serialize (ToExprs) +import Rel8.Table.Undefined (undefined) + + +{- | @NullTable t@ is the table @t@, but where all the columns in @t@ have the +possibility of being 'Rel8.null'. This is very similar to +'Rel8.MaybeTable', except that it does not use an extra tag field, so it +cannot distinguish between @Nothing@ and @Just Nothing@ if nested. In other +words, if all of the columns of the @t@ passed to @NullTable@ are already +nullable, then @NullTable@ has no effect. +-} type NullTable :: K.Context -> Type -> Type newtype NullTable context a = NullTable (Nullify context a) @@ -72,17 +86,20 @@ instance context ~ Expr => AlternativeTable (NullTable context) where emptyTable = nullTable -instance (Table context a, Reifiable context, context ~ context') => +instance + (Table context a, Reifiable context, context ~ context') => Table context' (NullTable context a) - where + where type Columns (NullTable context a) = Columns (Nullify context a) type Context (NullTable context a) = Context (Nullify context a) type FromExprs (NullTable context a) = FromExprs (Nullify context a) type Transpose to (NullTable context a) = NullTable to (Transpose to a) + toColumns (NullTable a) = toColumns a fromColumns = NullTable . fromColumns + toResult = toResult @_ @(Nullify context a) fromResult = fromResult @_ @(Nullify context a) @@ -95,12 +112,14 @@ instance (OrdTable a, context ~ Expr) => OrdTable (NullTable context a) where ordTable = ordTable @(Nullify context a) -instance (ToExprs exprs a, context ~ Expr) => +instance + (ToExprs exprs a, context ~ Expr) => ToExprs (NullTable context exprs) (Maybe a) --- | Check if any of the non-nullable fields of @a@ are 'Rel8.null' under the --- 'NullTable'. Returns 'Rel8.false' if @a@ has no non-nullable fields. +{- | Check if any of the non-nullable fields of @a@ are 'Rel8.null' under the +'NullTable'. Returns 'Rel8.false' if @a@ has no non-nullable fields. +-} isNullTable :: Table Expr a => NullTable Expr a -> Expr Bool isNullTable (NullTable a) = isNull a @@ -111,8 +130,12 @@ isNonNullTable = not_ . isNullTable -- | Like 'Rel8.nullable'. -nullableTable :: (Table Expr a, Table Expr b) - => b -> (a -> b) -> NullTable Expr a -> b +nullableTable :: + (Table Expr a, Table Expr b) => + b -> + (a -> b) -> + NullTable Expr a -> + b nullableTable b f ma@(NullTable a) = bool (f (extract a)) b (isNullTable ma) @@ -130,9 +153,10 @@ unsafeUnnullifyTable :: NullTable Expr a -> a unsafeUnnullifyTable (NullTable a) = extract a --- | Construct a 'NullTable' in the 'Name' context. This can be useful if you --- have a 'NullTable' that you are storing in a table and need to construct a --- 'TableSchema'. +{- | Construct a 'NullTable' in the 'Name' context. This can be useful if you +have a 'NullTable' that you are storing in a table and need to construct a +'TableSchema'. +-} nameNullTable :: a -> NullTable Name a nameNullTable = NullTable . pure @@ -142,7 +166,8 @@ toMaybeTable :: Table Expr a => NullTable Expr a -> MaybeTable Expr a toMaybeTable = nullableTable nothingTable justTable --- | Convert a 'MaybeTable' to a 'NullTable'. Note that if the underlying @a@ --- has no non-nullable fields, this is a lossy conversion. +{- | Convert a 'MaybeTable' to a 'NullTable'. Note that if the underlying @a@ +has no non-nullable fields, this is a lossy conversion. +-} toNullTable :: Table Expr a => MaybeTable Expr a -> NullTable Expr a toNullTable = maybeTable nullTable nullifyTable diff --git a/src/Rel8/Table/Nullify.hs b/src/Rel8/Table/Nullify.hs index c86738d1..38b9257c 100644 --- a/src/Rel8/Table/Nullify.hs +++ b/src/Rel8/Table/Nullify.hs @@ -1,76 +1,87 @@ -{-# language DataKinds #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language LambdaCase #-} -{-# language MultiParamTypeClasses #-} -{-# language NamedFieldPuns #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeApplications #-} -{-# language TypeFamilies #-} -{-# language TypeOperators #-} -{-# language UndecidableInstances #-} - -module Rel8.Table.Nullify - ( Nullify - , aggregateNullify - , guard - , isNull - ) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Rel8.Table.Nullify ( + Nullify, + aggregateNullify, + guard, + isNull, +) where -- base -import Control.Applicative ( liftA2 ) -import Data.Functor.Const ( Const( Const ), getConst ) -import Data.Functor.Identity ( runIdentity ) -import Data.Kind ( Type ) +import Control.Applicative (liftA2) +import Data.Functor.Const (Const (Const), getConst) +import Data.Functor.Identity (runIdentity) +import Data.Kind (Type) import Prelude -- comonad -import Control.Comonad ( Comonad, duplicate, extract, ComonadApply, (<@>) ) +import Control.Comonad (Comonad, ComonadApply, duplicate, extract, (<@>)) -- profunctors import Data.Profunctor (dimap) -- rel8 import Rel8.Aggregate (Aggregator') -import Rel8.Expr ( Expr ) -import Rel8.Expr.Bool ( (||.), false ) +import Rel8.Expr (Expr) +import Rel8.Expr.Bool (false, (||.)) import qualified Rel8.Expr.Null as Expr -import Rel8.Kind.Context ( Reifiable, contextSing ) -import Rel8.Schema.Context.Nullify - ( Nullifiability( NExpr ) - , NonNullifiability - , Nullifiable, nullifiability - , nullifiableOrNot, absurd - , guarder - , nullifier - , unnullifier - ) -import Rel8.Schema.Dict ( Dict( Dict ) ) -import Rel8.Schema.HTable ( HTable ) -import Rel8.Schema.HTable.Nullify - ( HNullify, hnulls, hnullify, hunnullify - , hguard - , hproject - ) +import Rel8.Kind.Context (Reifiable, contextSing) +import Rel8.Schema.Context.Nullify ( + NonNullifiability, + Nullifiability (NExpr), + Nullifiable, + absurd, + guarder, + nullifiability, + nullifiableOrNot, + nullifier, + unnullifier, + ) +import Rel8.Schema.Dict (Dict (Dict)) +import Rel8.Schema.HTable (HTable) +import Rel8.Schema.HTable.Nullify ( + HNullify, + hguard, + hnullify, + hnulls, + hproject, + hunnullify, + ) import qualified Rel8.Schema.Kind as K -import Rel8.Schema.Null ( Nullity( NotNull, Null ) ) +import Rel8.Schema.Null (Nullity (NotNull, Null)) import qualified Rel8.Schema.Result as R -import Rel8.Table - ( Table, Columns, Context, toColumns, fromColumns - , FromExprs, fromResult, toResult - , Transpose - ) -import Rel8.Schema.Spec ( Spec( Spec, nullity ) ) -import Rel8.Table.Eq ( EqTable, eqTable ) -import Rel8.Table.Ord ( OrdTable, ordTable ) -import Rel8.Table.Projection ( Projectable, apply, project ) +import Rel8.Schema.Spec (Spec (Spec, nullity)) +import Rel8.Table ( + Columns, + Context, + FromExprs, + Table, + Transpose, + fromColumns, + fromResult, + toColumns, + toResult, + ) +import Rel8.Table.Eq (EqTable, eqTable) +import Rel8.Table.Ord (OrdTable, ordTable) +import Rel8.Table.Projection (Projectable, apply, project) -- semigroupoids -import Data.Functor.Apply ( Apply, (<.>), liftF2 ) -import Data.Functor.Bind ( Bind, (>>-) ) -import Data.Functor.Extend ( Extend, duplicated ) +import Data.Functor.Apply (Apply, liftF2, (<.>)) +import Data.Functor.Bind (Bind, (>>-)) +import Data.Functor.Extend (Extend, duplicated) type Nullify :: K.Context -> Type -> Type @@ -142,31 +153,36 @@ instance Nullifiable context => ComonadApply (Nullify context) where (<@>) = (<.>) -instance (Table context a, Reifiable context, context ~ context') => +instance + (Table context a, Reifiable context, context ~ context') => Table context' (Nullify context a) - where + where type Columns (Nullify context a) = HNullify (Columns a) type Context (Nullify context a) = Context a type FromExprs (Nullify context a) = Maybe (FromExprs a) type Transpose to (Nullify context a) = Nullify to (Transpose to a) + fromColumns = case nullifiableOrNot contextSing of Left notNullifiable -> Fields notNullifiable Right nullifiable -> - Table nullifiable . - fromColumns . - runIdentity . - hunnullify (\spec -> pure . unnullifier nullifiable spec) + Table nullifiable + . fromColumns + . runIdentity + . hunnullify (\spec -> pure . unnullifier nullifiable spec) + toColumns = \case Table nullifiable a -> hnullify (nullifier nullifiable) (toColumns a) Fields _ a -> a + fromResult = fmap (fromResult @_ @a) . hunnullify R.unnullifier + toResult = - maybe (hnulls (const R.null)) (hnullify R.nullifier) . - fmap (toResult @_ @a) + maybe (hnulls (const R.null)) (hnullify R.nullifier) + . fmap (toResult @_ @a) instance (EqTable a, context ~ Expr) => EqTable (Nullify context a) where @@ -177,9 +193,10 @@ instance (OrdTable a, context ~ Expr) => OrdTable (Nullify context a) where ordTable = hnullify (\_ Dict -> Dict) (ordTable @a) -aggregateNullify :: () - => Aggregator' fold i a - -> Aggregator' fold (Nullify Expr i) (Nullify Expr a) +aggregateNullify :: + () => + Aggregator' fold i a -> + Aggregator' fold (Nullify Expr i) (Nullify Expr a) aggregateNullify = dimap from to where from = \case @@ -188,24 +205,27 @@ aggregateNullify = dimap from to to = Table NExpr -guard :: (Reifiable context, HTable t) - => context tag - -> (tag -> Bool) - -> (Expr tag -> Expr Bool) - -> HNullify t context - -> HNullify t context +guard :: + (Reifiable context, HTable t) => + context tag -> + (tag -> Bool) -> + (Expr tag -> Expr Bool) -> + HNullify t context -> + HNullify t context guard tag isNonNull isNonNullExpr = hguard (guarder contextSing tag isNonNull isNonNullExpr) isNull :: forall a. Table Expr a => Nullify Expr a -> Expr Bool isNull = - maybe false getAny . - getConst . - hunnullify (\Spec {nullity} a -> Const $ case nullity of - NotNull -> Just $ Any $ Expr.isNull a - Null -> Nothing) . - toColumns + maybe false getAny + . getConst + . hunnullify + ( \Spec{nullity} a -> Const $ case nullity of + NotNull -> Just $ Any $ Expr.isNull a + Null -> Nothing + ) + . toColumns newtype Any = Any diff --git a/src/Rel8/Table/Opaleye.hs b/src/Rel8/Table/Opaleye.hs index 269c8cf9..36f691fe 100644 --- a/src/Rel8/Table/Opaleye.hs +++ b/src/Rel8/Table/Opaleye.hs @@ -1,75 +1,87 @@ -{-# language BlockArguments #-} -{-# language DataKinds #-} -{-# language DisambiguateRecordFields #-} -{-# language FlexibleContexts #-} -{-# language NamedFieldPuns #-} -{-# language RankNTypes #-} -{-# language TypeFamilies #-} -{-# language ViewPatterns #-} - -{-# options_ghc -Wno-deprecations #-} - -module Rel8.Table.Opaleye - ( attributes - , binaryspec - , distinctspec - , exprs - , exprsWithNames - , ifPP - , table - , tableFields - , unpackspec - , valuesspec - , view - , castTable - ) +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-deprecations #-} + +module Rel8.Table.Opaleye ( + attributes, + binaryspec, + distinctspec, + exprs, + exprsWithNames, + ifPP, + table, + tableFields, + unpackspec, + valuesspec, + view, + castTable, +) where -- base -import Data.Functor.Const ( Const( Const ), getConst ) -import Data.List.NonEmpty ( NonEmpty ) +import Data.Functor.Const (Const (Const), getConst) +import Data.List.NonEmpty (NonEmpty) import Prelude -- opaleye import qualified Opaleye.Adaptors as Opaleye -import qualified Opaleye.Field as Opaleye ( Field_ ) +import qualified Opaleye.Field as Opaleye (Field_) import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye import qualified Opaleye.Internal.Values as Opaleye import qualified Opaleye.Table as Opaleye +-- product-profunctors +import Data.Profunctor.Product (ProductProfunctor) + -- profunctors -import Data.Profunctor ( dimap, lmap ) +import Data.Profunctor (dimap, lmap) -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Expr.Opaleye - ( fromPrimExpr, toPrimExpr - , scastExpr, traverseFieldP - ) -import Rel8.Schema.HTable ( htabulateA, hfield, hspecs, htabulate, - htraverseP, htraversePWithField ) -import Rel8.Schema.Name ( Name( Name ), Selects, ppColumn ) -import Rel8.Schema.Spec ( Spec(..) ) -import Rel8.Schema.Table ( TableSchema(..), ppTable ) -import Rel8.Table ( Table, fromColumns, toColumns ) -import Rel8.Type.Information ( typeName ) +import Rel8.Expr (Expr) +import Rel8.Expr.Opaleye ( + fromPrimExpr, + scastExpr, + toPrimExpr, + traverseFieldP, + ) +import Rel8.Schema.HTable ( + hfield, + hspecs, + htabulate, + htabulateA, + htraverseP, + htraversePWithField, + ) +import Rel8.Schema.Name (Name (Name), Selects, ppColumn) +import Rel8.Schema.Spec (Spec (..)) +import Rel8.Schema.Table (TableSchema (..), ppTable) +import Rel8.Table (Table, fromColumns, toColumns) +import Rel8.Type.Information (typeName) -- semigroupoids -import Data.Functor.Apply ( WrappedApplicative(..) ) -import Data.Profunctor.Product ( ProductProfunctor ) +import Data.Functor.Apply (WrappedApplicative (..)) attributes :: Selects names exprs => TableSchema names -> exprs -attributes schema@TableSchema {columns} = fromColumns $ htabulate $ \field -> +attributes schema@TableSchema{columns} = fromColumns $ htabulate $ \field -> case hfield (toColumns columns) field of - Name column -> fromPrimExpr $ Opaleye.ConstExpr $ - Opaleye.OtherLit $ - show (ppTable schema) <> "." <> show (ppColumn column) + Name column -> + fromPrimExpr $ + Opaleye.ConstExpr $ + Opaleye.OtherLit $ + show (ppTable schema) <> "." <> show (ppColumn column) -fromOpaleyespec :: (ProductProfunctor p, Table Expr a) - => p (Opaleye.Field_ n x) (Opaleye.Field_ n x) - -> p a a +fromOpaleyespec :: + (ProductProfunctor p, Table Expr a) => + p (Opaleye.Field_ n x) (Opaleye.Field_ n x) -> + p a a fromOpaleyespec x = dimap toColumns fromColumns (htraverseP (traverseFieldP x)) @@ -88,8 +100,11 @@ exprs (toColumns -> as) = getConst $ htabulateA $ \field -> expr -> Const (pure (toPrimExpr expr)) -exprsWithNames :: Selects names exprs - => names -> exprs -> NonEmpty (String, Opaleye.PrimExpr) +exprsWithNames :: + Selects names exprs => + names -> + exprs -> + NonEmpty (String, Opaleye.PrimExpr) exprsWithNames names as = getConst $ htabulateA $ \field -> case (hfield (toColumns names) field, hfield (toColumns as) field) of (Name name, expr) -> Const (pure (name, toPrimExpr expr)) @@ -106,12 +121,15 @@ table (TableSchema name schema columns) = Just schemaName -> Opaleye.tableWithSchema schemaName name (tableFields columns) -tableFields :: Selects names exprs - => names -> Opaleye.TableFields exprs exprs +tableFields :: + Selects names exprs => + names -> + Opaleye.TableFields exprs exprs tableFields (toColumns -> names) = dimap toColumns fromColumns $ - unwrapApplicative $ htabulateA $ \field -> WrapApplicative $ - case hfield names field of - name -> lmap (`hfield` field) (go name) + unwrapApplicative $ + htabulateA $ \field -> WrapApplicative $ + case hfield names field of + name -> lmap (`hfield` field) (go name) where go :: Name a -> Opaleye.TableFields (Expr a) (Expr a) go (Name name) = @@ -121,13 +139,15 @@ tableFields (toColumns -> names) = dimap toColumns fromColumns $ unpackspec :: Table Expr a => Opaleye.Unpackspec a a unpackspec = fromOpaleyespec Opaleye.unpackspecField -{-# INLINABLE unpackspec #-} +{-# INLINEABLE unpackspec #-} valuesspec :: Table Expr a => Opaleye.Valuesspec a a -valuesspec = dimap toColumns fromColumns $ - htraversePWithField (traverseFieldP . Opaleye.valuesspecFieldType . typeName) - where typeName = Rel8.Type.Information.typeName . info . hfield hspecs +valuesspec = + dimap toColumns fromColumns $ + htraversePWithField (traverseFieldP . Opaleye.valuesspecFieldType . typeName) + where + typeName = Rel8.Type.Information.typeName . info . hfield hspecs view :: Selects names exprs => names -> exprs @@ -136,11 +156,12 @@ view columns = fromColumns $ htabulate $ \field -> Name column -> fromPrimExpr $ Opaleye.BaseTableAttrExpr column --- | Transform a table by adding 'CAST' to all columns. This is most useful for --- finalising a SELECT or RETURNING statement, guaranteed that the output --- matches what is encoded in each columns TypeInformation. +{- | Transform a table by adding 'CAST' to all columns. This is most useful for +finalising a SELECT or RETURNING statement, guaranteed that the output +matches what is encoded in each columns TypeInformation. +-} castTable :: Table Expr a => a -> a castTable (toColumns -> as) = fromColumns $ htabulate \field -> case hfield hspecs field of - Spec {info} -> case hfield as field of - expr -> scastExpr info expr + Spec{info} -> case hfield as field of + expr -> scastExpr info expr diff --git a/src/Rel8/Table/Ord.hs b/src/Rel8/Table/Ord.hs index ac73fcdc..901ef827 100644 --- a/src/Rel8/Table/Ord.hs +++ b/src/Rel8/Table/Ord.hs @@ -1,58 +1,64 @@ -{-# language AllowAmbiguousTypes #-} -{-# language DataKinds #-} -{-# language DefaultSignatures #-} -{-# language DisambiguateRecordFields #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeApplications #-} -{-# language TypeFamilies #-} -{-# language TypeOperators #-} -{-# language UndecidableInstances #-} -{-# language ViewPatterns #-} - -module Rel8.Table.Ord - ( OrdTable( ordTable ), (<:), (<=:), (>:), (>=:), least, greatest - ) +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +module Rel8.Table.Ord ( + OrdTable (ordTable), + (<:), + (<=:), + (>:), + (>=:), + least, + greatest, +) where -- base -import Data.Functor.Const ( Const( Const ), getConst ) -import Data.Kind ( Constraint, Type ) -import GHC.Generics ( Rep ) -import Prelude hiding ( seq ) +import Data.Functor.Const (Const (Const), getConst) +import Data.Kind (Constraint, Type) +import GHC.Generics (Rep) +import Prelude hiding (seq) -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Expr.Bool ( (||.), (&&.), false, true ) -import Rel8.Expr.Eq ( (==.) ) -import Rel8.Expr.Ord ( (<.), (>.) ) -import Rel8.FCF ( Eval, Exp ) -import Rel8.Generic.Record ( Record ) -import Rel8.Generic.Table.Record ( GTable, GColumns, gtable ) -import Rel8.Schema.Dict ( Dict( Dict ) ) -import Rel8.Schema.HTable ( htabulateA, hfield ) -import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) ) +import Rel8.Expr (Expr) +import Rel8.Expr.Bool (false, true, (&&.), (||.)) +import Rel8.Expr.Eq ((==.)) +import Rel8.Expr.Ord ((<.), (>.)) +import Rel8.FCF (Eval, Exp) +import Rel8.Generic.Record (Record) +import Rel8.Generic.Table.Record (GColumns, GTable, gtable) +import Rel8.Schema.Dict (Dict (Dict)) +import Rel8.Schema.HTable (hfield, htabulateA) +import Rel8.Schema.HTable.Identity (HIdentity (HIdentity)) import Rel8.Schema.Null (Sql) -import Rel8.Table ( Columns, toColumns, TColumns ) -import Rel8.Table.Bool ( bool ) -import Rel8.Table.Eq ( EqTable ) -import Rel8.Type.Ord ( DBOrd ) +import Rel8.Table (Columns, TColumns, toColumns) +import Rel8.Table.Bool (bool) +import Rel8.Table.Eq (EqTable) +import Rel8.Type.Ord (DBOrd) --- | The class of 'Table's that can be ordered. Ordering on tables is defined --- by their lexicographic ordering of all columns, so this class means "all --- columns in a 'Table' have an instance of 'DBOrd'". +{- | The class of 'Table's that can be ordered. Ordering on tables is defined +by their lexicographic ordering of all columns, so this class means "all +columns in a 'Table' have an instance of 'DBOrd'". +-} type OrdTable :: Type -> Constraint class EqTable a => OrdTable a where ordTable :: Columns a (Dict (Sql DBOrd)) - default ordTable :: ( GTable TOrdTable TColumns (Rep (Record a)) , Columns a ~ GColumns TColumns (Rep (Record a)) - ) - => Columns a (Dict (Sql DBOrd)) + ) => + Columns a (Dict (Sql DBOrd)) ordTable = gtable @TOrdTable @TColumns @(Rep (Record a)) table where table (_ :: proxy x) = ordTable @x @@ -75,25 +81,37 @@ instance (OrdTable a, OrdTable b, OrdTable c) => OrdTable (a, b, c) instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d) => OrdTable (a, b, c, d) -instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e) => +instance + (OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e) => OrdTable (a, b, c, d, e) instance - ( OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e, OrdTable f - ) - => OrdTable (a, b, c, d, e, f) + ( OrdTable a + , OrdTable b + , OrdTable c + , OrdTable d + , OrdTable e + , OrdTable f + ) => + OrdTable (a, b, c, d, e, f) instance - ( OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e, OrdTable f + ( OrdTable a + , OrdTable b + , OrdTable c + , OrdTable d + , OrdTable e + , OrdTable f , OrdTable g - ) - => OrdTable (a, b, c, d, e, f, g) + ) => + OrdTable (a, b, c, d, e, f, g) --- | Test if one 'Table' sorts before another. Corresponds to comparing all --- columns with '<'. +{- | Test if one 'Table' sorts before another. Corresponds to comparing all +columns with '<'. +-} (<:) :: forall a. OrdTable a => a -> a -> Expr Bool (toColumns -> as) <: (toColumns -> bs) = foldr @[] go false $ getConst $ htabulateA $ \field -> @@ -102,11 +120,14 @@ instance Dict -> Const [(a <. b, a ==. b)] where go (lt, eq) a = lt ||. (eq &&. a) + + infix 4 <: --- | Test if one 'Table' sorts before, or is equal to, another. Corresponds to --- comparing all columns with '<='. +{- | Test if one 'Table' sorts before, or is equal to, another. Corresponds to +comparing all columns with '<='. +-} (<=:) :: forall a. OrdTable a => a -> a -> Expr Bool (toColumns -> as) <=: (toColumns -> bs) = foldr @[] go true $ getConst $ htabulateA $ \field -> @@ -115,11 +136,14 @@ infix 4 <: Dict -> Const [(a <. b, a ==. b)] where go (lt, eq) a = lt ||. (eq &&. a) + + infix 4 <=: --- | Test if one 'Table' sorts after another. Corresponds to comparing all --- columns with '>'. +{- | Test if one 'Table' sorts after another. Corresponds to comparing all +columns with '>'. +-} (>:) :: forall a. OrdTable a => a -> a -> Expr Bool (toColumns -> as) >: (toColumns -> bs) = foldr @[] go false $ getConst $ htabulateA $ \field -> @@ -128,11 +152,14 @@ infix 4 <=: Dict -> Const [(a >. b, a ==. b)] where go (gt, eq) a = gt ||. (eq &&. a) + + infix 4 >: --- | Test if one 'Table' sorts after another. Corresponds to comparing all --- columns with '>='. +{- | Test if one 'Table' sorts after another. Corresponds to comparing all +columns with '>='. +-} (>=:) :: forall a. OrdTable a => a -> a -> Expr Bool (toColumns -> as) >=: (toColumns -> bs) = foldr @[] go true $ getConst $ htabulateA $ \field -> @@ -141,6 +168,8 @@ infix 4 >: Dict -> Const [(a >. b, a ==. b)] where go (gt, eq) a = gt ||. (eq &&. a) + + infix 4 >=: diff --git a/src/Rel8/Table/Order.hs b/src/Rel8/Table/Order.hs index c4a20655..ce4a1a67 100644 --- a/src/Rel8/Table/Order.hs +++ b/src/Rel8/Table/Order.hs @@ -1,50 +1,58 @@ -{-# language DataKinds #-} -{-# language NamedFieldPuns #-} -{-# language ScopedTypeVariables #-} -{-# language TypeApplications #-} -{-# language TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} -module Rel8.Table.Order - ( ascTable - , descTable - ) +module Rel8.Table.Order ( + ascTable, + descTable, +) where -- base -import Data.Functor.Const ( Const( Const ), getConst ) -import Data.Functor.Contravariant ( (>$<), contramap ) +import Data.Functor.Const (Const (Const), getConst) +import Data.Functor.Contravariant (contramap, (>$<)) import Prelude -- rel8 -import Rel8.Expr.Order ( asc, desc, nullsFirst, nullsLast ) -import Rel8.Order ( Order ) -import Rel8.Schema.Dict ( Dict( Dict ) ) -import Rel8.Schema.HTable (htabulateA, hfield, hspecs) -import Rel8.Schema.Null ( Nullity( Null, NotNull ) ) -import Rel8.Schema.Spec ( Spec( Spec, nullity ) ) -import Rel8.Table ( Columns, toColumns ) -import Rel8.Table.Ord ( OrdTable, ordTable ) +import Rel8.Expr.Order (asc, desc, nullsFirst, nullsLast) +import Rel8.Order (Order) +import Rel8.Schema.Dict (Dict (Dict)) +import Rel8.Schema.HTable (hfield, hspecs, htabulateA) +import Rel8.Schema.Null (Nullity (NotNull, Null)) +import Rel8.Schema.Spec (Spec (Spec, nullity)) +import Rel8.Table (Columns, toColumns) +import Rel8.Table.Ord (OrdTable, ordTable) --- | Construct an 'Order' for a 'Table' by sorting all columns into ascending --- orders (any nullable columns will be sorted with @NULLS FIRST@). +{- | Construct an 'Order' for a 'Table' by sorting all columns into ascending +orders (any nullable columns will be sorted with @NULLS FIRST@). +-} ascTable :: forall a. OrdTable a => Order a -ascTable = contramap toColumns $ getConst $ - htabulateA @(Columns a) $ \field -> case hfield hspecs field of - Spec {nullity} -> case hfield (ordTable @a) field of - Dict -> Const $ (`hfield` field) >$< - case nullity of - Null -> nullsFirst asc - NotNull -> asc +ascTable = contramap toColumns $ + getConst $ + htabulateA @(Columns a) $ \field -> case hfield hspecs field of + Spec{nullity} -> case hfield (ordTable @a) field of + Dict -> + Const $ + (`hfield` field) + >$< case nullity of + Null -> nullsFirst asc + NotNull -> asc --- | Construct an 'Order' for a 'Table' by sorting all columns into descending --- orders (any nullable columns will be sorted with @NULLS LAST@). +{- | Construct an 'Order' for a 'Table' by sorting all columns into descending +orders (any nullable columns will be sorted with @NULLS LAST@). +-} descTable :: forall a. OrdTable a => Order a -descTable = contramap toColumns $ getConst $ - htabulateA @(Columns a) $ \field -> case hfield hspecs field of - Spec {nullity} -> case hfield (ordTable @a) field of - Dict -> Const $ (`hfield` field) >$< - case nullity of - Null -> nullsLast desc - NotNull -> desc +descTable = contramap toColumns $ + getConst $ + htabulateA @(Columns a) $ \field -> case hfield hspecs field of + Spec{nullity} -> case hfield (ordTable @a) field of + Dict -> + Const $ + (`hfield` field) + >$< case nullity of + Null -> nullsLast desc + NotNull -> desc diff --git a/src/Rel8/Table/Projection.hs b/src/Rel8/Table/Projection.hs index efdf9fcc..03ce7f13 100644 --- a/src/Rel8/Table/Projection.hs +++ b/src/Rel8/Table/Projection.hs @@ -1,73 +1,89 @@ -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language MonoLocalBinds #-} -{-# language MultiParamTypeClasses #-} -{-# language StandaloneKindSignatures #-} -{-# language UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UndecidableInstances #-} -module Rel8.Table.Projection - ( Projection - , Projectable( project ) - , Biprojectable( biproject ) - , Projecting - , apply - ) +module Rel8.Table.Projection ( + Projection, + Projectable (project), + Biprojectable (biproject), + Projecting, + apply, +) where -- base -import Data.Kind ( Constraint, Type ) +import Data.Kind (Constraint, Type) import Prelude -- rel8 -import Rel8.Schema.Field ( Field( Field ), fields ) -import Rel8.Schema.HTable ( hfield, htabulate ) -import Rel8.Table ( Columns, Context, Transpose, toColumns ) -import Rel8.Table.Transpose ( Transposes ) +import Rel8.Schema.Field (Field (Field), fields) +import Rel8.Schema.HTable (hfield, htabulate) +import Rel8.Table (Columns, Context, Transpose, toColumns) +import Rel8.Table.Transpose (Transposes) --- | The constraint @'Projecting' a b@ ensures that @'Projection' a b@ is a --- usable 'Projection'. +{- | The constraint @'Projecting' a b@ ensures that @'Projection' a b@ is a +usable 'Projection'. +-} type Projecting :: Type -> Type -> Constraint class ( Transposes (Context a) (Field a) a (Transpose (Field a) a) , Transposes (Context a) (Field a) b (Transpose (Field a) b) - ) - => Projecting a b + ) => + Projecting a b + + instance ( Transposes (Context a) (Field a) a (Transpose (Field a) a) , Transposes (Context a) (Field a) b (Transpose (Field a) b) - ) - => Projecting a b + ) => + Projecting a b --- | A @'Projection' a b@s is a special type of function @a -> b@ whereby the --- resulting @b@ is guaranteed to be composed only from columns contained in --- @a@. +{- | A @'Projection' a b@s is a special type of function @a -> b@ whereby the +resulting @b@ is guaranteed to be composed only from columns contained in +@a@. +-} type Projection :: Type -> Type -> Type type Projection a b = Transpose (Field a) a -> Transpose (Field a) b --- | @'Projectable' f@ means that @f@ is a kind of functor on 'Rel8.Table's --- that allows the mapping of a 'Projection' over its underlying columns. +{- | @'Projectable' f@ means that @f@ is a kind of functor on 'Rel8.Table's +that allows the mapping of a 'Projection' over its underlying columns. +-} type Projectable :: (Type -> Type) -> Constraint class Projectable f where -- | Map a 'Projection' over @f@. - project :: Projecting a b - => Projection a b -> f a -> f b + project :: + Projecting a b => + Projection a b -> + f a -> + f b --- | @'Biprojectable' p@ means that @p@ is a kind of bifunctor on --- 'Rel8.Table's that allows the mapping of a pair of 'Projection's over its --- underlying columns. +{- | @'Biprojectable' p@ means that @p@ is a kind of bifunctor on +'Rel8.Table's that allows the mapping of a pair of 'Projection's over its +underlying columns. +-} type Biprojectable :: (Type -> Type -> Type) -> Constraint class Biprojectable p where -- | Map a pair of 'Projection's over @p@. - biproject :: (Projecting a b, Projecting c d) - => Projection a b -> Projection c d -> p a c -> p b d + biproject :: + (Projecting a b, Projecting c d) => + Projection a b -> + Projection c d -> + p a c -> + p b d -apply :: Projecting a b - => Projection a b -> Columns a context -> Columns b context +apply :: + Projecting a b => + Projection a b -> + Columns a context -> + Columns b context apply f a = case toColumns (f fields) of bs -> htabulate $ \field -> case hfield bs field of Field field' -> hfield a field' diff --git a/src/Rel8/Table/Rel8able.hs b/src/Rel8/Table/Rel8able.hs index 79e01bbd..61d0144a 100644 --- a/src/Rel8/Table/Rel8able.hs +++ b/src/Rel8/Table/Rel8able.hs @@ -1,61 +1,71 @@ -{-# language CPP #-} -{-# language DataKinds #-} -{-# language FlexibleInstances #-} -{-# language MultiParamTypeClasses #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeApplications #-} -{-# language TypeFamilies #-} -{-# language TypeOperators #-} -{-# language UndecidableInstances #-} - -{-# options_ghc -fno-warn-orphans #-} - -module Rel8.Table.Rel8able - ( +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Rel8.Table.Rel8able ( ) where + -- base -#if __GLASGOW_HASKELL__ >= 904 -import Data.Type.Equality (type (~)) -#endif +import Data.Type.Equality.Compat import Prelude () -- rel8 -import Rel8.Expr ( Expr ) +import Rel8.Expr (Expr) +import Rel8.Generic.Rel8able ( + Algebra, + GColumns, + GFromExprs, + Rel8able, + gfromColumns, + gfromResult, + gtoColumns, + gtoResult, + ) import qualified Rel8.Kind.Algebra as K -import Rel8.Kind.Context ( Reifiable, contextSing ) -import Rel8.Generic.Rel8able - ( Rel8able, Algebra - , GColumns, gfromColumns, gtoColumns - , GFromExprs, gfromResult, gtoResult - ) +import Rel8.Kind.Context (Reifiable, contextSing) +import Rel8.Schema.HTable (HConstrainTable, hdicts) import qualified Rel8.Schema.Kind as K -import Rel8.Schema.HTable ( HConstrainTable, hdicts ) -import Rel8.Schema.Null ( Sql ) -import Rel8.Schema.Result ( Result ) -import Rel8.Table - ( Table, Columns, Context, fromColumns, toColumns - , FromExprs, fromResult, toResult - , Transpose - ) -import Rel8.Table.ADT ( ADT ) -import Rel8.Table.Eq ( EqTable, eqTable ) -import Rel8.Table.Ord ( OrdTable, ordTable ) -import Rel8.Table.Serialize ( ToExprs ) -import Rel8.Type.Eq ( DBEq ) -import Rel8.Type.Ord ( DBOrd ) +import Rel8.Schema.Null (Sql) +import Rel8.Schema.Result (Result) +import Rel8.Table ( + Columns, + Context, + FromExprs, + Table, + Transpose, + fromColumns, + fromResult, + toColumns, + toResult, + ) +import Rel8.Table.ADT (ADT) +import Rel8.Table.Eq (EqTable, eqTable) +import Rel8.Table.Ord (OrdTable, ordTable) +import Rel8.Table.Serialize (ToExprs) +import Rel8.Type.Eq (DBEq) +import Rel8.Type.Ord (DBOrd) -instance (Rel8able t, Reifiable context, context ~ context') => +instance + (Rel8able t, Reifiable context, context ~ context') => Table context' (t context) - where + where type Columns (t context) = GColumns t type Context (t context) = context type FromExprs (t context) = GFromExprs t type Transpose to (t context) = t to + fromColumns = gfromColumns contextSing toColumns = gtoColumns contextSing fromResult = gfromResult @t @@ -66,9 +76,9 @@ instance ( context ~ Expr , Rel8able t , HConstrainTable (Columns (t context)) (Sql DBEq) - ) - => EqTable (t context) - where + ) => + EqTable (t context) + where eqTable = hdicts @(Columns (t context)) @(Sql DBEq) @@ -77,18 +87,19 @@ instance , Rel8able t , HConstrainTable (Columns (t context)) (Sql DBEq) , HConstrainTable (Columns (t context)) (Sql DBOrd) - ) - => OrdTable (t context) - where + ) => + OrdTable (t context) + where ordTable = hdicts @(Columns (t context)) @(Sql DBOrd) instance - ( Rel8able t', t' ~ Choose (Algebra t) t + ( Rel8able t' + , t' ~ Choose (Algebra t) t , x ~ t' Expr , result ~ Result - ) - => ToExprs x (t result) + ) => + ToExprs x (t result) type Choose :: K.Algebra -> K.Rel8able -> K.Rel8able diff --git a/src/Rel8/Table/Serialize.hs b/src/Rel8/Table/Serialize.hs index cd746b1b..2bd7436b 100644 --- a/src/Rel8/Table/Serialize.hs +++ b/src/Rel8/Table/Serialize.hs @@ -1,47 +1,51 @@ -{-# language AllowAmbiguousTypes #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language FunctionalDependencies #-} -{-# language NamedFieldPuns #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeApplications #-} -{-# language TypeFamilies #-} -{-# language TypeOperators #-} -{-# language UndecidableInstances #-} - -module Rel8.Table.Serialize - ( Serializable, lit, litHTable, parse - , ToExprs - ) +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Rel8.Table.Serialize ( + Serializable, + lit, + litHTable, + parse, + ToExprs, +) where -- base -import Data.Functor.Identity ( Identity( Identity ) ) -import Data.Kind ( Constraint, Type ) -import Data.List.NonEmpty ( NonEmpty ) +import Data.Functor.Identity (Identity (Identity)) +import Data.Kind (Constraint, Type) +import Data.List.NonEmpty (NonEmpty) import Prelude -- hasql import qualified Hasql.Decoders as Hasql -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Expr.Serialize ( slitExpr, sparseValue ) -import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs ) -import Rel8.Schema.Null ( NotNull, Sql ) -import Rel8.Schema.Result ( Result ) -import Rel8.Schema.Spec ( Spec(..) ) -import Rel8.Table ( Table, fromColumns, FromExprs, fromResult, toResult ) -import Rel8.Type ( DBType ) +import Rel8.Expr (Expr) +import Rel8.Expr.Serialize (slitExpr, sparseValue) +import Rel8.Schema.HTable (HTable, hfield, hspecs, htabulate, htabulateA) +import Rel8.Schema.Null (NotNull, Sql) +import Rel8.Schema.Result (Result) +import Rel8.Schema.Spec (Spec (..)) +import Rel8.Table (FromExprs, Table, fromColumns, fromResult, toResult) +import Rel8.Type (DBType) -- semigroupoids -import Data.Functor.Apply ( WrappedApplicative(..) ) +import Data.Functor.Apply (WrappedApplicative (..)) --- | @ToExprs exprs a@ is evidence that the types @exprs@ and @a@ describe --- essentially the same type, but @exprs@ is in the 'Expr' context, and @a@ is --- a normal Haskell type. +{- | @ToExprs exprs a@ is evidence that the types @exprs@ and @a@ describe +essentially the same type, but @exprs@ is in the 'Expr' context, and @a@ is +a normal Haskell type. +-} type ToExprs :: Type -> Type -> Constraint class Table Expr exprs => ToExprs exprs a @@ -58,7 +62,8 @@ instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Expr x) (Maybe a) instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (Expr x) (NonEmpty a) -instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ (exprs1, exprs2)) => +instance + (ToExprs exprs1 a, ToExprs exprs2 b, x ~ (exprs1, exprs2)) => ToExprs x (a, b) @@ -67,8 +72,8 @@ instance , ToExprs exprs2 b , ToExprs exprs3 c , x ~ (exprs1, exprs2, exprs3) - ) - => ToExprs x (a, b, c) + ) => + ToExprs x (a, b, c) instance @@ -77,8 +82,8 @@ instance , ToExprs exprs3 c , ToExprs exprs4 d , x ~ (exprs1, exprs2, exprs3, exprs4) - ) - => ToExprs x (a, b, c, d) + ) => + ToExprs x (a, b, c, d) instance @@ -88,8 +93,8 @@ instance , ToExprs exprs4 d , ToExprs exprs5 e , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5) - ) - => ToExprs x (a, b, c, d, e) + ) => + ToExprs x (a, b, c, d, e) instance @@ -100,8 +105,8 @@ instance , ToExprs exprs5 e , ToExprs exprs6 f , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6) - ) - => ToExprs x (a, b, c, d, e, f) + ) => + ToExprs x (a, b, c, d, e, f) instance @@ -113,21 +118,25 @@ instance , ToExprs exprs6 f , ToExprs exprs7 g , x ~ (exprs1, exprs2, exprs3, exprs4, exprs5, exprs6, exprs7) - ) - => ToExprs x (a, b, c, d, e, f, g) + ) => + ToExprs x (a, b, c, d, e, f, g) --- | @Serializable@ witnesses the one-to-one correspondence between the type --- @sql@, which contains SQL expressions, and the type @haskell@, which --- contains the Haskell decoding of rows containing @sql@ SQL expressions. +{- | @Serializable@ witnesses the one-to-one correspondence between the type +@sql@, which contains SQL expressions, and the type @haskell@, which +contains the Haskell decoding of rows containing @sql@ SQL expressions. +-} type Serializable :: Type -> Type -> Constraint class (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a + + instance (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a --- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is --- capable of lifting single @Expr@s to full tables. +{- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is +capable of lifting single @Expr@s to full tables. +-} lit :: forall exprs a. Serializable exprs a => a -> exprs lit = fromColumns . litHTable . toResult @_ @exprs @@ -139,11 +148,11 @@ parse = fromResult @_ @exprs <$> parseHTable litHTable :: HTable t => t Result -> t Expr litHTable as = htabulate $ \field -> case hfield hspecs field of - Spec {nullity, info} -> case hfield as field of + Spec{nullity, info} -> case hfield as field of Identity value -> slitExpr nullity info value parseHTable :: HTable t => Hasql.Row (t Result) parseHTable = unwrapApplicative $ htabulateA $ \field -> WrapApplicative $ case hfield hspecs field of - Spec {nullity, info} -> Identity <$> sparseValue nullity info + Spec{nullity, info} -> Identity <$> sparseValue nullity info diff --git a/src/Rel8/Table/These.hs b/src/Rel8/Table/These.hs index 4c2bd2bd..f892b796 100644 --- a/src/Rel8/Table/These.hs +++ b/src/Rel8/Table/These.hs @@ -1,97 +1,112 @@ -{-# language DataKinds #-} -{-# language DeriveFunctor #-} -{-# language DerivingStrategies #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language MultiParamTypeClasses #-} -{-# language NamedFieldPuns #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language TupleSections #-} -{-# language TypeApplications #-} -{-# language TypeFamilies #-} -{-# language TypeOperators #-} -{-# language UndecidableInstances #-} - -{-# options_ghc -fno-warn-orphans #-} - -module Rel8.Table.These - ( TheseTable(..) - , theseTable, thisTable, thatTable, thoseTable - , isThisTable, isThatTable, isThoseTable - , hasHereTable, hasThereTable - , justHereTable, justThereTable - , alignMaybeTable - , aggregateTheseTable - , nameTheseTable - ) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Rel8.Table.These ( + TheseTable (..), + theseTable, + thisTable, + thatTable, + thoseTable, + isThisTable, + isThatTable, + isThoseTable, + hasHereTable, + hasThereTable, + justHereTable, + justThereTable, + alignMaybeTable, + aggregateTheseTable, + nameTheseTable, +) where -- base -import Data.Bifunctor ( Bifunctor, bimap ) -import Data.Kind ( Type ) -import Data.Maybe ( isJust ) -import Prelude hiding ( null, undefined ) +import Data.Bifunctor (Bifunctor, bimap) +import Data.Kind (Type) +import Data.Maybe (isJust) +import Prelude hiding (null, undefined) -- profunctors import Data.Profunctor (lmap) -- rel8 import Rel8.Aggregate (Aggregator', Aggregator1) -import Rel8.Expr ( Expr ) -import Rel8.Expr.Bool ( (&&.), (||.), boolExpr, not_ ) -import Rel8.Expr.Null ( null, isNonNull ) -import Rel8.Kind.Context ( Reifiable ) -import Rel8.Schema.Context.Nullify ( Nullifiable ) -import Rel8.Schema.Dict ( Dict( Dict ) ) -import Rel8.Schema.HTable.Label ( hlabel, hrelabel, hunlabel ) -import Rel8.Schema.HTable.Identity ( HIdentity(..) ) -import Rel8.Schema.HTable.Maybe ( HMaybeTable(..) ) -import Rel8.Schema.HTable.These ( HTheseTable(..) ) +import Rel8.Expr (Expr) +import Rel8.Expr.Bool (boolExpr, not_, (&&.), (||.)) +import Rel8.Expr.Null (isNonNull, null) +import Rel8.Kind.Context (Reifiable) +import Rel8.Schema.Context.Nullify (Nullifiable) +import Rel8.Schema.Dict (Dict (Dict)) +import Rel8.Schema.HTable.Identity (HIdentity (..)) +import Rel8.Schema.HTable.Label (hlabel, hrelabel, hunlabel) +import Rel8.Schema.HTable.Maybe (HMaybeTable (..)) +import Rel8.Schema.HTable.These (HTheseTable (..)) import qualified Rel8.Schema.Kind as K -import Rel8.Schema.Name ( Name ) -import Rel8.Table - ( Table, Columns, Context, fromColumns, toColumns - , FromExprs, fromResult, toResult - , Transpose - ) -import Rel8.Table.Eq ( EqTable, eqTable ) -import Rel8.Table.Maybe - ( MaybeTable(..) - , maybeTable, justTable, nothingTable - , isJustTable - , aggregateMaybeTable - , nameMaybeTable - ) -import Rel8.Table.Nullify ( Nullify, guard ) -import Rel8.Table.Ord ( OrdTable, ordTable ) -import Rel8.Table.Projection ( Biprojectable, Projectable, biproject, project ) -import Rel8.Table.Serialize ( ToExprs ) -import Rel8.Table.Undefined ( undefined ) -import Rel8.Type.Tag ( MaybeTag ) +import Rel8.Schema.Name (Name) +import Rel8.Table ( + Columns, + Context, + FromExprs, + Table, + Transpose, + fromColumns, + fromResult, + toColumns, + toResult, + ) +import Rel8.Table.Eq (EqTable, eqTable) +import Rel8.Table.Maybe ( + MaybeTable (..), + aggregateMaybeTable, + isJustTable, + justTable, + maybeTable, + nameMaybeTable, + nothingTable, + ) +import Rel8.Table.Nullify (Nullify, guard) +import Rel8.Table.Ord (OrdTable, ordTable) +import Rel8.Table.Projection (Biprojectable, Projectable, biproject, project) +import Rel8.Table.Serialize (ToExprs) +import Rel8.Table.Undefined (undefined) +import Rel8.Type.Tag (MaybeTag) -- semigroupoids -import Data.Functor.Apply ( Apply, (<.>) ) -import Data.Functor.Bind ( Bind, (>>-) ) +import Data.Functor.Apply (Apply, (<.>)) +import Data.Functor.Bind (Bind, (>>-)) -- these -import Data.These ( These( This, That, These ) ) -import Data.These.Combinators ( justHere, justThere ) +import Data.These (These (That, These, This)) +import Data.These.Combinators (justHere, justThere) --- | @TheseTable a b@ is a Rel8 table that contains either the table @a@, the --- table @b@, or both tables @a@ and @b@. You can construct @TheseTable@s using --- 'thisTable', 'thatTable' and 'thoseTable'. @TheseTable@s can be --- eliminated/pattern matched using 'theseTable'. --- --- @TheseTable@ is operationally the same as Haskell's 'These' type, but --- adapted to work with Rel8. +{- | @TheseTable a b@ is a Rel8 table that contains either the table @a@, the +table @b@, or both tables @a@ and @b@. You can construct @TheseTable@s using +'thisTable', 'thatTable' and 'thoseTable'. @TheseTable@s can be +eliminated/pattern matched using 'theseTable'. + +@TheseTable@ is operationally the same as Haskell's 'These' type, but +adapted to work with Rel8. +-} type TheseTable :: K.Context -> Type -> Type -> Type data TheseTable context a b = TheseTable { here :: MaybeTable context a , there :: MaybeTable context b } - deriving stock Functor + deriving stock (Functor) instance Biprojectable (TheseTable context) where @@ -106,89 +121,109 @@ instance Projectable (TheseTable context a) where project f (TheseTable a b) = TheseTable a (project f b) -instance (context ~ Expr, Table Expr a, Semigroup a) => +instance + (context ~ Expr, Table Expr a, Semigroup a) => Apply (TheseTable context a) - where - fs <.> as = TheseTable - { here = here fs <> here as - , there = there fs <.> there as - } + where + fs <.> as = + TheseTable + { here = here fs <> here as + , there = there fs <.> there as + } -instance (context ~ Expr, Table Expr a, Semigroup a) => +instance + (context ~ Expr, Table Expr a, Semigroup a) => Applicative (TheseTable context a) - where + where pure = thatTable (<*>) = (<.>) -instance (context ~ Expr, Table Expr a, Semigroup a) => +instance + (context ~ Expr, Table Expr a, Semigroup a) => Bind (TheseTable context a) - where + where TheseTable here1 ma >>- f = case ma >>- f' of - mtb -> TheseTable - { here = maybeTable here1 ((here1 <>) . fst) mtb - , there = snd <$> mtb - } + mtb -> + TheseTable + { here = maybeTable here1 ((here1 <>) . fst) mtb + , there = snd <$> mtb + } where f' a = case f a of TheseTable here2 mb -> (here2,) <$> mb -instance (context ~ Expr, Table Expr a, Semigroup a) => +instance + (context ~ Expr, Table Expr a, Semigroup a) => Monad (TheseTable context a) - where + where (>>=) = (>>-) -instance (context ~ Expr, Table Expr a, Table Expr b, Semigroup a, Semigroup b) => +instance + (context ~ Expr, Table Expr a, Table Expr b, Semigroup a, Semigroup b) => Semigroup (TheseTable context a b) - where - a <> b = TheseTable - { here = here a <> here b - , there = there a <> there b - } + where + a <> b = + TheseTable + { here = here a <> here b + , there = there a <> there b + } instance - ( Table context a, Table context b - , Reifiable context, context ~ context' - ) - => Table context' (TheseTable context a b) - where + ( Table context a + , Table context b + , Reifiable context + , context ~ context' + ) => + Table context' (TheseTable context a b) + where type Columns (TheseTable context a b) = HTheseTable (Columns a) (Columns b) type Context (TheseTable context a b) = Context a - type FromExprs (TheseTable context a b) = - These (FromExprs a) (FromExprs b) - type Transpose to (TheseTable context a b) = - TheseTable to (Transpose to a) (Transpose to b) - - toColumns TheseTable {here, there} = HTheseTable - { hhereTag = hlabel $ HIdentity $ tag here - , hhere = - hlabel $ guard (tag here) isJust isNonNull $ toColumns $ just here - , hthereTag = hlabel $ HIdentity $ tag there - , hthere = - hlabel $ guard (tag there) isJust isNonNull $ toColumns $ just there - } + type + FromExprs (TheseTable context a b) = + These (FromExprs a) (FromExprs b) + type + Transpose to (TheseTable context a b) = + TheseTable to (Transpose to a) (Transpose to b) + + + toColumns TheseTable{here, there} = + HTheseTable + { hhereTag = hlabel $ HIdentity $ tag here + , hhere = + hlabel $ guard (tag here) isJust isNonNull $ toColumns $ just here + , hthereTag = hlabel $ HIdentity $ tag there + , hthere = + hlabel $ guard (tag there) isJust isNonNull $ toColumns $ just there + } - fromColumns HTheseTable {hhereTag, hhere, hthereTag, hthere} = TheseTable - { here = MaybeTable - { tag = unHIdentity $ hunlabel hhereTag - , just = fromColumns $ hunlabel hhere - } - , there = MaybeTable - { tag = unHIdentity $ hunlabel hthereTag - , just = fromColumns $ hunlabel hthere - } - } - toResult tables = HTheseTable - { hhereTag = hrelabel hhereTag - , hhere = hrelabel hhere - , hthereTag = hrelabel hthereTag - , hthere = hrelabel hthere - } + fromColumns HTheseTable{hhereTag, hhere, hthereTag, hthere} = + TheseTable + { here = + MaybeTable + { tag = unHIdentity $ hunlabel hhereTag + , just = fromColumns $ hunlabel hhere + } + , there = + MaybeTable + { tag = unHIdentity $ hunlabel hthereTag + , just = fromColumns $ hunlabel hthere + } + } + + + toResult tables = + HTheseTable + { hhereTag = hrelabel hhereTag + , hhere = hrelabel hhere + , hthereTag = hrelabel hthereTag + , hthere = hrelabel hthere + } where HMaybeTable { htag = hhereTag @@ -199,7 +234,8 @@ instance , hjust = hthere } = toResult @_ @(MaybeTable context b) (justThere tables) - fromResult HTheseTable {hhereTag, hhere, hthereTag, hthere} = + + fromResult HTheseTable{hhereTag, hhere, hthereTag, hthere} = case (here, there) of (Just a, Nothing) -> This a (Nothing, Just b) -> That b @@ -208,96 +244,111 @@ instance where here = fromResult @_ @(MaybeTable context a) mhere there = fromResult @_ @(MaybeTable context b) mthere - mhere = HMaybeTable - { htag = hrelabel hhereTag - , hjust = hrelabel hhere - } - mthere = HMaybeTable - { htag = hrelabel hthereTag - , hjust = hrelabel hthere - } + mhere = + HMaybeTable + { htag = hrelabel hhereTag + , hjust = hrelabel hhere + } + mthere = + HMaybeTable + { htag = hrelabel hthereTag + , hjust = hrelabel hthere + } -instance (EqTable a, EqTable b, context ~ Expr) => +instance + (EqTable a, EqTable b, context ~ Expr) => EqTable (TheseTable context a b) - where - eqTable = HTheseTable - { hhereTag = hlabel (HIdentity Dict) - , hhere = hlabel (eqTable @(Nullify context a)) - , hthereTag = hlabel (HIdentity Dict) - , hthere = hlabel (eqTable @(Nullify context b)) - } + where + eqTable = + HTheseTable + { hhereTag = hlabel (HIdentity Dict) + , hhere = hlabel (eqTable @(Nullify context a)) + , hthereTag = hlabel (HIdentity Dict) + , hthere = hlabel (eqTable @(Nullify context b)) + } -instance (OrdTable a, OrdTable b, context ~ Expr) => +instance + (OrdTable a, OrdTable b, context ~ Expr) => OrdTable (TheseTable context a b) - where - ordTable = HTheseTable - { hhereTag = hlabel (HIdentity Dict) - , hhere = hlabel (ordTable @(Nullify context a)) - , hthereTag = hlabel (HIdentity Dict) - , hthere = hlabel (ordTable @(Nullify context b)) - } + where + ordTable = + HTheseTable + { hhereTag = hlabel (HIdentity Dict) + , hhere = hlabel (ordTable @(Nullify context a)) + , hthereTag = hlabel (HIdentity Dict) + , hthere = hlabel (ordTable @(Nullify context b)) + } -instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable Expr exprs1 exprs2) => +instance + (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable Expr exprs1 exprs2) => ToExprs x (These a b) --- | Test if a 'TheseTable' was constructed with 'thisTable'. --- --- Corresponds to 'Data.These.Combinators.isThis'. +{- | Test if a 'TheseTable' was constructed with 'thisTable'. + +Corresponds to 'Data.These.Combinators.isThis'. +-} isThisTable :: TheseTable Expr a b -> Expr Bool isThisTable a = hasHereTable a &&. not_ (hasThereTable a) --- | Test if a 'TheseTable' was constructed with 'thatTable'. --- --- Corresponds to 'Data.These.Combinators.isThat'. +{- | Test if a 'TheseTable' was constructed with 'thatTable'. + +Corresponds to 'Data.These.Combinators.isThat'. +-} isThatTable :: TheseTable Expr a b -> Expr Bool isThatTable a = not_ (hasHereTable a) &&. hasThereTable a --- | Test if a 'TheseTable' was constructed with 'thoseTable'. --- --- Corresponds to 'Data.These.Combinators.isThese'. +{- | Test if a 'TheseTable' was constructed with 'thoseTable'. + +Corresponds to 'Data.These.Combinators.isThese'. +-} isThoseTable :: TheseTable Expr a b -> Expr Bool isThoseTable a = hasHereTable a &&. hasThereTable a --- | Test if the @a@ side of @TheseTable a b@ is present. --- --- Corresponds to 'Data.These.Combinators.hasHere'. +{- | Test if the @a@ side of @TheseTable a b@ is present. + +Corresponds to 'Data.These.Combinators.hasHere'. +-} hasHereTable :: TheseTable Expr a b -> Expr Bool -hasHereTable TheseTable {here} = isJustTable here +hasHereTable TheseTable{here} = isJustTable here + +{- | Test if the @b@ table of @TheseTable a b@ is present. --- | Test if the @b@ table of @TheseTable a b@ is present. --- --- Corresponds to 'Data.These.Combinators.hasThere'. +Corresponds to 'Data.These.Combinators.hasThere'. +-} hasThereTable :: TheseTable Expr a b -> Expr Bool -hasThereTable TheseTable {there} = isJustTable there +hasThereTable TheseTable{there} = isJustTable there --- | Attempt to project out the @a@ table of a @TheseTable a b@. --- --- Corresponds to 'Data.These.Combinators.justHere'. +{- | Attempt to project out the @a@ table of a @TheseTable a b@. + +Corresponds to 'Data.These.Combinators.justHere'. +-} justHereTable :: TheseTable context a b -> MaybeTable context a justHereTable = here --- | Attempt to project out the @b@ table of a @TheseTable a b@. --- --- Corresponds to 'Data.These.Combinators.justThere'. +{- | Attempt to project out the @b@ table of a @TheseTable a b@. + +Corresponds to 'Data.These.Combinators.justThere'. +-} justThereTable :: TheseTable context a b -> MaybeTable context b justThereTable = there -- | Construct a @TheseTable@ from two 'MaybeTable's. -alignMaybeTable :: () - => MaybeTable Expr a - -> MaybeTable Expr b - -> MaybeTable Expr (TheseTable Expr a b) +alignMaybeTable :: + () => + MaybeTable Expr a -> + MaybeTable Expr b -> + MaybeTable Expr (TheseTable Expr a b) alignMaybeTable a b = MaybeTable tag (pure (TheseTable a b)) where tag = boolExpr null mempty (isJustTable a ||. isJustTable b) @@ -319,40 +370,49 @@ thoseTable a b = TheseTable (justTable a) (justTable b) -- | Pattern match on a 'TheseTable'. Corresponds to 'these'. -theseTable :: Table Expr c - => (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable Expr a b -> c -theseTable f g h TheseTable {here, there} = +theseTable :: + Table Expr c => + (a -> c) -> + (b -> c) -> + (a -> b -> c) -> + TheseTable Expr a b -> + c +theseTable f g h TheseTable{here, there} = maybeTable (maybeTable undefined f here) (\b -> maybeTable (g b) (`h` b) here) there --- | Lift a pair aggregators to operate on a 'TheseTable'. @thisTable@s, --- @thatTable@s are @thoseTable@s are grouped separately. -aggregateTheseTable :: () - => Aggregator' fold i a - -> Aggregator' fold' i' b - -> Aggregator1 (TheseTable Expr i i') (TheseTable Expr a b) +{- | Lift a pair aggregators to operate on a 'TheseTable'. @thisTable@s, +@thatTable@s are @thoseTable@s are grouped separately. +-} +aggregateTheseTable :: + () => + Aggregator' fold i a -> + Aggregator' fold' i' b -> + Aggregator1 (TheseTable Expr i i') (TheseTable Expr a b) aggregateTheseTable a b = TheseTable <$> lmap here (aggregateMaybeTable a) <*> lmap there (aggregateMaybeTable b) --- | Construct a 'TheseTable' in the 'Name' context. This can be useful if you --- have a 'TheseTable' that you are storing in a table and need to construct a --- 'TableSchema'. -nameTheseTable :: () - => Name (Maybe MaybeTag) - -- ^ The name of the column to track the presence of the @a@ table. - -> Name (Maybe MaybeTag) - -- ^ The name of the column to track the presence of the @b@ table. - -> a - -- ^ Names of the columns in the @a@ table. - -> b - -- ^ Names of the columns in the @b@ table. - -> TheseTable Name a b +{- | Construct a 'TheseTable' in the 'Name' context. This can be useful if you +have a 'TheseTable' that you are storing in a table and need to construct a +'TableSchema'. +-} +nameTheseTable :: + () => + -- | The name of the column to track the presence of the @a@ table. + Name (Maybe MaybeTag) -> + -- | The name of the column to track the presence of the @b@ table. + Name (Maybe MaybeTag) -> + -- | Names of the columns in the @a@ table. + a -> + -- | Names of the columns in the @b@ table. + b -> + TheseTable Name a b nameTheseTable here there a b = TheseTable { here = nameMaybeTable here a diff --git a/src/Rel8/Table/Transpose.hs b/src/Rel8/Table/Transpose.hs index 7efbbd61..c674153d 100644 --- a/src/Rel8/Table/Transpose.hs +++ b/src/Rel8/Table/Transpose.hs @@ -1,33 +1,32 @@ -{-# language CPP #-} -{-# language DataKinds #-} -{-# language FlexibleInstances #-} -{-# language FunctionalDependencies #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeFamilies #-} -{-# language TypeOperators #-} -{-# language UndecidableInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -module Rel8.Table.Transpose - ( Transposes - ) +module Rel8.Table.Transpose ( + Transposes, +) where -- base -import Data.Kind ( Constraint, Type ) -#if __GLASGOW_HASKELL__ >= 904 +import Data.Kind (Constraint, Type) import Data.Type.Equality (type (~)) -#endif import Prelude () -- rel8 import qualified Rel8.Schema.Kind as K -import Rel8.Table ( Table, Transpose, Congruent ) +import Rel8.Table (Congruent, Table, Transpose) --- | @'Transposes' from to a b@ means that @a@ and @b@ are 'Table's, in the --- @from@ and @to@ contexts respectively, which share the same underlying --- structure. In other words, @b@ is a version of @a@ transposed from the --- @from@ context to the @to@ context (and vice versa). +{- | @'Transposes' from to a b@ means that @a@ and @b@ are 'Table's, in the +@from@ and @to@ contexts respectively, which share the same underlying +structure. In other words, @b@ is a version of @a@ transposed from the +@from@ context to the @to@ context (and vice versa). +-} type Transposes :: K.Context -> K.Context -> Type -> Type -> Constraint class ( Table from a @@ -35,17 +34,19 @@ class , Congruent a b , b ~ Transpose to a , a ~ Transpose from b - ) - => Transposes from to a b + ) => + Transposes from to a b | a -> from , b -> to , a to -> b , b from -> a + + instance ( Table from a , Table to b , Congruent a b , b ~ Transpose to a , a ~ Transpose from b - ) - => Transposes from to a b + ) => + Transposes from to a b diff --git a/src/Rel8/Table/Undefined.hs b/src/Rel8/Table/Undefined.hs index 3e42ebd2..44f512d4 100644 --- a/src/Rel8/Table/Undefined.hs +++ b/src/Rel8/Table/Undefined.hs @@ -1,26 +1,26 @@ -{-# language FlexibleContexts #-} -{-# language NamedFieldPuns #-} -{-# language TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} -module Rel8.Table.Undefined - ( undefined - ) +module Rel8.Table.Undefined ( + undefined, +) where -- base -import Prelude hiding ( undefined ) +import Prelude hiding (undefined) -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Expr.Null ( snull, unsafeUnnullify ) -import Rel8.Schema.HTable ( htabulate, hfield, hspecs ) -import Rel8.Schema.Null ( Nullity( Null, NotNull ) ) -import Rel8.Schema.Spec ( Spec(..) ) -import Rel8.Table ( Table, fromColumns ) +import Rel8.Expr (Expr) +import Rel8.Expr.Null (snull, unsafeUnnullify) +import Rel8.Schema.HTable (hfield, hspecs, htabulate) +import Rel8.Schema.Null (Nullity (NotNull, Null)) +import Rel8.Schema.Spec (Spec (..)) +import Rel8.Table (Table, fromColumns) undefined :: Table Expr a => a undefined = fromColumns $ htabulate $ \field -> case hfield hspecs field of - Spec {nullity, info} -> case nullity of + Spec{nullity, info} -> case nullity of Null -> snull info NotNull -> unsafeUnnullify (snull info) diff --git a/src/Rel8/Table/Window.hs b/src/Rel8/Table/Window.hs index f2fa860f..35861217 100644 --- a/src/Rel8/Table/Window.hs +++ b/src/Rel8/Table/Window.hs @@ -1,8 +1,8 @@ -{-# language MonoLocalBinds #-} +{-# LANGUAGE MonoLocalBinds #-} -module Rel8.Table.Window - ( currentRow - ) +module Rel8.Table.Window ( + currentRow, +) where -- base diff --git a/src/Rel8/Tabulate.hs b/src/Rel8/Tabulate.hs index 82a8077c..143978f5 100644 --- a/src/Rel8/Tabulate.hs +++ b/src/Rel8/Tabulate.hs @@ -1,128 +1,133 @@ -{-# language FlexibleContexts #-} -{-# language MonoLocalBinds #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language TupleSections #-} -{-# language UndecidableInstances #-} - --- | "Rel8.Tabulate" provides an alternative API ('Tabulation') for writing --- queries that complements the main "Rel8" API ('Query'). - -module Rel8.Tabulate - ( - Tabulation - - -- * Interfacing with 'Query's - , fromQuery - , toQuery - , liftQuery - , through - , lookup - - -- * Aggregation and Ordering - , aggregate - , aggregate1 - , distinct - , order - - -- * Materialize - , materialize - - -- ** Magic 'Tabulation's - -- $magic - , count - , optional - , many - , some - , exists - , present - , absent - - -- * Natural joins - , align - , alignWith - , leftAlign - , leftAlignWith - , rightAlign - , rightAlignWith - , zip - , zipWith - , similarity - , difference - ) +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | "Rel8.Tabulate" provides an alternative API ('Tabulation') for writing +queries that complements the main "Rel8" API ('Query'). +-} +module Rel8.Tabulate ( + Tabulation, + + -- * Interfacing with 'Query's + fromQuery, + toQuery, + liftQuery, + through, + lookup, + + -- * Aggregation and Ordering + aggregate, + aggregate1, + distinct, + order, + + -- * Materialize + materialize, + + -- ** Magic 'Tabulation's + -- $magic + count, + optional, + many, + some, + exists, + present, + absent, + + -- * Natural joins + align, + alignWith, + leftAlign, + leftAlignWith, + rightAlign, + rightAlignWith, + zip, + zipWith, + similarity, + difference, +) where -- base -import Control.Applicative ( (<|>), empty, liftA2 ) -import Control.Monad ( liftM2 ) -import Data.Bifunctor ( Bifunctor, bimap, first, second ) -import Data.Foldable ( traverse_ ) -import Data.Function ( on ) -import Data.Functor.Contravariant ( Contravariant, (>$<), contramap ) -import Data.Int ( Int64 ) -import Data.Kind ( Type ) -import Data.Maybe ( fromJust, fromMaybe ) -import Prelude hiding ( lookup, zip, zipWith ) +import Control.Applicative (empty, liftA2, (<|>)) +import Control.Monad (liftM2) +import Data.Bifunctor (Bifunctor, bimap, first, second) +import Data.Foldable (traverse_) +import Data.Function (on) +import Data.Functor.Contravariant (Contravariant, contramap, (>$<)) +import Data.Int (Int64) +import Data.Kind (Type) +import Data.Maybe (fromJust, fromMaybe) +import Prelude hiding (lookup, zip, zipWith) -- bifunctors -import Data.Bifunctor.Clown ( Clown( Clown ), runClown ) +import Data.Bifunctor.Clown (Clown (Clown), runClown) -- comonad -import Control.Comonad ( extract ) +import Control.Comonad (extract) -- opaleye -import qualified Opaleye.Order as Opaleye ( orderBy, distinctOnExplicit ) - --- profunctors -import Data.Profunctor ( dimap, lmap ) +import qualified Opaleye.Order as Opaleye (distinctOnExplicit, orderBy) -- product-profunctors -import Data.Profunctor.Product - ( ProductProfunctor, (***!) - , SumProfunctor, (+++!) - ) +import Data.Profunctor.Product ( + ProductProfunctor, + SumProfunctor, + (***!), + (+++!), + ) import qualified Data.Profunctor.Product as PP +-- profunctors +import Data.Profunctor (dimap, lmap) + -- rel8 -import Rel8.Aggregate (Aggregator' (Aggregator), Aggregator, toAggregator1) +import Rel8.Aggregate (Aggregator, Aggregator' (Aggregator), toAggregator1) import Rel8.Aggregate.Fold (Fallback (Fallback)) -import Rel8.Expr ( Expr ) +import Rel8.Expr (Expr) import Rel8.Expr.Aggregate (countStar) -import Rel8.Expr.Bool ( true ) -import Rel8.Order ( Order( Order ) ) -import Rel8.Query ( Query ) +import Rel8.Expr.Bool (true) +import Rel8.Order (Order (Order)) +import Rel8.Query (Query) import qualified Rel8.Query.Aggregate as Q -import qualified Rel8.Query.Exists as Q ( exists, present, absent ) -import Rel8.Query.Filter ( where_ ) -import Rel8.Query.List ( catNonEmptyTable ) +import qualified Rel8.Query.Exists as Q (absent, exists, present) +import Rel8.Query.Filter (where_) +import Rel8.Query.List (catNonEmptyTable) import qualified Rel8.Query.Materialize as Q -import qualified Rel8.Query.Maybe as Q ( optional ) -import Rel8.Query.Opaleye ( mapOpaleye, unsafePeekQuery ) -import Rel8.Query.Rebind ( rebind ) -import Rel8.Query.These ( alignBy ) -import Rel8.Table ( Table, fromColumns, toColumns ) +import qualified Rel8.Query.Maybe as Q (optional) +import Rel8.Query.Opaleye (mapOpaleye, unsafePeekQuery) +import Rel8.Query.Rebind (rebind) +import Rel8.Query.These (alignBy) +import Rel8.Table (Table, fromColumns, toColumns) import Rel8.Table.Aggregate (groupBy, listAgg, nonEmptyAgg) -import Rel8.Table.Alternative - ( AltTable, (<|>:) - , AlternativeTable, emptyTable - ) +import Rel8.Table.Alternative ( + AltTable, + AlternativeTable, + emptyTable, + (<|>:), + ) import Rel8.Table.Eq (EqTable, (==:)) import Rel8.Table.List (ListTable) import Rel8.Table.Maybe (MaybeTable (MaybeTable), fromMaybeTable) import Rel8.Table.NonEmpty (NonEmptyTable) -import Rel8.Table.Opaleye ( unpackspec ) -import Rel8.Table.Ord ( OrdTable ) -import Rel8.Table.Order ( ascTable ) -import Rel8.Table.Projection - ( Biprojectable, biproject - , Projectable, project - , apply - ) -import Rel8.Table.These ( TheseTable( TheseTable ), theseTable ) +import Rel8.Table.Opaleye (unpackspec) +import Rel8.Table.Ord (OrdTable) +import Rel8.Table.Order (ascTable) +import Rel8.Table.Projection ( + Biprojectable, + Projectable, + apply, + biproject, + project, + ) +import Rel8.Table.These (TheseTable (TheseTable), theseTable) -- semigroupoids -import Data.Functor.Apply ( Apply, liftF2 ) -import Data.Functor.Bind ( Bind, (>>-) ) +import Data.Functor.Apply (Apply, liftF2) +import Data.Functor.Bind (Bind, (>>-)) type Key :: Type -> Type @@ -133,16 +138,21 @@ cat :: Table Expr k => Key k -> Query k cat = maybe emptyTable pure -key :: (ProductProfunctor p, SumProfunctor p) - => p a b -> p (Key a) (Key b) +key :: + (ProductProfunctor p, SumProfunctor p) => + p a b -> + p (Key a) (Key b) key a = dimap from to (PP.empty +++! a) where from = maybe (Left ()) Right to = either (const Nothing) Just -keyed :: (ProductProfunctor p, SumProfunctor p) - => p k l -> p a b -> p (Key k, a) (Key l, b) +keyed :: + (ProductProfunctor p, SumProfunctor p) => + p k l -> + p a b -> + p (Key k, a) (Key l, b) keyed k a = key k ***! a @@ -170,20 +180,21 @@ ensure :: Predicate k -> Key k -> Query () ensure (Predicate mp) = traverse_ (\k -> traverse_ (\p -> where_ (p k)) mp) --- | A @'Tabulation' k a@ is like a @'Query' a@, except that each row also --- has a key @k@ in addition to the value @a@. 'Tabulation's can be composed --- monadically just like 'Query's, but the resulting join is more like a --- @NATURAL JOIN@ (based on the common key column(s) @k@) than the --- @CROSS JOIN@ given by 'Query'. --- --- Another way to think of @'Tabulation' k a@ is as analogous to @Map k a@ in --- the same way @'Query' a@ is analogous to @[a]@. However, there's nothing --- stopping a 'Tabulation' from containing multiple rows with the same key, so --- technically @Map k (NonEmpty a)@ is more accurate. --- --- 'Tabulation's can be created from 'Query's with 'fromQuery' and 'liftQuery' --- and converted back to 'Query's with 'lookup' and 'toQuery' (though note the --- caveats that come with the latter). +{- | A @'Tabulation' k a@ is like a @'Query' a@, except that each row also +has a key @k@ in addition to the value @a@. 'Tabulation's can be composed +monadically just like 'Query's, but the resulting join is more like a +@NATURAL JOIN@ (based on the common key column(s) @k@) than the +@CROSS JOIN@ given by 'Query'. + +Another way to think of @'Tabulation' k a@ is as analogous to @Map k a@ in +the same way @'Query' a@ is analogous to @[a]@. However, there's nothing +stopping a 'Tabulation' from containing multiple rows with the same key, so +technically @Map k (NonEmpty a)@ is more accurate. + +'Tabulation's can be created from 'Query's with 'fromQuery' and 'liftQuery' +and converted back to 'Query's with 'lookup' and 'toQuery' (though note the +caveats that come with the latter). +-} type Tabulation :: Type -> Type -> Type newtype Tabulation k a = Tabulation (Predicate k -> Query (Key k, a)) @@ -208,8 +219,9 @@ instance Projectable (Tabulation k) where project f = fmap (fromColumns . apply f . toColumns) --- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<.>)@ is --- @intersectionWith (liftA2 (<*>))@ +{- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<.>)@ is +@intersectionWith (liftA2 (<*>))@ +-} instance EqTable k => Apply (Tabulation k) where liftF2 = liftA2 @@ -235,8 +247,9 @@ instance EqTable k => Monad (Tabulation k) where (>>=) = (>>-) --- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<|>:)@ is --- @unionWith (<>)@. +{- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<|>:)@ is +@unionWith (<>)@. +-} instance EqTable k => AltTable (Tabulation k) where tas <|>: tbs = do eas <- peek tas @@ -251,15 +264,14 @@ instance EqTable k => AlternativeTable (Tabulation k) where emptyTable = Tabulation $ const $ fmap (empty,) emptyTable --- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<>)@ is --- @unionWith (liftA2 (<>))@. -instance (EqTable k, Table Expr a, Semigroup a) => Semigroup (Tabulation k a) - where +{- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<>)@ is +@unionWith (liftA2 (<>))@. +-} +instance (EqTable k, Table Expr a, Semigroup a) => Semigroup (Tabulation k a) where (<>) = alignWith (theseTable id id (<>)) -instance (EqTable k, Table Expr a, Semigroup a) => Monoid (Tabulation k a) - where +instance (EqTable k, Table Expr a, Semigroup a) => Monoid (Tabulation k a) where mempty = emptyTable @@ -268,34 +280,35 @@ fromQuery :: Query (k, a) -> Tabulation k a fromQuery = Tabulation . const . fmap (first pure) --- | Convert a @'Tabulation' k a@ back into a 'Query' of key-value pairs. --- --- Note that the result of a 'toQuery' is undefined (will always return zero --- rows) on 'Tabulation's constructed with 'liftQuery' or 'pure'. So while --- @toQuery . fromQuery@ is always @id@, @fromQuery . toQuery@ is not. --- --- A safer, more predictable alternative to 'toQuery' is to use 'lookup' with --- an explicit set of keys: --- --- @ --- do --- k <- keys --- a <- lookup k tabulation --- pure (k, a) --- @ --- --- Having said that, in practice, most legitimate uses of 'Tabulation' will --- have a well-defined 'toQuery'. It would be possible in theory to encode --- the necessary invariants at the type level using an indexed monad, but we --- would lose the ability to use @do@-notation, which is the main benefit --- of having 'Tabulation' as a monad in the first place. --- --- In particular, @'toQuery' t@ is well-defined for any 'Tabulation' @t@ --- defined as @t = fromQuery _@. @'toQuery' t@ is also well-defined for any --- 'Tabulation' @t@ defined as @t = t' >>= _@ or @t = t' *> _@ where --- @'toQuery' t'@ is well-defined. There are other valid permutations too. --- Generally, anything that uses 'fromQuery' at some point, unless wrapped in --- a top-level 'present' or 'absent', will have a well-defined 'toQuery'. +{- | Convert a @'Tabulation' k a@ back into a 'Query' of key-value pairs. + +Note that the result of a 'toQuery' is undefined (will always return zero +rows) on 'Tabulation's constructed with 'liftQuery' or 'pure'. So while +@toQuery . fromQuery@ is always @id@, @fromQuery . toQuery@ is not. + +A safer, more predictable alternative to 'toQuery' is to use 'lookup' with +an explicit set of keys: + +@ +do + k <- keys + a <- lookup k tabulation + pure (k, a) +@ + +Having said that, in practice, most legitimate uses of 'Tabulation' will +have a well-defined 'toQuery'. It would be possible in theory to encode +the necessary invariants at the type level using an indexed monad, but we +would lose the ability to use @do@-notation, which is the main benefit +of having 'Tabulation' as a monad in the first place. + +In particular, @'toQuery' t@ is well-defined for any 'Tabulation' @t@ +defined as @t = fromQuery _@. @'toQuery' t@ is also well-defined for any +'Tabulation' @t@ defined as @t = t' >>= _@ or @t = t' *> _@ where +@'toQuery' t'@ is well-defined. There are other valid permutations too. +Generally, anything that uses 'fromQuery' at some point, unless wrapped in +a top-level 'present' or 'absent', will have a well-defined 'toQuery'. +-} toQuery :: Table Expr k => Tabulation k a -> Query (k, a) toQuery (Tabulation f) = do (mk, a) <- f mempty @@ -303,23 +316,27 @@ toQuery (Tabulation f) = do pure (k, a) --- | A @'Query' a@ can be treated as a @'Tabulation' k a@ where the given @a@ --- values exist at every possible key @k@. +{- | A @'Query' a@ can be treated as a @'Tabulation' k a@ where the given @a@ +values exist at every possible key @k@. +-} liftQuery :: Query a -> Tabulation k a liftQuery = Tabulation . const . fmap (empty,) --- | Run a Kleisli arrow in the the 'Query' monad \"through\" a 'Tabulation'. --- Useful for 'Rel8.filter'ing a 'Tabulation'. --- --- @ --- 'Rel8.filter' ((>=. 30) . userAge) `'through'` usersById --- @ +{- | Run a Kleisli arrow in the the 'Query' monad \"through\" a 'Tabulation'. +Useful for 'Rel8.filter'ing a 'Tabulation'. + +@ +'Rel8.filter' ((>=. 30) . userAge) `'through'` usersById +@ +-} through :: (a -> Query b) -> Tabulation k a -> Tabulation k b through f (Tabulation as) = Tabulation $ \p -> do (k, a) <- as p b <- f a pure (k, b) + + infixr 1 `through` @@ -333,38 +350,49 @@ lookup k (Tabulation f) = do p = match (pure k) --- | 'aggregate' produces a \"magic\" 'Tabulation' whereby the values within --- each group of keys in the given 'Tabulation' is aggregated according to --- the given aggregator, and every other possible key contains a single --- \"fallback\" row is returned, composed of the identity elements of the --- constituent aggregation functions. -aggregate :: (EqTable k, Table Expr a) - => Aggregator i a -> Tabulation k i -> Tabulation k a +{- | 'aggregate' produces a \"magic\" 'Tabulation' whereby the values within +each group of keys in the given 'Tabulation' is aggregated according to +the given aggregator, and every other possible key contains a single +\"fallback\" row is returned, composed of the identity elements of the +constituent aggregation functions. +-} +aggregate :: + (EqTable k, Table Expr a) => + Aggregator i a -> + Tabulation k i -> + Tabulation k a aggregate aggregator@(Aggregator (Fallback fallback) _) = fmap (fromMaybeTable fallback) . optional . aggregate1 aggregator --- | 'aggregate1' aggregates the values within each key of a --- 'Tabulation'. There is an implicit @GROUP BY@ on all the key columns. -aggregate1 :: EqTable k - => Aggregator' fold i a -> Tabulation k i -> Tabulation k a +{- | 'aggregate1' aggregates the values within each key of a +'Tabulation'. There is an implicit @GROUP BY@ on all the key columns. +-} +aggregate1 :: + EqTable k => + Aggregator' fold i a -> + Tabulation k i -> + Tabulation k a aggregate1 aggregator (Tabulation f) = Tabulation $ Q.aggregate1 (keyed groupBy (toAggregator1 aggregator)) . f --- | 'distinct' ensures a 'Tabulation' has at most one value for --- each key, i.e., it drops duplicates. In general it keeps only the --- \"first\" value it encounters for each key, but note that \"first\" is --- undefined unless you first call 'order'. +{- | 'distinct' ensures a 'Tabulation' has at most one value for +each key, i.e., it drops duplicates. In general it keeps only the +\"first\" value it encounters for each key, but note that \"first\" is +undefined unless you first call 'order'. +-} distinct :: EqTable k => Tabulation k a -> Tabulation k a -distinct (Tabulation f) = Tabulation $ - mapOpaleye (Opaleye.distinctOnExplicit (key unpackspec) fst) . f +distinct (Tabulation f) = + Tabulation $ + mapOpaleye (Opaleye.distinctOnExplicit (key unpackspec) fst) . f --- | 'order' orders the /values/ of a 'Tabulation' within their --- respective keys. This specifies a defined order for 'distinct'. --- It also defines the order of the lists produced by 'many' and --- 'some'. +{- | 'order' orders the /values/ of a 'Tabulation' within their +respective keys. This specifies a defined order for 'distinct'. +It also defines the order of the lists produced by 'many' and +'some'. +-} order :: OrdTable k => Order a -> Tabulation k a -> Tabulation k a order ordering (Tabulation f) = Tabulation $ mapOpaleye (Opaleye.orderBy ordering') . f @@ -372,58 +400,61 @@ order ordering (Tabulation f) = Order ordering' = runClown (keyed (Clown ascTable) (Clown ordering)) --- $magic --- --- Some of the following combinators produce \"magic\" 'Tabulation's. Let's --- use 'count' as an example to demonstrate this concept. Consider --- the following: --- --- @ --- count $ fromQuery $ values --- [ (lit 'a', lit True) --- , (lit 'a', lit False) --- , (lit 'b', lit True) --- ] --- @ --- --- You might expect this to be equivalent to the following 'Tabulation': --- --- @ --- fromQuery $ values --- [ (lit 'a', 2) --- , (lit 'b', 1) --- ] --- @ --- --- However, it isn't quite. While the resulting 'Tabulation' does effectively --- contain the above entries, it also behaves as though it contained the value --- @0@ at every other possible key. --- --- This means you can do: --- --- @ --- do --- user <- usersById --- orderCount <- count ordersByUserId --- @ --- --- To see how many orders a user has (getting @0@ if they have no orders). - - --- | 'count' returns a count of how many entries are in the given --- 'Tabulation' at each key. --- --- The resulting 'Tabulation' is \"magic\" in that the value @0@ exists at --- every possible key that wasn't in the given 'Tabulation'. +{- $magic + +Some of the following combinators produce \"magic\" 'Tabulation's. Let's +use 'count' as an example to demonstrate this concept. Consider +the following: + +@ +count $ fromQuery $ values + [ (lit 'a', lit True) + , (lit 'a', lit False) + , (lit 'b', lit True) + ] +@ + +You might expect this to be equivalent to the following 'Tabulation': + +@ +fromQuery $ values + [ (lit 'a', 2) + , (lit 'b', 1) + ] +@ + +However, it isn't quite. While the resulting 'Tabulation' does effectively +contain the above entries, it also behaves as though it contained the value +@0@ at every other possible key. + +This means you can do: + +@ +do + user <- usersById + orderCount <- count ordersByUserId +@ + +To see how many orders a user has (getting @0@ if they have no orders). +-} + + +{- | 'count' returns a count of how many entries are in the given +'Tabulation' at each key. + +The resulting 'Tabulation' is \"magic\" in that the value @0@ exists at +every possible key that wasn't in the given 'Tabulation'. +-} count :: EqTable k => Tabulation k a -> Tabulation k (Expr Int64) count = aggregate countStar --- | 'optional' produces a \"magic\" 'Tabulation' whereby each --- entry in the given 'Tabulation' is wrapped in 'Rel8.justTable', and every --- other possible key contains a single 'Rel8.nothingTable'. --- --- This is used to implement 'leftAlignWith'. +{- | 'optional' produces a \"magic\" 'Tabulation' whereby each +entry in the given 'Tabulation' is wrapped in 'Rel8.justTable', and every +other possible key contains a single 'Rel8.nothingTable'. + +This is used to implement 'leftAlignWith'. +-} optional :: Tabulation k a -> Tabulation k (MaybeTable Expr a) optional (Tabulation f) = Tabulation $ \p -> case p of Predicate Nothing -> fmap pure <$> f p @@ -433,31 +464,38 @@ optional (Tabulation f) = Tabulation $ \p -> case p of pure (k, a) --- | 'many' aggregates each entry with a particular key into a --- single entry with all of the values contained in a 'ListTable'. --- --- 'order' can be used to give this 'ListTable' a defined order. --- --- The resulting 'Tabulation' is \"magic\" in that the value --- @'Rel8.listTable []'@ exists at every possible key that wasn't in the given --- 'Tabulation'. -many :: (EqTable k, Table Expr a) - => Tabulation k a -> Tabulation k (ListTable Expr a) +{- | 'many' aggregates each entry with a particular key into a +single entry with all of the values contained in a 'ListTable'. + +'order' can be used to give this 'ListTable' a defined order. + +The resulting 'Tabulation' is \"magic\" in that the value +@'Rel8.listTable []'@ exists at every possible key that wasn't in the given +'Tabulation'. +-} +many :: + (EqTable k, Table Expr a) => + Tabulation k a -> + Tabulation k (ListTable Expr a) many = aggregate listAgg --- | 'some' aggregates each entry with a particular key into a --- single entry with all of the values contained in a 'NonEmptyTable'. --- --- 'order' can be used to give this 'NonEmptyTable' a defined order. -some :: (EqTable k, Table Expr a) - => Tabulation k a -> Tabulation k (NonEmptyTable Expr a) +{- | 'some' aggregates each entry with a particular key into a +single entry with all of the values contained in a 'NonEmptyTable'. + +'order' can be used to give this 'NonEmptyTable' a defined order. +-} +some :: + (EqTable k, Table Expr a) => + Tabulation k a -> + Tabulation k (NonEmptyTable Expr a) some = aggregate1 nonEmptyAgg --- | 'exists' produces a \"magic\" 'Tabulation' which contains the --- value 'Rel8.true' at each key in the given 'Tabulation', and the value --- 'Rel8.false' at every other possible key. +{- | 'exists' produces a \"magic\" 'Tabulation' which contains the +value 'Rel8.true' at each key in the given 'Tabulation', and the value +'Rel8.false' at every other possible key. +-} exists :: Tabulation k a -> Tabulation k (Expr Bool) exists (Tabulation f) = Tabulation $ \p -> case p of Predicate Nothing -> (true <$) <$> f p @@ -466,10 +504,11 @@ exists (Tabulation f) = Tabulation $ \p -> case p of ensure p k --- | 'present' produces a 'Tabulation' where a single @()@ row --- exists for every key that was present in the given 'Tabulation'. --- --- This is used to implement 'similarity'. +{- | 'present' produces a 'Tabulation' where a single @()@ row +exists for every key that was present in the given 'Tabulation'. + +This is used to implement 'similarity'. +-} present :: Tabulation k a -> Tabulation k () present (Tabulation f) = Tabulation $ \p -> do Q.present $ do @@ -478,10 +517,11 @@ present (Tabulation f) = Tabulation $ \p -> do pure (empty, ()) --- | 'absent' produces a 'Tabulation' where a single @()@ row exists --- at every possible key that absent from the given 'Tabulation'. --- --- This is used to implement 'difference'. +{- | 'absent' produces a 'Tabulation' where a single @()@ row exists +at every possible key that absent from the given 'Tabulation'. + +This is used to implement 'difference'. +-} absent :: Tabulation k a -> Tabulation k () absent (Tabulation f) = Tabulation $ \p -> do Q.absent $ do @@ -490,20 +530,28 @@ absent (Tabulation f) = Tabulation $ \p -> do pure (empty, ()) --- | Performs a @NATURAL FULL OUTER JOIN@ based on the common key columns. --- --- Analogous to 'Data.Semialign.align'. -align :: EqTable k - => Tabulation k a -> Tabulation k b -> Tabulation k (TheseTable Expr a b) +{- | Performs a @NATURAL FULL OUTER JOIN@ based on the common key columns. + +Analogous to 'Data.Semialign.align'. +-} +align :: + EqTable k => + Tabulation k a -> + Tabulation k b -> + Tabulation k (TheseTable Expr a b) align = alignWith id --- | Performs a @NATURAL FULL OUTER JOIN@ based on the common key columns. --- --- Analogous to 'Data.Semialign.alignWith'. -alignWith :: EqTable k - => (TheseTable Expr a b -> c) - -> Tabulation k a -> Tabulation k b -> Tabulation k c +{- | Performs a @NATURAL FULL OUTER JOIN@ based on the common key columns. + +Analogous to 'Data.Semialign.alignWith'. +-} +alignWith :: + EqTable k => + (TheseTable Expr a b -> c) -> + Tabulation k a -> + Tabulation k b -> + Tabulation k c alignWith f (Tabulation as) (Tabulation bs) = Tabulation $ \p -> do tkab <- liftF2 (alignBy condition) as bs p k <- traverse (rebind "key") $ recover $ bimap fst fst tkab @@ -521,115 +569,145 @@ alignWith f (Tabulation as) (Tabulation bs) = Tabulation $ \p -> do MaybeTable _ c -> pure (extract c) --- | Performs a @NATURAL LEFT OUTER JOIN@ based on the common key columns. --- --- Analogous to 'Data.Semialign.rpadZip'. --- --- Note that you can achieve the same effect with 'optional' and the --- 'Applicative' instance for 'Tabulation', i.e., this is just --- @\left right -> liftA2 (,) left (optional right). You can also --- use @do@-notation. -leftAlign :: EqTable k - => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable Expr b) +{- | Performs a @NATURAL LEFT OUTER JOIN@ based on the common key columns. + +Analogous to 'Data.Semialign.rpadZip'. + +Note that you can achieve the same effect with 'optional' and the +'Applicative' instance for 'Tabulation', i.e., this is just +@\left right -> liftA2 (,) left (optional right). You can also +use @do@-notation. +-} +leftAlign :: + EqTable k => + Tabulation k a -> + Tabulation k b -> + Tabulation k (a, MaybeTable Expr b) leftAlign = leftAlignWith (,) --- | Performs a @NATURAL LEFT OUTER JOIN@ based on the common key columns. --- --- Analogous to 'Data.Semialign.rpadZipWith'. --- --- Note that you can achieve the same effect with 'optional' and the --- 'Applicative' instance for 'Tabulation', i.e., this is just --- @\f left right -> liftA2 f left (optional right). You can also --- use @do@-notation. -leftAlignWith :: EqTable k - => (a -> MaybeTable Expr b -> c) - -> Tabulation k a -> Tabulation k b -> Tabulation k c +{- | Performs a @NATURAL LEFT OUTER JOIN@ based on the common key columns. + +Analogous to 'Data.Semialign.rpadZipWith'. + +Note that you can achieve the same effect with 'optional' and the +'Applicative' instance for 'Tabulation', i.e., this is just +@\f left right -> liftA2 f left (optional right). You can also +use @do@-notation. +-} +leftAlignWith :: + EqTable k => + (a -> MaybeTable Expr b -> c) -> + Tabulation k a -> + Tabulation k b -> + Tabulation k c leftAlignWith f left right = liftA2 f left (optional right) --- | Performs a @NATURAL RIGHT OUTER JOIN@ based on the common key columns. --- --- Analogous to 'Data.Semialign.lpadZip'. --- --- Note that you can achieve the same effect with 'optional' and the --- 'Applicative' instance for 'Tabulation', i.e., this is just --- @\left right -> liftA2 (flip (,)) right (optional left). You can --- also use @do@-notation. -rightAlign :: EqTable k - => Tabulation k a -> Tabulation k b -> Tabulation k (MaybeTable Expr a, b) +{- | Performs a @NATURAL RIGHT OUTER JOIN@ based on the common key columns. + +Analogous to 'Data.Semialign.lpadZip'. + +Note that you can achieve the same effect with 'optional' and the +'Applicative' instance for 'Tabulation', i.e., this is just +@\left right -> liftA2 (flip (,)) right (optional left). You can +also use @do@-notation. +-} +rightAlign :: + EqTable k => + Tabulation k a -> + Tabulation k b -> + Tabulation k (MaybeTable Expr a, b) rightAlign = rightAlignWith (,) --- | Performs a @NATURAL RIGHT OUTER JOIN@ based on the common key columns. --- --- Analogous to 'Data.Semialign.lpadZipWith'. --- --- Note that you can achieve the same effect with 'optional' and the --- 'Applicative' instance for 'Tabulation', i.e., this is just --- @\f left right -> liftA2 (flip f) right (optional left). You can --- also use @do@-notation. -rightAlignWith :: EqTable k - => (MaybeTable Expr a -> b -> c) - -> Tabulation k a -> Tabulation k b -> Tabulation k c +{- | Performs a @NATURAL RIGHT OUTER JOIN@ based on the common key columns. + +Analogous to 'Data.Semialign.lpadZipWith'. + +Note that you can achieve the same effect with 'optional' and the +'Applicative' instance for 'Tabulation', i.e., this is just +@\f left right -> liftA2 (flip f) right (optional left). You can +also use @do@-notation. +-} +rightAlignWith :: + EqTable k => + (MaybeTable Expr a -> b -> c) -> + Tabulation k a -> + Tabulation k b -> + Tabulation k c rightAlignWith f left right = liftA2 (flip f) right (optional left) --- | Performs a @NATURAL INNER JOIN@ based on the common key columns. --- --- Analagous to 'Data.Semialign.zip'. --- --- Note that you can achieve the same effect with the 'Applicative' instance --- of 'Tabulation', i.e., this is just @'liftA2 (,)'@. You can also use --- @do@-notation. -zip :: EqTable k - => Tabulation k a -> Tabulation k b -> Tabulation k (a, b) +{- | Performs a @NATURAL INNER JOIN@ based on the common key columns. + +Analagous to 'Data.Semialign.zip'. + +Note that you can achieve the same effect with the 'Applicative' instance +of 'Tabulation', i.e., this is just @'liftA2 (,)'@. You can also use +@do@-notation. +-} +zip :: + EqTable k => + Tabulation k a -> + Tabulation k b -> + Tabulation k (a, b) zip = zipWith (,) --- | Performs a @NATURAL INNER JOIN@ based on the common key columns. --- --- Analagous to 'Data.Semialign.zipWith'. --- --- Note that you can achieve the same effect with the 'Applicative' instance --- of 'Tabulation', i.e., this is just @'liftA2'@. You can also use --- @do@-notation. -zipWith :: EqTable k - => (a -> b -> c) -> Tabulation k a -> Tabulation k b -> Tabulation k c +{- | Performs a @NATURAL INNER JOIN@ based on the common key columns. + +Analagous to 'Data.Semialign.zipWith'. + +Note that you can achieve the same effect with the 'Applicative' instance +of 'Tabulation', i.e., this is just @'liftA2'@. You can also use +@do@-notation. +-} +zipWith :: + EqTable k => + (a -> b -> c) -> + Tabulation k a -> + Tabulation k b -> + Tabulation k c zipWith = liftA2 --- | Performs a [@NATURAL SEMI JOIN@](https://en.wikipedia.org/wiki/Relational_algebra#Semijoin_%28%E2%8B%89%29%28%E2%8B%8A%29) --- based on the common key columns. --- --- The result is a subset of the left tabulation where only entries which have --- a corresponding entry in the right tabulation are kept. --- --- Note that you can achieve a similar effect with 'present' and the --- 'Applicative' instance of 'Tabulation', i.e., this is just --- @\left right -> left <* present right@. You can also use --- @do@-notation. +{- | Performs a [@NATURAL SEMI JOIN@](https://en.wikipedia.org/wiki/Relational_algebra#Semijoin_%28%E2%8B%89%29%28%E2%8B%8A%29) +based on the common key columns. + +The result is a subset of the left tabulation where only entries which have +a corresponding entry in the right tabulation are kept. + +Note that you can achieve a similar effect with 'present' and the +'Applicative' instance of 'Tabulation', i.e., this is just +@\left right -> left <* present right@. You can also use +@do@-notation. +-} similarity :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a similarity a b = a <* present b --- | Performs a [@NATURAL ANTI JOIN@](https://en.wikipedia.org/wiki/Relational_algebra#Antijoin_%28%E2%96%B7%29) --- based on the common key columns. --- --- The result is a subset of the left tabulation where only entries which do --- not have a corresponding entry in the right tabulation are kept. --- --- Note that you can achieve a similar effect with 'absent' and the --- 'Applicative' instance of 'Tabulation', i.e., this is just --- @\left right -> left <* absent right@. You can also use --- @do@-notation. +{- | Performs a [@NATURAL ANTI JOIN@](https://en.wikipedia.org/wiki/Relational_algebra#Antijoin_%28%E2%96%B7%29) +based on the common key columns. + +The result is a subset of the left tabulation where only entries which do +not have a corresponding entry in the right tabulation are kept. + +Note that you can achieve a similar effect with 'absent' and the +'Applicative' instance of 'Tabulation', i.e., this is just +@\left right -> left <* absent right@. You can also use +@do@-notation. +-} difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a difference a b = a <* absent b -- | 'Q.materialize' for 'Tabulation's. -materialize :: (Table Expr k, Table Expr a) - => Tabulation k a -> (Tabulation k a -> Query b) -> Query b +materialize :: + (Table Expr k, Table Expr a) => + Tabulation k a -> + (Tabulation k a -> Query b) -> + Query b materialize tabulation f = case peek tabulation of Tabulation query -> do (_, equery) <- query mempty @@ -638,9 +716,10 @@ materialize tabulation f = case peek tabulation of Right kas -> Q.materialize kas (f . fromQuery) --- | 'Tabulation's can be produced with either 'fromQuery' or 'liftQuery', and --- in some cases we might want to treat these differently. 'peek' uses --- 'unsafePeekQuery' to determine which type of 'Tabulation' we have. +{- | 'Tabulation's can be produced with either 'fromQuery' or 'liftQuery', and +in some cases we might want to treat these differently. 'peek' uses +'unsafePeekQuery' to determine which type of 'Tabulation' we have. +-} peek :: Tabulation k a -> Tabulation k (Either (Query a) (Query (k, a))) peek (Tabulation f) = Tabulation $ \p -> pure $ (empty,) $ case unsafePeekQuery (f p) of diff --git a/src/Rel8/Type.hs b/src/Rel8/Type.hs index 43fd8398..1895424b 100644 --- a/src/Rel8/Type.hs +++ b/src/Rel8/Type.hs @@ -1,81 +1,83 @@ -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language MonoLocalBinds #-} -{-# language MultiWayIf #-} -{-# language StandaloneKindSignatures #-} -{-# language UndecidableInstances #-} - -module Rel8.Type - ( DBType (typeInformation) - ) +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UndecidableInstances #-} + +module Rel8.Type ( + DBType (typeInformation), +) where -- aeson -import Data.Aeson ( Value ) +import Data.Aeson (Value) import qualified Data.Aeson as Aeson -- base -import Data.Int ( Int16, Int32, Int64 ) -import Data.List.NonEmpty ( NonEmpty ) -import Data.Kind ( Constraint, Type ) +import Data.Int (Int16, Int32, Int64) +import Data.Kind (Constraint, Type) +import Data.List.NonEmpty (NonEmpty) import Prelude -- bytestring -import Data.ByteString ( ByteString ) -import qualified Data.ByteString.Lazy as Lazy ( ByteString ) -import qualified Data.ByteString.Lazy as ByteString ( fromStrict, toStrict ) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as ByteString (fromStrict, toStrict) +import qualified Data.ByteString.Lazy as Lazy (ByteString) -- case-insensitive -import Data.CaseInsensitive ( CI ) +import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI -- hasql import qualified Hasql.Decoders as Hasql +-- network-ip +import Network.IP.Addr (IP, NetAddr, printNetAddr) + -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye -import qualified Opaleye.Internal.HaskellDB.Sql.Default as Opaleye ( quote ) +import qualified Opaleye.Internal.HaskellDB.Sql.Default as Opaleye (quote) -- rel8 -import Rel8.Schema.Null ( NotNull, Sql, nullable ) -import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation ) -import Rel8.Type.Information ( TypeInformation(..), mapTypeInformation ) +import Rel8.Schema.Null (NotNull, Sql, nullable) +import Rel8.Type.Array (listTypeInformation, nonEmptyTypeInformation) +import Rel8.Type.Information (TypeInformation (..), mapTypeInformation) -- scientific -import Data.Scientific ( Scientific ) +import Data.Scientific (Scientific) -- text -import Data.Text ( Text ) +import Data.Text (Text) import qualified Data.Text as Text -import qualified Data.Text.Lazy as Lazy ( Text, unpack ) -import qualified Data.Text.Lazy as Text ( fromStrict, toStrict ) -import qualified Data.Text.Lazy.Encoding as Lazy ( decodeUtf8 ) +import qualified Data.Text.Lazy as Lazy (Text, unpack) +import qualified Data.Text.Lazy as Text (fromStrict, toStrict) +import qualified Data.Text.Lazy.Encoding as Lazy (decodeUtf8) -- time -import Data.Time.Calendar ( Day ) -import Data.Time.Clock ( UTCTime ) -import Data.Time.LocalTime - ( CalendarDiffTime( CalendarDiffTime ) - , LocalTime - , TimeOfDay - ) -import Data.Time.Format ( formatTime, defaultTimeLocale ) +import Data.Time.Calendar (Day) +import Data.Time.Clock (UTCTime) +import Data.Time.Format (defaultTimeLocale, formatTime) +import Data.Time.LocalTime ( + CalendarDiffTime (CalendarDiffTime), + LocalTime, + TimeOfDay, + ) -- uuid -import Data.UUID ( UUID ) +import Data.UUID (UUID) import qualified Data.UUID as UUID --- ip -import Network.IP.Addr (NetAddr, IP, printNetAddr) - --- | Haskell types that can be represented as expressions in a database. There --- should be an instance of @DBType@ for all column types in your database --- schema (e.g., @int@, @timestamptz@, etc). --- --- Rel8 comes with stock instances for most default types in PostgreSQL, so you --- should only need to derive instances of this class for custom database --- types, such as types defined in PostgreSQL extensions, or custom domain --- types. + +{- | Haskell types that can be represented as expressions in a database. There +should be an instance of @DBType@ for all column types in your database +schema (e.g., @int@, @timestamptz@, etc). + +Rel8 comes with stock instances for most default types in PostgreSQL, so you +should only need to derive instances of this class for custom database +types, such as types defined in PostgreSQL extensions, or custom domain +types. +-} type DBType :: Type -> Constraint class NotNull a => DBType a where typeInformation :: TypeInformation a @@ -83,146 +85,169 @@ class NotNull a => DBType a where -- | Corresponds to @bool@ instance DBType Bool where - typeInformation = TypeInformation - { encode = Opaleye.ConstExpr . Opaleye.BoolLit - , decode = Hasql.bool - , typeName = "bool" - } + typeInformation = + TypeInformation + { encode = Opaleye.ConstExpr . Opaleye.BoolLit + , decode = Hasql.bool + , typeName = "bool" + } -- | Corresponds to @char@ instance DBType Char where - typeInformation = TypeInformation - { encode = Opaleye.ConstExpr . Opaleye.StringLit . pure - , decode = Hasql.char - , typeName = "char" - } + typeInformation = + TypeInformation + { encode = Opaleye.ConstExpr . Opaleye.StringLit . pure + , decode = Hasql.char + , typeName = "char" + } -- | Corresponds to @int2@ instance DBType Int16 where - typeInformation = TypeInformation - { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger - , decode = Hasql.int2 - , typeName = "int2" - } + typeInformation = + TypeInformation + { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger + , decode = Hasql.int2 + , typeName = "int2" + } -- | Corresponds to @int4@ instance DBType Int32 where - typeInformation = TypeInformation - { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger - , decode = Hasql.int4 - , typeName = "int4" - } + typeInformation = + TypeInformation + { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger + , decode = Hasql.int4 + , typeName = "int4" + } -- | Corresponds to @int8@ instance DBType Int64 where - typeInformation = TypeInformation - { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger - , decode = Hasql.int8 - , typeName = "int8" - } + typeInformation = + TypeInformation + { encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger + , decode = Hasql.int8 + , typeName = "int8" + } -- | Corresponds to @float4@ instance DBType Float where - typeInformation = TypeInformation - { encode = \x -> Opaleye.ConstExpr - if | x == (1 / 0) -> Opaleye.OtherLit "'Infinity'" - | isNaN x -> Opaleye.OtherLit "'NaN'" - | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'" - | otherwise -> Opaleye.NumericLit $ realToFrac x - , decode = Hasql.float4 - , typeName = "float4" - } + typeInformation = + TypeInformation + { encode = \x -> + Opaleye.ConstExpr + if + | x == (1 / 0) -> Opaleye.OtherLit "'Infinity'" + | isNaN x -> Opaleye.OtherLit "'NaN'" + | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'" + | otherwise -> Opaleye.NumericLit $ realToFrac x + , decode = Hasql.float4 + , typeName = "float4" + } -- | Corresponds to @float8@ instance DBType Double where - typeInformation = TypeInformation - { encode = \x -> Opaleye.ConstExpr - if | x == (1 / 0) -> Opaleye.OtherLit "'Infinity'" - | isNaN x -> Opaleye.OtherLit "'NaN'" - | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'" - | otherwise -> Opaleye.NumericLit $ realToFrac x - , decode = Hasql.float8 - , typeName = "float8" - } + typeInformation = + TypeInformation + { encode = \x -> + Opaleye.ConstExpr + if + | x == (1 / 0) -> Opaleye.OtherLit "'Infinity'" + | isNaN x -> Opaleye.OtherLit "'NaN'" + | x == (-1 / 0) -> Opaleye.OtherLit "'-Infinity'" + | otherwise -> Opaleye.NumericLit $ realToFrac x + , decode = Hasql.float8 + , typeName = "float8" + } -- | Corresponds to @numeric@ instance DBType Scientific where - typeInformation = TypeInformation - { encode = Opaleye.ConstExpr . Opaleye.NumericLit - , decode = Hasql.numeric - , typeName = "numeric" - } + typeInformation = + TypeInformation + { encode = Opaleye.ConstExpr . Opaleye.NumericLit + , decode = Hasql.numeric + , typeName = "numeric" + } -- | Corresponds to @timestamptz@ instance DBType UTCTime where - typeInformation = TypeInformation - { encode = - Opaleye.ConstExpr . Opaleye.OtherLit . - formatTime defaultTimeLocale "'%FT%T%QZ'" - , decode = Hasql.timestamptz - , typeName = "timestamptz" - } + typeInformation = + TypeInformation + { encode = + Opaleye.ConstExpr + . Opaleye.OtherLit + . formatTime defaultTimeLocale "'%FT%T%QZ'" + , decode = Hasql.timestamptz + , typeName = "timestamptz" + } -- | Corresponds to @date@ instance DBType Day where - typeInformation = TypeInformation - { encode = - Opaleye.ConstExpr . Opaleye.OtherLit . - formatTime defaultTimeLocale "'%F'" - , decode = Hasql.date - , typeName = "date" - } + typeInformation = + TypeInformation + { encode = + Opaleye.ConstExpr + . Opaleye.OtherLit + . formatTime defaultTimeLocale "'%F'" + , decode = Hasql.date + , typeName = "date" + } -- | Corresponds to @timestamp@ instance DBType LocalTime where - typeInformation = TypeInformation - { encode = - Opaleye.ConstExpr . Opaleye.OtherLit . - formatTime defaultTimeLocale "'%FT%T%Q'" - , decode = Hasql.timestamp - , typeName = "timestamp" - } + typeInformation = + TypeInformation + { encode = + Opaleye.ConstExpr + . Opaleye.OtherLit + . formatTime defaultTimeLocale "'%FT%T%Q'" + , decode = Hasql.timestamp + , typeName = "timestamp" + } -- | Corresponds to @time@ instance DBType TimeOfDay where - typeInformation = TypeInformation - { encode = - Opaleye.ConstExpr . Opaleye.OtherLit . - formatTime defaultTimeLocale "'%T%Q'" - , decode = Hasql.time - , typeName = "time" - } + typeInformation = + TypeInformation + { encode = + Opaleye.ConstExpr + . Opaleye.OtherLit + . formatTime defaultTimeLocale "'%T%Q'" + , decode = Hasql.time + , typeName = "time" + } -- | Corresponds to @interval@ instance DBType CalendarDiffTime where - typeInformation = TypeInformation - { encode = - Opaleye.ConstExpr . Opaleye.OtherLit . - formatTime defaultTimeLocale "'%bmon %0Es'" - , decode = CalendarDiffTime 0 . realToFrac <$> Hasql.interval - , typeName = "interval" - } + typeInformation = + TypeInformation + { encode = + Opaleye.ConstExpr + . Opaleye.OtherLit + . formatTime defaultTimeLocale "'%bmon %0Es'" + , decode = CalendarDiffTime 0 . realToFrac <$> Hasql.interval + , typeName = "interval" + } -- | Corresponds to @text@ instance DBType Text where - typeInformation = TypeInformation - { encode = Opaleye.ConstExpr . Opaleye.StringLit . Text.unpack - , decode = Hasql.text - , typeName = "text" - } + typeInformation = + TypeInformation + { encode = Opaleye.ConstExpr . Opaleye.StringLit . Text.unpack + , decode = Hasql.text + , typeName = "text" + } -- | Corresponds to @text@ @@ -233,62 +258,80 @@ instance DBType Lazy.Text where -- | Corresponds to @citext@ instance DBType (CI Text) where - typeInformation = mapTypeInformation CI.mk CI.original typeInformation - { typeName = "citext" - } + typeInformation = + mapTypeInformation + CI.mk + CI.original + typeInformation + { typeName = "citext" + } -- | Corresponds to @citext@ instance DBType (CI Lazy.Text) where - typeInformation = mapTypeInformation CI.mk CI.original typeInformation - { typeName = "citext" - } + typeInformation = + mapTypeInformation + CI.mk + CI.original + typeInformation + { typeName = "citext" + } -- | Corresponds to @bytea@ instance DBType ByteString where - typeInformation = TypeInformation - { encode = Opaleye.ConstExpr . Opaleye.ByteStringLit - , decode = Hasql.bytea - , typeName = "bytea" - } + typeInformation = + TypeInformation + { encode = Opaleye.ConstExpr . Opaleye.ByteStringLit + , decode = Hasql.bytea + , typeName = "bytea" + } -- | Corresponds to @bytea@ instance DBType Lazy.ByteString where typeInformation = - mapTypeInformation ByteString.fromStrict ByteString.toStrict + mapTypeInformation + ByteString.fromStrict + ByteString.toStrict typeInformation -- | Corresponds to @uuid@ instance DBType UUID where - typeInformation = TypeInformation - { encode = Opaleye.ConstExpr . Opaleye.StringLit . UUID.toString - , decode = Hasql.uuid - , typeName = "uuid" - } + typeInformation = + TypeInformation + { encode = Opaleye.ConstExpr . Opaleye.StringLit . UUID.toString + , decode = Hasql.uuid + , typeName = "uuid" + } -- | Corresponds to @jsonb@ instance DBType Value where - typeInformation = TypeInformation - { encode = - Opaleye.ConstExpr . Opaleye.OtherLit . - Opaleye.quote . - Lazy.unpack . Lazy.decodeUtf8 . Aeson.encode - , decode = Hasql.jsonb - , typeName = "jsonb" - } + typeInformation = + TypeInformation + { encode = + Opaleye.ConstExpr + . Opaleye.OtherLit + . Opaleye.quote + . Lazy.unpack + . Lazy.decodeUtf8 + . Aeson.encode + , decode = Hasql.jsonb + , typeName = "jsonb" + } + -- | Corresponds to @inet@ instance DBType (NetAddr IP) where - typeInformation = TypeInformation - { encode = - Opaleye.ConstExpr . Opaleye.StringLit . printNetAddr - , decode = Hasql.inet - , typeName = "inet" - } + typeInformation = + TypeInformation + { encode = + Opaleye.ConstExpr . Opaleye.StringLit . printNetAddr + , decode = Hasql.inet + , typeName = "inet" + } instance Sql DBType a => DBType [a] where diff --git a/src/Rel8/Type/Array.hs b/src/Rel8/Type/Array.hs index e170bf1d..3189b777 100644 --- a/src/Rel8/Type/Array.hs +++ b/src/Rel8/Type/Array.hs @@ -1,21 +1,23 @@ -{-# language GADTs #-} -{-# language LambdaCase #-} -{-# language NamedFieldPuns #-} -{-# language OverloadedStrings #-} -{-# language TypeApplications #-} -{-# language ViewPatterns #-} - -module Rel8.Type.Array - ( array, encodeArrayElement, extractArrayElement - , listTypeInformation - , nonEmptyTypeInformation - ) +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +module Rel8.Type.Array ( + array, + encodeArrayElement, + extractArrayElement, + listTypeInformation, + nonEmptyTypeInformation, +) where -- base -import Data.Foldable ( toList ) -import Data.List.NonEmpty ( NonEmpty, nonEmpty ) -import Prelude hiding ( null, repeat, zipWith ) +import Data.Foldable (toList) +import Data.List.NonEmpty (NonEmpty, nonEmpty) +import Prelude hiding (null, repeat, zipWith) -- hasql import qualified Hasql.Decoders as Hasql @@ -24,23 +26,29 @@ import qualified Hasql.Decoders as Hasql import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye -- rel8 -import Rel8.Schema.Null ( Unnullify, Nullity( Null, NotNull ) ) -import Rel8.Type.Information ( TypeInformation(..), parseTypeInformation ) +import Rel8.Schema.Null (Nullity (NotNull, Null), Unnullify) +import Rel8.Type.Information (TypeInformation (..), parseTypeInformation) -array :: Foldable f - => TypeInformation a -> f Opaleye.PrimExpr -> Opaleye.PrimExpr +array :: + Foldable f => + TypeInformation a -> + f Opaleye.PrimExpr -> + Opaleye.PrimExpr array info = - Opaleye.CastExpr (arrayType info <> "[]") . - Opaleye.ArrayExpr . map (encodeArrayElement info) . toList -{-# INLINABLE array #-} - - -listTypeInformation :: () - => Nullity a - -> TypeInformation (Unnullify a) - -> TypeInformation [a] -listTypeInformation nullity info@TypeInformation {encode, decode} = + Opaleye.CastExpr (arrayType info <> "[]") + . Opaleye.ArrayExpr + . map (encodeArrayElement info) + . toList +{-# INLINEABLE array #-} + + +listTypeInformation :: + () => + Nullity a -> + TypeInformation (Unnullify a) -> + TypeInformation [a] +listTypeInformation nullity info@TypeInformation{encode, decode} = TypeInformation { decode = case nullity of Null -> @@ -49,21 +57,22 @@ listTypeInformation nullity info@TypeInformation {encode, decode} = Hasql.listArray (decodeArrayElement info (Hasql.nonNullable decode)) , encode = case nullity of Null -> - Opaleye.ArrayExpr . - fmap (encodeArrayElement info . maybe null encode) + Opaleye.ArrayExpr + . fmap (encodeArrayElement info . maybe null encode) NotNull -> - Opaleye.ArrayExpr . - fmap (encodeArrayElement info . encode) + Opaleye.ArrayExpr + . fmap (encodeArrayElement info . encode) , typeName = arrayType info <> "[]" } where null = Opaleye.ConstExpr Opaleye.NullLit -nonEmptyTypeInformation :: () - => Nullity a - -> TypeInformation (Unnullify a) - -> TypeInformation (NonEmpty a) +nonEmptyTypeInformation :: + () => + Nullity a -> + TypeInformation (Unnullify a) -> + TypeInformation (NonEmpty a) nonEmptyTypeInformation nullity = parseTypeInformation parse toList . listTypeInformation nullity where @@ -124,6 +133,6 @@ extractArrayElement info where unescape char a = Opaleye.FunExpr "replace" [a, pattern, replacement] - where - pattern = string [char, char] - replacement = string [char] + where + pattern = string [char, char] + replacement = string [char] diff --git a/src/Rel8/Type/Composite.hs b/src/Rel8/Type/Composite.hs index 3482e0b1..9f4e5279 100644 --- a/src/Rel8/Type/Composite.hs +++ b/src/Rel8/Type/Composite.hs @@ -1,27 +1,28 @@ -{-# language AllowAmbiguousTypes #-} -{-# language BlockArguments #-} -{-# language DataKinds #-} -{-# language FlexibleContexts #-} -{-# language GADTs #-} -{-# language NamedFieldPuns #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeApplications #-} -{-# language UndecidableInstances #-} -{-# language UndecidableSuperClasses #-} -{-# language ViewPatterns #-} - -module Rel8.Type.Composite - ( Composite( Composite ) - , DBComposite( compositeFields, compositeTypeName ) - , compose, decompose - ) +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# LANGUAGE ViewPatterns #-} + +module Rel8.Type.Composite ( + Composite (Composite), + DBComposite (compositeFields, compositeTypeName), + compose, + decompose, +) where -- base -import Data.Functor.Const ( Const( Const ), getConst ) -import Data.Functor.Identity ( Identity( Identity ) ) -import Data.Kind ( Constraint, Type ) +import Data.Functor.Const (Const (Const), getConst) +import Data.Functor.Identity (Identity (Identity)) +import Data.Kind (Constraint, Type) import Prelude -- hasql @@ -31,35 +32,36 @@ import qualified Hasql.Decoders as Hasql import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Expr.Opaleye ( castExpr, fromPrimExpr, toPrimExpr ) -import Rel8.Schema.HTable ( HTable, hfield, hspecs, htabulate, htabulateA ) -import Rel8.Schema.Name ( Name( Name ) ) -import Rel8.Schema.Null ( Nullity( Null, NotNull ) ) -import Rel8.Schema.Result ( Result ) -import Rel8.Schema.Spec ( Spec( Spec, nullity, info ) ) -import Rel8.Table ( fromColumns, toColumns, fromResult, toResult ) -import Rel8.Table.Eq ( EqTable ) -import Rel8.Table.HKD ( HKD, HKDable ) -import Rel8.Table.Ord ( OrdTable ) +import Rel8.Expr (Expr) +import Rel8.Expr.Opaleye (castExpr, fromPrimExpr, toPrimExpr) +import Rel8.Schema.HTable (HTable, hfield, hspecs, htabulate, htabulateA) +import Rel8.Schema.Name (Name (Name)) +import Rel8.Schema.Null (Nullity (NotNull, Null)) +import Rel8.Schema.Result (Result) +import Rel8.Schema.Spec (Spec (Spec, info, nullity)) +import Rel8.Table (fromColumns, fromResult, toColumns, toResult) +import Rel8.Table.Eq (EqTable) +import Rel8.Table.HKD (HKD, HKDable) +import Rel8.Table.Ord (OrdTable) import Rel8.Table.Rel8able () -import Rel8.Table.Serialize ( litHTable ) -import Rel8.Type ( DBType, typeInformation ) -import Rel8.Type.Eq ( DBEq ) -import Rel8.Type.Information ( TypeInformation(..) ) -import Rel8.Type.Ord ( DBOrd, DBMax, DBMin ) +import Rel8.Table.Serialize (litHTable) +import Rel8.Type (DBType, typeInformation) +import Rel8.Type.Eq (DBEq) +import Rel8.Type.Information (TypeInformation (..)) +import Rel8.Type.Ord (DBMax, DBMin, DBOrd) -- semigroupoids -import Data.Functor.Apply ( WrappedApplicative(..) ) +import Data.Functor.Apply (WrappedApplicative (..)) --- | A deriving-via helper type for column types that store a Haskell product --- type in a single Postgres column using a Postgres composite type. --- --- Note that this must map to a specific extant type in your database's schema --- (created with @CREATE TYPE@). Use 'DBComposite' to specify the name of this --- Postgres type and the names of the individual fields (for projecting with --- 'decompose'). +{- | A deriving-via helper type for column types that store a Haskell product +type in a single Postgres column using a Postgres composite type. + +Note that this must map to a specific extant type in your database's schema +(created with @CREATE TYPE@). Use 'DBComposite' to specify the name of this +Postgres type and the names of the individual fields (for projecting with +'decompose'). +-} type Composite :: Type -> Type newtype Composite a = Composite { unComposite :: a @@ -67,11 +69,12 @@ newtype Composite a = Composite instance DBComposite a => DBType (Composite a) where - typeInformation = TypeInformation - { decode = Hasql.composite (Composite . fromResult @_ @(HKD a Expr) <$> decoder) - , encode = encoder . litHTable . toResult @_ @(HKD a Expr) . unComposite - , typeName = compositeTypeName @a - } + typeInformation = + TypeInformation + { decode = Hasql.composite (Composite . fromResult @_ @(HKD a Expr) <$> decoder) + , encode = encoder . litHTable . toResult @_ @(HKD a Expr) . unComposite + , typeName = compositeTypeName @a + } instance (DBComposite a, EqTable (HKD a Expr)) => DBEq (Composite a) @@ -86,35 +89,39 @@ instance (DBComposite a, OrdTable (HKD a Expr)) => DBMax (Composite a) instance (DBComposite a, OrdTable (HKD a Expr)) => DBMin (Composite a) --- | 'DBComposite' is used to associate composite type metadata with a Haskell --- type. +{- | 'DBComposite' is used to associate composite type metadata with a Haskell +type. +-} type DBComposite :: Type -> Constraint class (DBType a, HKDable a) => DBComposite a where -- | The names of all fields in the composite type that @a@ maps to. compositeFields :: HKD a Name + -- | The name of the composite type that @a@ maps to. compositeTypeName :: String --- | Collapse a 'HKD' into a PostgreSQL composite type. --- --- 'HKD' values are represented in queries by having a column for each field in --- the corresponding Haskell type. 'compose' collapses these columns into a --- single column expression, by combining them into a PostgreSQL composite --- type. +{- | Collapse a 'HKD' into a PostgreSQL composite type. + +'HKD' values are represented in queries by having a column for each field in +the corresponding Haskell type. 'compose' collapses these columns into a +single column expression, by combining them into a PostgreSQL composite +type. +-} compose :: DBComposite a => HKD a Expr -> Expr a compose = castExpr . fromPrimExpr . encoder . toColumns --- | Expand a composite type into a 'HKD'. --- --- 'decompose' is the inverse of 'compose'. +{- | Expand a composite type into a 'HKD'. + +'decompose' is the inverse of 'compose'. +-} decompose :: forall a. DBComposite a => Expr a -> HKD a Expr decompose (toPrimExpr -> a) = fromColumns $ htabulate \field -> case hfield names field of Name name -> case hfield hspecs field of - Spec {} -> fromPrimExpr $ Opaleye.CompositeExpr a name + Spec{} -> fromPrimExpr $ Opaleye.CompositeExpr a name where names = toColumns (compositeFields @a) @@ -122,10 +129,12 @@ decompose (toPrimExpr -> a) = fromColumns $ htabulate \field -> decoder :: HTable t => Hasql.Composite (t Result) decoder = unwrapApplicative $ htabulateA \field -> case hfield hspecs field of - Spec {nullity, info} -> WrapApplicative $ Identity <$> - case nullity of - Null -> Hasql.field $ Hasql.nullable $ decode info - NotNull -> Hasql.field $ Hasql.nonNullable $ decode info + Spec{nullity, info} -> + WrapApplicative $ + Identity + <$> case nullity of + Null -> Hasql.field $ Hasql.nullable $ decode info + NotNull -> Hasql.field $ Hasql.nonNullable $ decode info encoder :: HTable t => t Expr -> Opaleye.PrimExpr diff --git a/src/Rel8/Type/Enum.hs b/src/Rel8/Type/Enum.hs index 3324079e..e2034ce2 100644 --- a/src/Rel8/Type/Enum.hs +++ b/src/Rel8/Type/Enum.hs @@ -1,35 +1,42 @@ -{-# language AllowAmbiguousTypes #-} -{-# language DataKinds #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language LambdaCase #-} -{-# language RankNTypes #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeApplications #-} -{-# language TypeFamilies #-} -{-# language TypeOperators #-} -{-# language UndecidableInstances #-} - -module Rel8.Type.Enum - ( Enum( Enum ) - , DBEnum( enumValue, enumTypeName ) - , Enumable - ) +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Rel8.Type.Enum ( + Enum (Enum), + DBEnum (enumValue, enumTypeName), + Enumable, +) where -- base -import Control.Applicative ( (<|>) ) -import Control.Arrow ( (&&&) ) -import Data.Kind ( Constraint, Type ) -import Data.Proxy ( Proxy( Proxy ) ) -import GHC.Generics - ( Generic, Rep, from, to - , (:+:)( L1, R1 ), M1( M1 ), U1( U1 ) - , D, C, Meta( MetaCons ) - ) -import GHC.TypeLits ( KnownSymbol, symbolVal ) -import Prelude hiding ( Enum ) +import Control.Applicative ((<|>)) +import Control.Arrow ((&&&)) +import Data.Kind (Constraint, Type) +import Data.Proxy (Proxy (Proxy)) +import GHC.Generics ( + C, + D, + Generic, + M1 (M1), + Meta (MetaCons), + Rep, + U1 (U1), + from, + to, + (:+:) (L1, R1), + ) +import GHC.TypeLits (KnownSymbol, symbolVal) +import Prelude hiding (Enum) -- hasql import qualified Hasql.Decoders as Hasql @@ -38,25 +45,26 @@ import qualified Hasql.Decoders as Hasql import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye -- rel8 -import Rel8.Type ( DBType, typeInformation ) -import Rel8.Type.Eq ( DBEq ) -import Rel8.Type.Information ( TypeInformation(..) ) -import Rel8.Type.Ord ( DBOrd, DBMax, DBMin ) +import Rel8.Type (DBType, typeInformation) +import Rel8.Type.Eq (DBEq) +import Rel8.Type.Information (TypeInformation (..)) +import Rel8.Type.Ord (DBMax, DBMin, DBOrd) -- text -import Data.Text ( pack ) - - --- | A deriving-via helper type for column types that store an \"enum\" type --- (in Haskell terms, a sum type where all constructors are nullary) using a --- Postgres @enum@ type. --- --- Note that this should map to a specific type in your database's schema --- (explicitly created with @CREATE TYPE ... AS ENUM@). Use 'DBEnum' to --- specify the name of this Postgres type and the names of the individual --- values. If left unspecified, the names of the values of the Postgres --- @enum@ are assumed to match exactly exactly the names of the constructors --- of the Haskell type (up to and including case sensitivity). +import Data.Text (pack) + + +{- | A deriving-via helper type for column types that store an \"enum\" type +(in Haskell terms, a sum type where all constructors are nullary) using a +Postgres @enum@ type. + +Note that this should map to a specific type in your database's schema +(explicitly created with @CREATE TYPE ... AS ENUM@). Use 'DBEnum' to +specify the name of this Postgres type and the names of the individual +values. If left unspecified, the names of the values of the Postgres +@enum@ are assumed to match exactly exactly the names of the constructors +of the Haskell type (up to and including case sensitivity). +-} type Enum :: Type -> Type newtype Enum a = Enum { unEnum :: a @@ -64,19 +72,20 @@ newtype Enum a = Enum instance DBEnum a => DBType (Enum a) where - typeInformation = TypeInformation - { decode = - Hasql.enum $ - flip lookup $ - map ((pack . enumValue &&& Enum) . to) $ - genumerate @(Rep a) - , encode = - Opaleye.ConstExpr . - Opaleye.StringLit . - enumValue @a . - unEnum - , typeName = enumTypeName @a - } + typeInformation = + TypeInformation + { decode = + Hasql.enum $ + flip lookup $ + map ((pack . enumValue &&& Enum) . to) $ + genumerate @(Rep a) + , encode = + Opaleye.ConstExpr + . Opaleye.StringLit + . enumValue @a + . unEnum + , typeName = enumTypeName @a + } instance DBEnum a => DBEq (Enum a) @@ -100,14 +109,18 @@ class (DBType a, Enumable a) => DBEnum a where enumValue :: a -> String enumValue = gshow @(Rep a) . from + -- | The name of the PostgreSQL @enum@ type that @a@ maps to. enumTypeName :: String --- | Types that are sum types, where each constructor is unary (that is, has no --- fields). +{- | Types that are sum types, where each constructor is unary (that is, has no +fields). +-} type Enumable :: Type -> Constraint class (Generic a, GEnumable (Rep a)) => Enumable a + + instance (Generic a, GEnumable (Rep a)) => Enumable a @@ -132,8 +145,8 @@ instance (GEnumable a, GEnumable b) => GEnumable (a :+: b) where instance ( meta ~ 'MetaCons name _fixity _isRecord , KnownSymbol name - ) - => GEnumable (M1 C meta U1) - where + ) => + GEnumable (M1 C meta U1) + where genumerate = [M1 U1] gshow (M1 U1) = symbolVal (Proxy @name) diff --git a/src/Rel8/Type/Eq.hs b/src/Rel8/Type/Eq.hs index 02e11273..9d00ee6b 100644 --- a/src/Rel8/Type/Eq.hs +++ b/src/Rel8/Type/Eq.hs @@ -1,54 +1,55 @@ -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language MonoLocalBinds #-} -{-# language MultiParamTypeClasses #-} -{-# language StandaloneKindSignatures #-} -{-# language UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UndecidableInstances #-} -module Rel8.Type.Eq - ( DBEq - ) +module Rel8.Type.Eq ( + DBEq, +) where -- aeson -import Data.Aeson ( Value ) +import Data.Aeson (Value) -- base -import Data.List.NonEmpty ( NonEmpty ) -import Data.Int ( Int16, Int32, Int64 ) -import Data.Kind ( Constraint, Type ) +import Data.Int (Int16, Int32, Int64) +import Data.Kind (Constraint, Type) +import Data.List.NonEmpty (NonEmpty) import Prelude -- bytestring -import Data.ByteString ( ByteString ) -import qualified Data.ByteString.Lazy as Lazy ( ByteString ) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as Lazy (ByteString) -- case-insensitive -import Data.CaseInsensitive ( CI ) +import Data.CaseInsensitive (CI) -- rel8 -import Rel8.Schema.Null ( Sql ) -import Rel8.Type ( DBType ) +import Rel8.Schema.Null (Sql) +import Rel8.Type (DBType) -- scientific -import Data.Scientific ( Scientific ) +import Data.Scientific (Scientific) -- text -import Data.Text ( Text ) -import qualified Data.Text.Lazy as Lazy ( Text ) +import Data.Text (Text) +import qualified Data.Text.Lazy as Lazy (Text) -- time -import Data.Time.Calendar ( Day ) -import Data.Time.Clock ( UTCTime ) -import Data.Time.LocalTime ( CalendarDiffTime, LocalTime, TimeOfDay ) +import Data.Time.Calendar (Day) +import Data.Time.Clock (UTCTime) +import Data.Time.LocalTime (CalendarDiffTime, LocalTime, TimeOfDay) -- uuid -import Data.UUID ( UUID ) +import Data.UUID (UUID) --- | Database types that can be compared for equality in queries. If a type is --- an instance of 'DBEq', it means we can compare expressions for equality --- using the SQL @=@ operator. +{- | Database types that can be compared for equality in queries. If a type is +an instance of 'DBEq', it means we can compare expressions for equality +using the SQL @=@ operator. +-} type DBEq :: Type -> Constraint class DBType a => DBEq a diff --git a/src/Rel8/Type/Information.hs b/src/Rel8/Type/Information.hs index 47651677..bc01374a 100644 --- a/src/Rel8/Type/Information.hs +++ b/src/Rel8/Type/Information.hs @@ -1,17 +1,17 @@ -{-# language GADTs #-} -{-# language NamedFieldPuns #-} -{-# language StandaloneKindSignatures #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE StandaloneKindSignatures #-} -module Rel8.Type.Information - ( TypeInformation(..) - , mapTypeInformation - , parseTypeInformation - ) +module Rel8.Type.Information ( + TypeInformation (..), + mapTypeInformation, + parseTypeInformation, +) where -- base -import Data.Bifunctor ( first ) -import Data.Kind ( Type ) +import Data.Bifunctor (first) +import Data.Kind (Type) import Prelude -- hasql @@ -24,42 +24,51 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye import qualified Data.Text as Text --- | @TypeInformation@ describes how to encode and decode a Haskell type to and --- from database queries. The @typeName@ is the name of the type in the --- database, which is used to accurately type literals. +{- | @TypeInformation@ describes how to encode and decode a Haskell type to and +from database queries. The @typeName@ is the name of the type in the +database, which is used to accurately type literals. +-} type TypeInformation :: Type -> Type data TypeInformation a = TypeInformation { encode :: a -> Opaleye.PrimExpr - -- ^ How to encode a single Haskell value as a SQL expression. + -- ^ How to encode a single Haskell value as a SQL expression. , decode :: Hasql.Value a - -- ^ How to deserialize a single result back to Haskell. + -- ^ How to deserialize a single result back to Haskell. , typeName :: String - -- ^ The name of the SQL type. + -- ^ The name of the SQL type. } --- | Simultaneously map over how a type is both encoded and decoded, while --- retaining the name of the type. This operation is useful if you want to --- essentially @newtype@ another 'Rel8.DBType'. --- --- The mapping is required to be total. If you have a partial mapping, see --- 'parseTypeInformation'. -mapTypeInformation :: () - => (a -> b) -> (b -> a) - -> TypeInformation a -> TypeInformation b +{- | Simultaneously map over how a type is both encoded and decoded, while +retaining the name of the type. This operation is useful if you want to +essentially @newtype@ another 'Rel8.DBType'. + +The mapping is required to be total. If you have a partial mapping, see +'parseTypeInformation'. +-} +mapTypeInformation :: + () => + (a -> b) -> + (b -> a) -> + TypeInformation a -> + TypeInformation b mapTypeInformation = parseTypeInformation . fmap pure --- | Apply a parser to 'TypeInformation'. --- --- This can be used if the data stored in the database should only be subset of --- a given 'TypeInformation'. The parser is applied when deserializing rows --- returned - the encoder assumes that the input data is already in the --- appropriate form. -parseTypeInformation :: () - => (a -> Either String b) -> (b -> a) - -> TypeInformation a -> TypeInformation b -parseTypeInformation to from TypeInformation {encode, decode, typeName} = +{- | Apply a parser to 'TypeInformation'. + +This can be used if the data stored in the database should only be subset of +a given 'TypeInformation'. The parser is applied when deserializing rows +returned - the encoder assumes that the input data is already in the +appropriate form. +-} +parseTypeInformation :: + () => + (a -> Either String b) -> + (b -> a) -> + TypeInformation a -> + TypeInformation b +parseTypeInformation to from TypeInformation{encode, decode, typeName} = TypeInformation { encode = encode . from , decode = Hasql.refine (first Text.pack . to) decode diff --git a/src/Rel8/Type/JSONBEncoded.hs b/src/Rel8/Type/JSONBEncoded.hs index 7530f0d5..7cf2ce46 100644 --- a/src/Rel8/Type/JSONBEncoded.hs +++ b/src/Rel8/Type/JSONBEncoded.hs @@ -1,35 +1,36 @@ -{-# language StandaloneKindSignatures #-} +{-# LANGUAGE StandaloneKindSignatures #-} -module Rel8.Type.JSONBEncoded ( JSONBEncoded(..) ) where +module Rel8.Type.JSONBEncoded (JSONBEncoded (..)) where -- aeson -import Data.Aeson ( FromJSON, ToJSON, parseJSON, toJSON ) -import Data.Aeson.Types ( parseEither ) +import Data.Aeson (FromJSON, ToJSON, parseJSON, toJSON) +import Data.Aeson.Types (parseEither) -- base -import Data.Bifunctor ( first ) -import Data.Kind ( Type ) +import Data.Bifunctor (first) +import Data.Kind (Type) import Prelude -- hasql import qualified Hasql.Decoders as Hasql -- rel8 -import Rel8.Type ( DBType(..) ) -import Rel8.Type.Information ( TypeInformation(..) ) +import Rel8.Type (DBType (..)) +import Rel8.Type.Information (TypeInformation (..)) -- text -import Data.Text ( pack ) +import Data.Text (pack) -- | Like 'Rel8.JSONEncoded', but works for @jsonb@ columns. type JSONBEncoded :: Type -> Type -newtype JSONBEncoded a = JSONBEncoded { fromJSONBEncoded :: a } +newtype JSONBEncoded a = JSONBEncoded {fromJSONBEncoded :: a} instance (FromJSON a, ToJSON a) => DBType (JSONBEncoded a) where - typeInformation = TypeInformation - { encode = encode typeInformation . toJSON . fromJSONBEncoded - , decode = Hasql.refine (first pack . fmap JSONBEncoded . parseEither parseJSON) Hasql.jsonb - , typeName = "jsonb" - } + typeInformation = + TypeInformation + { encode = encode typeInformation . toJSON . fromJSONBEncoded + , decode = Hasql.refine (first pack . fmap JSONBEncoded . parseEither parseJSON) Hasql.jsonb + , typeName = "jsonb" + } diff --git a/src/Rel8/Type/JSONEncoded.hs b/src/Rel8/Type/JSONEncoded.hs index 1681a05d..f2d0f8f8 100644 --- a/src/Rel8/Type/JSONEncoded.hs +++ b/src/Rel8/Type/JSONEncoded.hs @@ -1,25 +1,26 @@ -{-# language StandaloneKindSignatures #-} +{-# LANGUAGE StandaloneKindSignatures #-} -module Rel8.Type.JSONEncoded ( JSONEncoded(..) ) where +module Rel8.Type.JSONEncoded (JSONEncoded (..)) where -- aeson -import Data.Aeson ( FromJSON, ToJSON, parseJSON, toJSON ) -import Data.Aeson.Types ( parseEither ) +import Data.Aeson (FromJSON, ToJSON, parseJSON, toJSON) +import Data.Aeson.Types (parseEither) -- base -import Data.Kind ( Type ) +import Data.Kind (Type) import Prelude -- rel8 -import Rel8.Type ( DBType(..) ) -import Rel8.Type.Information ( parseTypeInformation ) +import Rel8.Type (DBType (..)) +import Rel8.Type.Information (parseTypeInformation) --- | A deriving-via helper type for column types that store a Haskell value --- using a JSON encoding described by @aeson@'s 'ToJSON' and 'FromJSON' type --- classes. +{- | A deriving-via helper type for column types that store a Haskell value +using a JSON encoding described by @aeson@'s 'ToJSON' and 'FromJSON' type +classes. +-} type JSONEncoded :: Type -> Type -newtype JSONEncoded a = JSONEncoded { fromJSONEncoded :: a } +newtype JSONEncoded a = JSONEncoded {fromJSONEncoded :: a} instance (FromJSON a, ToJSON a) => DBType (JSONEncoded a) where diff --git a/src/Rel8/Type/Monoid.hs b/src/Rel8/Type/Monoid.hs index d9623eac..be2fc31b 100644 --- a/src/Rel8/Type/Monoid.hs +++ b/src/Rel8/Type/Monoid.hs @@ -1,46 +1,47 @@ -{-# language DataKinds #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language MultiParamTypeClasses #-} -{-# language OverloadedStrings #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeFamilies #-} -{-# language UndecidableInstances #-} - -module Rel8.Type.Monoid - ( DBMonoid( memptyExpr ) - ) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Rel8.Type.Monoid ( + DBMonoid (memptyExpr), +) where -- base -import Data.Kind ( Constraint, Type ) -import Prelude hiding ( null ) +import Data.Kind (Constraint, Type) +import Prelude hiding (null) -- bytestring -import Data.ByteString ( ByteString ) -import qualified Data.ByteString.Lazy as Lazy ( ByteString ) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as Lazy (ByteString) -- case-insensitive -import Data.CaseInsensitive ( CI ) +import Data.CaseInsensitive (CI) -- rel8 -import {-# SOURCE #-} Rel8.Expr ( Expr ) -import Rel8.Expr.Array ( sempty ) -import Rel8.Expr.Serialize ( litExpr ) -import Rel8.Schema.Null ( Sql ) -import Rel8.Type ( DBType, typeInformation ) -import Rel8.Type.Semigroup ( DBSemigroup ) +import {-# SOURCE #-} Rel8.Expr (Expr) +import Rel8.Expr.Array (sempty) +import Rel8.Expr.Serialize (litExpr) +import Rel8.Schema.Null (Sql) +import Rel8.Type (DBType, typeInformation) +import Rel8.Type.Semigroup (DBSemigroup) -- text -import Data.Text ( Text ) -import qualified Data.Text.Lazy as Lazy ( Text ) +import Data.Text (Text) +import qualified Data.Text.Lazy as Lazy (Text) -- time -import Data.Time.LocalTime ( CalendarDiffTime( CalendarDiffTime ) ) +import Data.Time.LocalTime (CalendarDiffTime (CalendarDiffTime)) --- | The class of 'Rel8.DBType's that form a semigroup. This class is purely a --- Rel8 concept, and exists to mirror the 'Monoid' class. +{- | The class of 'Rel8.DBType's that form a semigroup. This class is purely a +Rel8 concept, and exists to mirror the 'Monoid' class. +-} type DBMonoid :: Type -> Constraint class DBSemigroup a => DBMonoid a where -- The identity for '<>.' diff --git a/src/Rel8/Type/Num.hs b/src/Rel8/Type/Num.hs index da13ef09..b9d0f4cf 100644 --- a/src/Rel8/Type/Num.hs +++ b/src/Rel8/Type/Num.hs @@ -1,33 +1,39 @@ -{-# language DataKinds #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language MultiParamTypeClasses #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeFamilies #-} -{-# language UndecidableInstances #-} - -module Rel8.Type.Num - ( DBNum, DBIntegral, DBFractional, DBFloating - ) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Rel8.Type.Num ( + DBNum, + DBIntegral, + DBFractional, + DBFloating, +) where -- base -import Data.Int ( Int16, Int32, Int64 ) -import Data.Kind ( Constraint, Type ) +import Data.Int (Int16, Int32, Int64) +import Data.Kind (Constraint, Type) import Prelude -- rel8 -import Rel8.Type ( DBType ) -import Rel8.Type.Ord ( DBOrd ) +import Rel8.Type (DBType) +import Rel8.Type.Ord (DBOrd) -- scientific -import Data.Scientific ( Scientific ) +import Data.Scientific (Scientific) --- | The class of database types that support the @+@, @*@, @-@ operators, and --- the @abs@, @negate@, @sign@ functions. +{- | The class of database types that support the @+@, @*@, @-@ operators, and +the @abs@, @negate@, @sign@ functions. +-} type DBNum :: Type -> Constraint class DBType a => DBNum a + + instance DBNum Int16 instance DBNum Int32 instance DBNum Int64 @@ -36,11 +42,14 @@ instance DBNum Double instance DBNum Scientific --- | The class of database types that can be coerced to from integral --- expressions. This is a Rel8 concept, and allows us to provide --- 'fromIntegral'. +{- | The class of database types that can be coerced to from integral +expressions. This is a Rel8 concept, and allows us to provide +'fromIntegral'. +-} type DBIntegral :: Type -> Constraint class (DBNum a, DBOrd a) => DBIntegral a + + instance DBIntegral Int16 instance DBIntegral Int32 instance DBIntegral Int64 @@ -49,6 +58,8 @@ instance DBIntegral Int64 -- | The class of database types that support the @/@ operator. type DBFractional :: Type -> Constraint class DBNum a => DBFractional a + + instance DBFractional Float instance DBFractional Double instance DBFractional Scientific @@ -57,5 +68,7 @@ instance DBFractional Scientific -- | The class of database types that support the @/@ operator. type DBFloating :: Type -> Constraint class DBFractional a => DBFloating a + + instance DBFloating Float instance DBFloating Double diff --git a/src/Rel8/Type/Ord.hs b/src/Rel8/Type/Ord.hs index a89c40fa..04c485cf 100644 --- a/src/Rel8/Type/Ord.hs +++ b/src/Rel8/Type/Ord.hs @@ -1,53 +1,57 @@ -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language MonoLocalBinds #-} -{-# language MultiParamTypeClasses #-} -{-# language StandaloneKindSignatures #-} -{-# language UndecidableInstances #-} - -module Rel8.Type.Ord - ( DBOrd - , DBMax, DBMin - ) +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UndecidableInstances #-} + +module Rel8.Type.Ord ( + DBOrd, + DBMax, + DBMin, +) where -- base -import Data.Int ( Int16, Int32, Int64 ) -import Data.Kind ( Constraint, Type ) -import Data.List.NonEmpty ( NonEmpty ) +import Data.Int (Int16, Int32, Int64) +import Data.Kind (Constraint, Type) +import Data.List.NonEmpty (NonEmpty) import Prelude -- bytestring -import Data.ByteString ( ByteString ) -import qualified Data.ByteString.Lazy as Lazy ( ByteString ) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as Lazy (ByteString) -- case-insensitive -import Data.CaseInsensitive ( CI ) +import Data.CaseInsensitive (CI) -- rel8 -import Rel8.Schema.Null ( Sql ) -import Rel8.Type.Eq ( DBEq ) +import Rel8.Schema.Null (Sql) +import Rel8.Type.Eq (DBEq) -- scientific -import Data.Scientific ( Scientific ) +import Data.Scientific (Scientific) -- text -import Data.Text ( Text ) -import qualified Data.Text.Lazy as Lazy ( Text ) +import Data.Text (Text) +import qualified Data.Text.Lazy as Lazy (Text) -- time -import Data.Time.Calendar ( Day ) -import Data.Time.Clock ( UTCTime ) -import Data.Time.LocalTime ( CalendarDiffTime, LocalTime, TimeOfDay ) +import Data.Time.Calendar (Day) +import Data.Time.Clock (UTCTime) +import Data.Time.LocalTime (CalendarDiffTime, LocalTime, TimeOfDay) -- uuid -import Data.UUID ( UUID ) +import Data.UUID (UUID) --- | The class of database types that support the @<@, @<=@, @>@ and @>=@ --- operators. +{- | The class of database types that support the @<@, @<=@, @>@ and @>=@ +operators. +-} type DBOrd :: Type -> Constraint class DBEq a => DBOrd a + + instance DBOrd Bool instance DBOrd Char instance DBOrd Int16 @@ -75,6 +79,8 @@ instance Sql DBOrd a => DBOrd (NonEmpty a) -- | The class of database types that support the @max@ aggregation function. type DBMax :: Type -> Constraint class DBOrd a => DBMax a + + instance DBMax Char instance DBMax Int16 instance DBMax Int32 @@ -100,6 +106,8 @@ instance Sql DBMax a => DBMax (NonEmpty a) -- | The class of database types that support the @min@ aggregation function. type DBMin :: Type -> Constraint class DBOrd a => DBMin a + + instance DBMin Char instance DBMin Int16 instance DBMin Int32 diff --git a/src/Rel8/Type/ReadShow.hs b/src/Rel8/Type/ReadShow.hs index a7f9d083..77a810a4 100644 --- a/src/Rel8/Type/ReadShow.hs +++ b/src/Rel8/Type/ReadShow.hs @@ -1,29 +1,30 @@ -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeApplications #-} -{-# language ViewPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} -module Rel8.Type.ReadShow ( ReadShow(..) ) where +module Rel8.Type.ReadShow (ReadShow (..)) where -- base -import Data.Kind ( Type ) -import Data.Proxy ( Proxy( Proxy ) ) -import Data.Typeable ( Typeable, typeRep ) -import Prelude -import Text.Read ( readMaybe ) +import Data.Kind (Type) +import Data.Proxy (Proxy (Proxy)) +import Data.Typeable (Typeable, typeRep) +import Prelude +import Text.Read (readMaybe) -- rel8 -import Rel8.Type ( DBType( typeInformation ) ) -import Rel8.Type.Information ( parseTypeInformation ) +import Rel8.Type (DBType (typeInformation)) +import Rel8.Type.Information (parseTypeInformation) -- text import qualified Data.Text as Text --- | A deriving-via helper type for column types that store a Haskell value --- using a Haskell's 'Read' and 'Show' type classes. +{- | A deriving-via helper type for column types that store a Haskell value +using a Haskell's 'Read' and 'Show' type classes. +-} type ReadShow :: Type -> Type -newtype ReadShow a = ReadShow { fromReadShow :: a } +newtype ReadShow a = ReadShow {fromReadShow :: a} instance (Read a, Show a, Typeable a) => DBType (ReadShow a) where diff --git a/src/Rel8/Type/Semigroup.hs b/src/Rel8/Type/Semigroup.hs index c76e8e45..a790c0d7 100644 --- a/src/Rel8/Type/Semigroup.hs +++ b/src/Rel8/Type/Semigroup.hs @@ -1,53 +1,56 @@ -{-# language BlockArguments #-} -{-# language DataKinds #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language MultiParamTypeClasses #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeFamilies #-} -{-# language UndecidableInstances #-} - -module Rel8.Type.Semigroup - ( DBSemigroup( (<>.)) - ) +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Rel8.Type.Semigroup ( + DBSemigroup ((<>.)), +) where -- base -import Data.Kind ( Constraint, Type ) -import Data.List.NonEmpty ( NonEmpty ) +import Data.Kind (Constraint, Type) +import Data.List.NonEmpty (NonEmpty) import Prelude () -- bytestring -import Data.ByteString ( ByteString ) -import qualified Data.ByteString.Lazy as Lazy ( ByteString ) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as Lazy (ByteString) -- case-insensitive -import Data.CaseInsensitive ( CI ) +import Data.CaseInsensitive (CI) -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye -- rel8 -import {-# SOURCE #-} Rel8.Expr ( Expr ) -import Rel8.Expr.Array ( sappend, sappend1 ) -import Rel8.Expr.Opaleye ( zipPrimExprsWith ) -import Rel8.Schema.Null ( Sql ) -import Rel8.Type ( DBType ) +import {-# SOURCE #-} Rel8.Expr (Expr) +import Rel8.Expr.Array (sappend, sappend1) +import Rel8.Expr.Opaleye (zipPrimExprsWith) +import Rel8.Schema.Null (Sql) +import Rel8.Type (DBType) -- text -import Data.Text ( Text ) -import qualified Data.Text.Lazy as Lazy ( Text ) +import Data.Text (Text) +import qualified Data.Text.Lazy as Lazy (Text) -- time -import Data.Time.LocalTime ( CalendarDiffTime ) +import Data.Time.LocalTime (CalendarDiffTime) --- | The class of 'Rel8.DBType's that form a semigroup. This class is purely a --- Rel8 concept, and exists to mirror the 'Semigroup' class. +{- | The class of 'Rel8.DBType's that form a semigroup. This class is purely a +Rel8 concept, and exists to mirror the 'Semigroup' class. +-} type DBSemigroup :: Type -> Constraint class DBType a => DBSemigroup a where -- | An associative operation. (<>.) :: Expr a -> Expr a -> Expr a + + infixr 6 <>. diff --git a/src/Rel8/Type/String.hs b/src/Rel8/Type/String.hs index 302022a3..8de90cfb 100644 --- a/src/Rel8/Type/String.hs +++ b/src/Rel8/Type/String.hs @@ -1,37 +1,40 @@ -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language MultiParamTypeClasses #-} -{-# language StandaloneKindSignatures #-} -{-# language UndecidableInstances #-} - -module Rel8.Type.String - ( DBString - ) +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UndecidableInstances #-} + +module Rel8.Type.String ( + DBString, +) where -- base -import Data.Kind ( Constraint, Type ) +import Data.Kind (Constraint, Type) import Prelude () -- bytestring -import Data.ByteString ( ByteString ) -import qualified Data.ByteString.Lazy as Lazy ( ByteString ) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as Lazy (ByteString) -- case-insensitive -import Data.CaseInsensitive ( CI ) +import Data.CaseInsensitive (CI) -- rel8 -import Rel8.Type ( DBType ) +import Rel8.Type (DBType) -- text -import Data.Text ( Text ) -import qualified Data.Text.Lazy as Lazy ( Text ) +import Data.Text (Text) +import qualified Data.Text.Lazy as Lazy (Text) --- | The class of data types that support the @string_agg()@ aggregation --- function. +{- | The class of data types that support the @string_agg()@ aggregation +function. +-} type DBString :: Type -> Constraint class DBType a => DBString a + + instance DBString Text instance DBString Lazy.Text instance DBString (CI Text) diff --git a/src/Rel8/Type/Sum.hs b/src/Rel8/Type/Sum.hs index 3808b321..afe89787 100644 --- a/src/Rel8/Type/Sum.hs +++ b/src/Rel8/Type/Sum.hs @@ -1,34 +1,36 @@ -{-# language DataKinds #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language MultiParamTypeClasses #-} -{-# language TypeFamilies #-} -{-# language StandaloneKindSignatures #-} -{-# language UndecidableInstances #-} - -module Rel8.Type.Sum - ( DBSum - ) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Rel8.Type.Sum ( + DBSum, +) where -- base -import Data.Int ( Int16, Int32, Int64 ) -import Data.Kind ( Constraint, Type ) +import Data.Int (Int16, Int32, Int64) +import Data.Kind (Constraint, Type) import Prelude -- rel8 -import Rel8.Type ( DBType ) +import Rel8.Type (DBType) -- scientific -import Data.Scientific ( Scientific ) +import Data.Scientific (Scientific) -- time -import Data.Time.LocalTime ( CalendarDiffTime ) +import Data.Time.LocalTime (CalendarDiffTime) -- | The class of database types that support the @sum()@ aggregation function. type DBSum :: Type -> Constraint class DBType a => DBSum a + + instance DBSum Int16 instance DBSum Int32 instance DBSum Int64 diff --git a/src/Rel8/Type/Tag.hs b/src/Rel8/Type/Tag.hs index 032dacef..62e7d24f 100644 --- a/src/Rel8/Type/Tag.hs +++ b/src/Rel8/Type/Tag.hs @@ -1,39 +1,41 @@ -{-# language DataKinds #-} -{-# language DeriveAnyClass #-} -{-# language DerivingVia #-} -{-# language GeneralizedNewtypeDeriving #-} -{-# language StandaloneKindSignatures #-} - -module Rel8.Type.Tag - ( EitherTag( IsLeft, IsRight ), isLeft, isRight - , MaybeTag( IsJust ) - , Tag( Tag ) - ) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} + +module Rel8.Type.Tag ( + EitherTag (IsLeft, IsRight), + isLeft, + isRight, + MaybeTag (IsJust), + Tag (Tag), +) where -- base -import Data.Bool ( bool ) -import Data.Kind ( Type ) -import Data.Semigroup ( Min( Min ) ) +import Data.Bool (bool) +import Data.Kind (Type) +import Data.Semigroup (Min (Min)) import Prelude -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye -- rel8 -import Rel8.Expr ( Expr ) -import Rel8.Expr.Eq ( (==.) ) -import Rel8.Expr.Opaleye ( zipPrimExprsWith ) -import Rel8.Expr.Serialize ( litExpr ) -import Rel8.Type.Eq ( DBEq ) -import Rel8.Type ( DBType, typeInformation ) -import Rel8.Type.Information ( mapTypeInformation, parseTypeInformation ) -import Rel8.Type.Monoid ( DBMonoid, memptyExpr ) -import Rel8.Type.Ord ( DBOrd ) -import Rel8.Type.Semigroup ( DBSemigroup, (<>.) ) +import Rel8.Expr (Expr) +import Rel8.Expr.Eq ((==.)) +import Rel8.Expr.Opaleye (zipPrimExprsWith) +import Rel8.Expr.Serialize (litExpr) +import Rel8.Type (DBType, typeInformation) +import Rel8.Type.Eq (DBEq) +import Rel8.Type.Information (mapTypeInformation, parseTypeInformation) +import Rel8.Type.Monoid (DBMonoid, memptyExpr) +import Rel8.Type.Ord (DBOrd) +import Rel8.Type.Semigroup (DBSemigroup, (<>.)) -- text -import Data.Text ( Text ) +import Data.Text (Text) type EitherTag :: Type @@ -93,6 +95,11 @@ instance DBMonoid MaybeTag where type Tag :: Type newtype Tag = Tag Text deriving newtype - ( Eq, Ord, Read, Show - , DBType, DBEq, DBOrd + ( Eq + , Ord + , Read + , Show + , DBType + , DBEq + , DBOrd ) diff --git a/src/Rel8/Window.hs b/src/Rel8/Window.hs index 45ea2af6..33eed3e9 100644 --- a/src/Rel8/Window.hs +++ b/src/Rel8/Window.hs @@ -1,51 +1,52 @@ -{-# language DerivingVia #-} -{-# language FlexibleContexts #-} -{-# language GeneralizedNewtypeDeriving #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeApplications #-} - -module Rel8.Window - ( Window(..) - , Partition - , over - , partitionBy - , orderPartitionBy - ) +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} + +module Rel8.Window ( + Window (..), + Partition, + over, + partitionBy, + orderPartitionBy, +) where -- base -import Data.Functor.Const ( Const( Const ), getConst ) -import Data.Functor.Contravariant ( Contravariant, contramap ) -import Data.Kind ( Type ) +import Data.Functor.Const (Const (Const), getConst) +import Data.Functor.Contravariant (Contravariant, contramap) +import Data.Kind (Type) import Prelude -- opaleye -import qualified Opaleye.Internal.Window as Opaleye import qualified Opaleye.Internal.PackMap as Opaleye - --- profunctors -import Data.Profunctor ( Profunctor ) +import qualified Opaleye.Internal.Window as Opaleye -- product-profunctors -import Data.Profunctor.Product ( ProductProfunctor, (****), purePP ) +import Data.Profunctor.Product (ProductProfunctor, purePP, (****)) + +-- profunctors +import Data.Profunctor (Profunctor) -- rel8 -import Rel8.Expr.Opaleye ( toColumn, toPrimExpr ) -import Rel8.Order( Order( Order ) ) -import Rel8.Schema.HTable ( hfield, htabulateA ) -import Rel8.Table ( Columns, toColumns ) -import Rel8.Table.Eq ( EqTable ) +import Rel8.Expr.Opaleye (toColumn, toPrimExpr) +import Rel8.Order (Order (Order)) +import Rel8.Schema.HTable (hfield, htabulateA) +import Rel8.Table (Columns, toColumns) +import Rel8.Table.Eq (EqTable) -- semigroupoids -import Data.Functor.Apply ( Apply, WrappedApplicative(..) ) +import Data.Functor.Apply (Apply, WrappedApplicative (..)) --- | 'Window' is an applicative functor that represents expressions that --- contain --- [window functions](https://www.postgresql.org/docs/current/tutorial-window.html). --- 'Rel8.Query.Window.window' can be used to --- evaluate these expressions over a particular query. +{- | 'Window' is an applicative functor that represents expressions that +contain +[window functions](https://www.postgresql.org/docs/current/tutorial-window.html). +'Rel8.Query.Window.window' can be used to +evaluate these expressions over a particular query. +-} type Window :: Type -> Type -> Type newtype Window a b = Window (Opaleye.Windows a b) deriving newtype (Profunctor) @@ -58,40 +59,48 @@ instance ProductProfunctor Window where (****) = (<*>) --- | In PostgreSQL, window functions must specify the \"window\" or --- \"partition\" over which they operate. The syntax for this looks like: --- @SUM(salary) OVER (PARTITION BY department)@. The Rel8 type 'Partition' --- represents everything that comes after @OVER@. --- --- 'Partition' is a 'Monoid', so 'Window's created with 'partitionBy' and --- 'orderWindowBy' can be combined using '<>'. +{- | In PostgreSQL, window functions must specify the \"window\" or +\"partition\" over which they operate. The syntax for this looks like: +@SUM(salary) OVER (PARTITION BY department)@. The Rel8 type 'Partition' +represents everything that comes after @OVER@. + +'Partition' is a 'Monoid', so 'Window's created with 'partitionBy' and +'orderWindowBy' can be combined using '<>'. +-} type Partition :: Type -> Type newtype Partition a = Partition (Opaleye.Window a) deriving newtype (Contravariant, Semigroup, Monoid) --- | 'over' adds a 'Partition' to a 'Window' expression. --- --- @@@ --- 'Rel8.Table.Window.cumulative' ('Rel8.Expr.Aggregate.sum' . salary) `over` 'partitionBy' department <> 'orderPartitionBy' (salary >$< 'Rel8.desc') --- @@@ +{- | 'over' adds a 'Partition' to a 'Window' expression. + +@@@ +'Rel8.Table.Window.cumulative' ('Rel8.Expr.Aggregate.sum' . salary) `over` 'partitionBy' department <> 'orderPartitionBy' (salary >$< 'Rel8.desc') +@@@ +-} over :: Window a b -> Partition a -> Window a b over (Window (Opaleye.Windows (Opaleye.PackMap w))) (Partition p) = Window $ Opaleye.Windows $ Opaleye.PackMap $ \f -> w (\(o, p') -> f (o, p' <> p)) + + infixl 1 `over` --- | Restricts a window function to operate only the group of rows that share --- the same value(s) for the given expression(s). +{- | Restricts a window function to operate only the group of rows that share +the same value(s) for the given expression(s). +-} partitionBy :: forall b a. EqTable b => (a -> b) -> Partition a partitionBy f = - Partition $ contramap (toColumns . f) $ getConst $ - htabulateA @(Columns b) $ \field -> - Const $ Opaleye.partitionBy (toColumn . toPrimExpr . (`hfield` field)) + Partition $ + contramap (toColumns . f) $ + getConst $ + htabulateA @(Columns b) $ \field -> + Const $ Opaleye.partitionBy (toColumn . toPrimExpr . (`hfield` field)) --- | Controls the order in which rows are processed by window functions. This --- does not need to match the ordering of the overall query. +{- | Controls the order in which rows are processed by window functions. This +does not need to match the ordering of the overall query. +-} orderPartitionBy :: Order a -> Partition a orderPartitionBy (Order ordering) = Partition $ Opaleye.orderPartitionBy ordering diff --git a/tests/Main.hs b/tests/Main.hs index b0973670..0d85dbe4 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,94 +1,96 @@ -{-# language BangPatterns #-} -{-# language BlockArguments #-} -{-# language DeriveAnyClass #-} -{-# language DeriveGeneric #-} -{-# language DerivingVia #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language MonoLocalBinds #-} -{-# language NamedFieldPuns #-} -{-# language OverloadedStrings #-} -{-# language RecordWildCards #-} -{-# language ScopedTypeVariables #-} -{-# language StandaloneDeriving #-} -{-# language TypeApplications #-} - -module Main - ( main - ) +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} + +module Main ( + main, +) where +-- +import Hasql.Transaction (Transaction, condemn, statement) +import qualified Hasql.Transaction.Sessions as Hasql + -- base -import Control.Applicative ( empty, liftA2, liftA3 ) -import Control.Exception ( bracket, throwIO ) -import Control.Monad ( (>=>), void ) -import Data.Bifunctor ( bimap ) +import Control.Applicative (empty, liftA2, liftA3) +import Control.Exception (bracket, throwIO) +import Control.Monad (void, (>=>)) +import Data.Bifunctor (bimap) import Data.Fixed (Fixed (MkFixed)) -import Data.Foldable ( for_ ) -import Data.Int ( Int32, Int64 ) -import Data.List ( nub, sort ) -import Data.Maybe ( catMaybes ) -import Data.String ( fromString ) +import Data.Foldable (for_) +import Data.Int (Int32, Int64) +import Data.List (nub, sort) +import Data.Maybe (catMaybes) +import Data.String (fromString) import Data.Word (Word32, Word8) -import GHC.Generics ( Generic ) +import GHC.Generics (Generic) -- bytestring import qualified Data.ByteString.Lazy -- case-insensitive -import Data.CaseInsensitive ( mk ) +import Data.CaseInsensitive (mk) -- containers -import Data.Containers.ListUtils ( nubOrdOn ) +import Data.Containers.ListUtils (nubOrdOn) import qualified Data.Map.Strict as Map --- hasql -import Hasql.Connection ( Connection, acquire, release ) -import Hasql.Session ( sql, run ) +-- data-dword +import Data.DoubleWord (Word128 (..)) --- hasql-transaction -import Hasql.Transaction ( Transaction, condemn, statement ) -import qualified Hasql.Transaction.Sessions as Hasql +-- hasql +import Hasql.Connection (Connection, acquire, release) +import Hasql.Session (run, sql) -- hedgehog -import Hedgehog ( property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen ) +import Hedgehog (Gen, PropertyT, TestT, cover, diff, evalM, forAll, property, test, (===)) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range -- mmorph -import Control.Monad.Morph ( hoist ) +import Control.Monad.Morph (hoist) -- network-ip -import Network.IP.Addr (NetAddr, IP, IP4(..), IP6(..), IP46(..), net4Addr, net6Addr, fromNetAddr46, Net4Addr, Net6Addr) -import Data.DoubleWord (Word128(..)) +import Network.IP.Addr (IP, IP4 (..), IP46 (..), IP6 (..), Net4Addr, Net6Addr, NetAddr, fromNetAddr46, net4Addr, net6Addr) -- rel8 -import Rel8 ( Result ) +import Rel8 (Result) import qualified Rel8 -- scientific -import Data.Scientific ( Scientific ) +import Data.Scientific (Scientific) -- tasty import Test.Tasty -- tasty-hedgehog -import Test.Tasty.Hedgehog ( testProperty ) +import Test.Tasty.Hedgehog (testProperty) -- text -import Data.Text ( Text, pack, unpack ) +import Data.Text (Text, pack, unpack) +import Data.Text.Encoding (decodeUtf8) import qualified Data.Text.Lazy -import Data.Text.Encoding ( decodeUtf8 ) -- time import Data.Time --- transformers -import Control.Monad.Trans.Class ( lift ) - -- tmp-postgres import qualified Database.Postgres.Temp as TmpPostgres +-- transformers +import Control.Monad.Trans.Class (lift) + -- uuid import qualified Data.UUID @@ -100,42 +102,41 @@ main = defaultMain tests tests :: TestTree tests = withResource startTestDatabase stopTestDatabase \getTestDatabase -> - testGroup "rel8" - [ testSelectTestTable getTestDatabase - , testWhere_ getTestDatabase - , testFilter getTestDatabase - , testLimit getTestDatabase - , testUnion getTestDatabase - , testDistinct getTestDatabase - , testExists getTestDatabase - , testOptional getTestDatabase - , testAnd getTestDatabase - , testOr getTestDatabase - , testNot getTestDatabase - , testBool getTestDatabase - , testAp getTestDatabase - , testDBType getTestDatabase - , testDBEq getTestDatabase - , testTableEquality getTestDatabase - , testFromString getTestDatabase - , testCatMaybeTable getTestDatabase - , testCatMaybe getTestDatabase - , testMaybeTable getTestDatabase - , testAggregateMaybeTable getTestDatabase - , testNestedTables getTestDatabase - , testMaybeTableApplicative getTestDatabase - , testLogicalFixities getTestDatabase - , testUpdate getTestDatabase - , testDelete getTestDatabase - , testUpsert getTestDatabase - , testSelectNestedPairs getTestDatabase - , testSelectArray getTestDatabase - , testNestedMaybeTable getTestDatabase - , testEvaluate getTestDatabase - ] - + testGroup + "rel8" + [ testSelectTestTable getTestDatabase + , testWhere_ getTestDatabase + , testFilter getTestDatabase + , testLimit getTestDatabase + , testUnion getTestDatabase + , testDistinct getTestDatabase + , testExists getTestDatabase + , testOptional getTestDatabase + , testAnd getTestDatabase + , testOr getTestDatabase + , testNot getTestDatabase + , testBool getTestDatabase + , testAp getTestDatabase + , testDBType getTestDatabase + , testDBEq getTestDatabase + , testTableEquality getTestDatabase + , testFromString getTestDatabase + , testCatMaybeTable getTestDatabase + , testCatMaybe getTestDatabase + , testMaybeTable getTestDatabase + , testAggregateMaybeTable getTestDatabase + , testNestedTables getTestDatabase + , testMaybeTableApplicative getTestDatabase + , testLogicalFixities getTestDatabase + , testUpdate getTestDatabase + , testDelete getTestDatabase + , testUpsert getTestDatabase + , testSelectNestedPairs getTestDatabase + , testSelectArray getTestDatabase + , testNestedMaybeTable getTestDatabase + , testEvaluate getTestDatabase + ] where - startTestDatabase = do db <- TmpPostgres.start >>= either throwIO return @@ -156,25 +157,27 @@ connect :: TmpPostgres.DB -> IO Connection connect = acquire . TmpPostgres.toConnectionString >=> either (maybe empty (fail . unpack . decodeUtf8)) pure -databasePropertyTest - :: TestName - -> ((TestT Transaction () -> PropertyT IO ()) -> PropertyT IO ()) - -> IO TmpPostgres.DB -> TestTree +databasePropertyTest :: + TestName -> + ((TestT Transaction () -> PropertyT IO ()) -> PropertyT IO ()) -> + IO TmpPostgres.DB -> + TestTree databasePropertyTest testName f getTestDatabase = withResource (connect =<< getTestDatabase) release $ \c -> - testProperty testName $ property do - connection <- lift c - f $ test . hoist \m -> do - e <- run (Hasql.transaction Hasql.Serializable Hasql.Write (m <* condemn)) connection - either throwIO pure e + testProperty testName $ property do + connection <- lift c + f $ + test . hoist \m -> do + e <- run (Hasql.transaction Hasql.Serializable Hasql.Write (m <* condemn)) connection + either throwIO pure e data TestTable f = TestTable { testTableColumn1 :: Rel8.Column f Text , testTableColumn2 :: Rel8.Column f Bool } - deriving stock Generic - deriving anyclass Rel8.Rel8able + deriving stock (Generic) + deriving anyclass (Rel8.Rel8able) deriving stock instance Eq (TestTable Result) @@ -187,10 +190,11 @@ testTableSchema = Rel8.TableSchema { name = "test_table" , schema = Nothing - , columns = TestTable - { testTableColumn1 = "column1" - , testTableColumn2 = "column2" - } + , columns = + TestTable + { testTableColumn1 = "column1" + , testTableColumn2 = "column2" + } } @@ -200,12 +204,14 @@ testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction - transaction do selected <- lift do - statement () $ Rel8.insert Rel8.Insert - { into = testTableSchema - , rows = Rel8.values $ map Rel8.lit rows - , onConflict = Rel8.DoNothing - , returning = pure () - } + statement () $ + Rel8.insert + Rel8.Insert + { into = testTableSchema + , rows = Rel8.values $ map Rel8.lit rows + , onConflict = Rel8.DoNothing + , returning = pure () + } statement () $ Rel8.select do Rel8.each testTableSchema @@ -334,7 +340,7 @@ testOptional = databasePropertyTest "Rel8.optional" \transaction -> do case rows of [] -> selected === [Nothing] - _ -> sort selected === fmap Just (sort rows) + _ -> sort selected === fmap Just (sort rows) testAnd :: IO TmpPostgres.DB -> TestTree @@ -355,8 +361,10 @@ testOr = databasePropertyTest "OR (||.)" \transaction -> do transaction do [result] <- lift do - statement () $ Rel8.select $ pure $ - Rel8.lit x Rel8.||. Rel8.lit y + statement () $ + Rel8.select $ + pure $ + Rel8.lit x Rel8.||. Rel8.lit y result === (x || y) @@ -399,10 +407,12 @@ testBool = databasePropertyTest "ifThenElse_" \transaction -> do testAp :: IO TmpPostgres.DB -> TestTree testAp = databasePropertyTest "Cartesian product (<*>)" \transaction -> do - (rows1, rows2) <- forAll $ - liftA2 (,) - (Gen.list (Range.linear 1 10) genTestTable) - (Gen.list (Range.linear 1 10) genTestTable) + (rows1, rows2) <- + forAll $ + liftA2 + (,) + (Gen.list (Range.linear 1 10) genTestTable) + (Gen.list (Range.linear 1 10) genTestTable) transaction do result <- lift do @@ -427,40 +437,45 @@ instance Rel8.DBComposite Composite where testDBType :: IO TmpPostgres.DB -> TestTree -testDBType getTestDatabase = testGroup "DBType instances" - [ dbTypeTest "Bool" Gen.bool - , dbTypeTest "ByteString" $ Gen.bytes (Range.linear 0 128) - , dbTypeTest "CalendarDiffTime" genCalendarDiffTime - , dbTypeTest "CI Lazy Text" $ mk . Data.Text.Lazy.fromStrict <$> Gen.text (Range.linear 0 10) Gen.unicode - , dbTypeTest "CI Text" $ mk <$> Gen.text (Range.linear 0 10) Gen.unicode - , dbTypeTest "Composite" genComposite - , dbTypeTest "Day" genDay - , dbTypeTest "Double" $ (/ 10) . fromIntegral @Int @Double <$> Gen.integral (Range.linear (-100) 100) - , dbTypeTest "Float" $ (/ 10) . fromIntegral @Int @Float <$> Gen.integral (Range.linear (-100) 100) - , dbTypeTest "Int32" $ Gen.integral @_ @Int32 Range.linearBounded - , dbTypeTest "Int64" $ Gen.integral @_ @Int64 Range.linearBounded - , dbTypeTest "Lazy ByteString" $ Data.ByteString.Lazy.fromStrict <$> Gen.bytes (Range.linear 0 128) - , dbTypeTest "Lazy Text" $ Data.Text.Lazy.fromStrict <$> Gen.text (Range.linear 0 10) Gen.unicode - , dbTypeTest "LocalTime" genLocalTime - , dbTypeTest "Scientific" $ (/ 10) . fromIntegral @Int @Scientific <$> Gen.integral (Range.linear (-100) 100) - , dbTypeTest "Text" $ Gen.text (Range.linear 0 10) Gen.unicode - , dbTypeTest "TimeOfDay" genTimeOfDay - , dbTypeTest "UTCTime" $ UTCTime <$> genDay <*> genDiffTime - , dbTypeTest "UUID" $ Data.UUID.fromWords <$> genWord32 <*> genWord32 <*> genWord32 <*> genWord32 - , dbTypeTest "INet" genNetAddrIP - ] - +testDBType getTestDatabase = + testGroup + "DBType instances" + [ dbTypeTest "Bool" Gen.bool + , dbTypeTest "ByteString" $ Gen.bytes (Range.linear 0 128) + , dbTypeTest "CalendarDiffTime" genCalendarDiffTime + , dbTypeTest "CI Lazy Text" $ mk . Data.Text.Lazy.fromStrict <$> Gen.text (Range.linear 0 10) Gen.unicode + , dbTypeTest "CI Text" $ mk <$> Gen.text (Range.linear 0 10) Gen.unicode + , dbTypeTest "Composite" genComposite + , dbTypeTest "Day" genDay + , dbTypeTest "Double" $ (/ 10) . fromIntegral @Int @Double <$> Gen.integral (Range.linear (-100) 100) + , dbTypeTest "Float" $ (/ 10) . fromIntegral @Int @Float <$> Gen.integral (Range.linear (-100) 100) + , dbTypeTest "Int32" $ Gen.integral @_ @Int32 Range.linearBounded + , dbTypeTest "Int64" $ Gen.integral @_ @Int64 Range.linearBounded + , dbTypeTest "Lazy ByteString" $ Data.ByteString.Lazy.fromStrict <$> Gen.bytes (Range.linear 0 128) + , dbTypeTest "Lazy Text" $ Data.Text.Lazy.fromStrict <$> Gen.text (Range.linear 0 10) Gen.unicode + , dbTypeTest "LocalTime" genLocalTime + , dbTypeTest "Scientific" $ (/ 10) . fromIntegral @Int @Scientific <$> Gen.integral (Range.linear (-100) 100) + , dbTypeTest "Text" $ Gen.text (Range.linear 0 10) Gen.unicode + , dbTypeTest "TimeOfDay" genTimeOfDay + , dbTypeTest "UTCTime" $ UTCTime <$> genDay <*> genDiffTime + , dbTypeTest "UUID" $ Data.UUID.fromWords <$> genWord32 <*> genWord32 <*> genWord32 <*> genWord32 + , dbTypeTest "INet" genNetAddrIP + ] where dbTypeTest :: (Eq a, Show a, Rel8.DBType a, Rel8.ToExprs (Rel8.Expr a) a) => TestName -> Gen a -> TestTree - dbTypeTest name generator = testGroup name - [ databasePropertyTest name (t generator) getTestDatabase - , databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase - ] - - t :: forall a b. (Eq a, Show a, Rel8.Sql Rel8.DBType a, Rel8.ToExprs (Rel8.Expr a) a) - => Gen a - -> (TestT Transaction () -> PropertyT IO b) - -> PropertyT IO b + dbTypeTest name generator = + testGroup + name + [ databasePropertyTest name (t generator) getTestDatabase + , databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase + ] + + t :: + forall a b. + (Eq a, Show a, Rel8.Sql Rel8.DBType a, Rel8.ToExprs (Rel8.Expr a) a) => + Gen a -> + (TestT Transaction () -> PropertyT IO b) -> + PropertyT IO b t generator transaction = do x <- forAll generator y <- forAll generator @@ -483,21 +498,21 @@ testDBType getTestDatabase = testGroup "DBType instances" xs <- Rel8.catListTable (Rel8.listTable [Rel8.listTable [Rel8.litExpr x, Rel8.litExpr y]]) Rel8.catListTable xs diff res'' (==) [x, y] -{- - res''' <- lift do - statement () $ Rel8.select do - xss <- Rel8.catListTable (Rel8.listTable [Rel8.listTable [Rel8.listTable [Rel8.litExpr x, Rel8.litExpr y]]]) - xs <- Rel8.catListTable xss - Rel8.catListTable xs - diff res''' (==) [x, y] --} + {- + res''' <- lift do + statement () $ Rel8.select do + xss <- Rel8.catListTable (Rel8.listTable [Rel8.listTable [Rel8.listTable [Rel8.litExpr x, Rel8.litExpr y]]]) + xs <- Rel8.catListTable xss + Rel8.catListTable xs + diff res''' (==) [x, y] + -} genComposite :: Gen Composite genComposite = do bool <- Gen.bool char <- Gen.unicode array <- Gen.list (Range.linear 0 10) (Gen.int32 (Range.linear (-10000) 10000)) - pure Composite {..} + pure Composite{..} genDay :: Gen Day genDay = do @@ -532,7 +547,7 @@ testDBType getTestDatabase = testGroup "DBType instances" genWord128 :: Gen Word128 genWord128 = Gen.integral Range.linearBounded - genNetAddrIP :: Gen (NetAddr IP) + genNetAddrIP :: Gen (NetAddr IP) genNetAddrIP = let genIP4Mask :: Gen Word8 @@ -546,29 +561,34 @@ testDBType getTestDatabase = testGroup "DBType instances" genIPv6 :: Gen (IP46 Net4Addr Net6Addr) genIPv6 = IPv6 <$> (liftA2 net6Addr (IP6 <$> genWord128) genIP6Mask) - - in fromNetAddr46 <$> Gen.choice [ genIPv4, genIPv6 ] + in + fromNetAddr46 <$> Gen.choice [genIPv4, genIPv6] testDBEq :: IO TmpPostgres.DB -> TestTree -testDBEq getTestDatabase = testGroup "DBEq instances" - [ dbEqTest "Bool" Gen.bool - , dbEqTest "Int32" $ Gen.integral @_ @Int32 Range.linearBounded - , dbEqTest "Int64" $ Gen.integral @_ @Int64 Range.linearBounded - , dbEqTest "Text" $ Gen.text (Range.linear 0 10) Gen.unicode - ] - +testDBEq getTestDatabase = + testGroup + "DBEq instances" + [ dbEqTest "Bool" Gen.bool + , dbEqTest "Int32" $ Gen.integral @_ @Int32 Range.linearBounded + , dbEqTest "Int64" $ Gen.integral @_ @Int64 Range.linearBounded + , dbEqTest "Text" $ Gen.text (Range.linear 0 10) Gen.unicode + ] where dbEqTest :: (Eq a, Show a, Rel8.DBEq a) => TestName -> Gen a -> TestTree - dbEqTest name generator = testGroup name - [ databasePropertyTest name (t generator) getTestDatabase - , databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase - ] - - t :: forall a. (Eq a, Show a, Rel8.Sql Rel8.DBEq a) - => Gen a - -> (TestT Transaction () -> PropertyT IO ()) - -> PropertyT IO () + dbEqTest name generator = + testGroup + name + [ databasePropertyTest name (t generator) getTestDatabase + , databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase + ] + + t :: + forall a. + (Eq a, Show a, Rel8.Sql Rel8.DBEq a) => + Gen a -> + (TestT Transaction () -> PropertyT IO ()) -> + PropertyT IO () t generator transaction = do (x, y) <- forAll (liftA2 (,) generator generator) @@ -581,14 +601,14 @@ testDBEq getTestDatabase = testGroup "DBEq instances" testTableEquality :: IO TmpPostgres.DB -> TestTree testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do - (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable + (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable - transaction do - [eq] <- lift do - statement () $ Rel8.select do - pure $ Rel8.lit x Rel8.==: Rel8.lit y + transaction do + [eq] <- lift do + statement () $ Rel8.select do + pure $ Rel8.lit x Rel8.==: Rel8.lit y - eq === (x == y) + eq === (x == y) testFromString :: IO TmpPostgres.DB -> TestTree @@ -663,13 +683,12 @@ testAggregateMaybeTable = databasePropertyTest "aggregateMaybeTable" \transactio sort selected === aggregate rows -data TwoTestTables f = - TwoTestTables - { testTable1 :: TestTable f - , testTable2 :: TestTable f - } - deriving stock Generic - deriving anyclass Rel8.Rel8able +data TwoTestTables f = TwoTestTables + { testTable1 :: TestTable f + , testTable2 :: TestTable f + } + deriving stock (Generic) + deriving anyclass (Rel8.Rel8able) deriving stock instance Eq (TwoTestTables Result) @@ -727,33 +746,36 @@ testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do transaction do selected <- lift do - statement () $ Rel8.insert Rel8.Insert - { into = testTableSchema - , rows = Rel8.values $ map Rel8.lit $ Map.keys rows - , onConflict = Rel8.DoNothing - , returning = pure () - } - - statement () $ Rel8.update Rel8.Update - { target = testTableSchema - , from = pure () - , set = \_ r -> - let updates = map (bimap Rel8.lit Rel8.lit) $ Map.toList rows - in - foldl - ( \e (x, y) -> - Rel8.bool - e - y - ( testTableColumn1 r Rel8.==. testTableColumn1 x Rel8.&&. - testTableColumn2 r Rel8.==. testTableColumn2 x - ) - ) - r - updates - , updateWhere = \_ _ -> Rel8.lit True - , returning = pure () - } + statement () $ + Rel8.insert + Rel8.Insert + { into = testTableSchema + , rows = Rel8.values $ map Rel8.lit $ Map.keys rows + , onConflict = Rel8.DoNothing + , returning = pure () + } + + statement () $ + Rel8.update + Rel8.Update + { target = testTableSchema + , from = pure () + , set = \_ r -> + let updates = map (bimap Rel8.lit Rel8.lit) $ Map.toList rows + in foldl + ( \e (x, y) -> + Rel8.bool + e + y + ( testTableColumn1 r Rel8.==. testTableColumn1 x + Rel8.&&. testTableColumn2 r Rel8.==. testTableColumn2 x + ) + ) + r + updates + , updateWhere = \_ _ -> Rel8.lit True + , returning = pure () + } statement () $ Rel8.select do Rel8.each testTableSchema @@ -771,19 +793,24 @@ testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do transaction do (deleted, selected) <- lift do - statement () $ Rel8.insert Rel8.Insert - { into = testTableSchema - , rows = Rel8.values $ map Rel8.lit rows - , onConflict = Rel8.DoNothing - , returning = pure () - } - - deleted <- statement () $ Rel8.delete Rel8.Delete - { from = testTableSchema - , using = pure () - , deleteWhere = const testTableColumn2 - , returning = Rel8.Projection id - } + statement () $ + Rel8.insert + Rel8.Insert + { into = testTableSchema + , rows = Rel8.values $ map Rel8.lit rows + , onConflict = Rel8.DoNothing + , returning = pure () + } + + deleted <- + statement () $ + Rel8.delete + Rel8.Delete + { from = testTableSchema + , using = pure () + , deleteWhere = const testTableColumn2 + , returning = Rel8.Projection id + } selected <- statement () $ Rel8.select do Rel8.each testTableSchema @@ -797,8 +824,8 @@ data UniqueTable f = UniqueTable { uniqueTableKey :: Rel8.Column f Text , uniqueTableValue :: Rel8.Column f Text } - deriving stock Generic - deriving anyclass Rel8.Rel8able + deriving stock (Generic) + deriving anyclass (Rel8.Rel8able) deriving stock instance Eq (UniqueTable Result) @@ -811,10 +838,11 @@ uniqueTableSchema = Rel8.TableSchema { name = "unique_table" , schema = Nothing - , columns = UniqueTable - { uniqueTableKey = "key" - , uniqueTableValue = "value" - } + , columns = + UniqueTable + { uniqueTableKey = "key" + , uniqueTableValue = "value" + } } @@ -822,7 +850,7 @@ genUniqueTable :: Gen (UniqueTable Result) genUniqueTable = do uniqueTableKey <- Gen.text (Range.linear 0 5) Gen.alphaNum uniqueTableValue <- Gen.text (Range.linear 0 5) Gen.alphaNum - pure UniqueTable {..} + pure UniqueTable{..} testUpsert :: IO TmpPostgres.DB -> TestTree @@ -832,23 +860,29 @@ testUpsert = databasePropertyTest "Can UPSERT UniqueTable" \transaction -> do transaction do selected <- lift do - statement () $ Rel8.insert Rel8.Insert - { into = uniqueTableSchema - , rows = Rel8.values $ Rel8.lit <$> as - , onConflict = Rel8.DoNothing - , returning = pure () - } - - statement () $ Rel8.insert Rel8.Insert - { into = uniqueTableSchema - , rows = Rel8.values $ Rel8.lit <$> bs - , onConflict = Rel8.DoUpdate Rel8.Upsert - { index = uniqueTableKey - , set = \UniqueTable {uniqueTableValue} old -> old {uniqueTableValue} - , updateWhere = \_ _ -> Rel8.true + statement () $ + Rel8.insert + Rel8.Insert + { into = uniqueTableSchema + , rows = Rel8.values $ Rel8.lit <$> as + , onConflict = Rel8.DoNothing + , returning = pure () + } + + statement () $ + Rel8.insert + Rel8.Insert + { into = uniqueTableSchema + , rows = Rel8.values $ Rel8.lit <$> bs + , onConflict = + Rel8.DoUpdate + Rel8.Upsert + { index = uniqueTableKey + , set = \UniqueTable{uniqueTableValue} old -> old{uniqueTableValue} + , updateWhere = \_ _ -> Rel8.true + } + , returning = pure () } - , returning = pure () - } statement () $ Rel8.select do Rel8.each uniqueTableSchema @@ -859,9 +893,10 @@ testUpsert = databasePropertyTest "Can UPSERT UniqueTable" \transaction -> do fromUniqueTables = Map.fromList . map \(UniqueTable key value) -> (key, value) -newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) } - deriving stock Generic - deriving anyclass Rel8.Rel8able +newtype HKNestedPair f = HKNestedPair {pairOne :: (TestTable f, TestTable f)} + deriving stock (Generic) + deriving anyclass (Rel8.Rel8able) + deriving stock instance Eq (HKNestedPair Result) deriving stock instance Ord (HKNestedPair Result) @@ -893,10 +928,12 @@ testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \t selected' <- lift do statement () $ Rel8.select do - a <- Rel8.catListTable =<< do - Rel8.many $ Rel8.values (map Rel8.lit rows) - b <- Rel8.catListTable =<< do - Rel8.many $ Rel8.values (map Rel8.lit rows) + a <- + Rel8.catListTable =<< do + Rel8.many $ Rel8.values (map Rel8.lit rows) + b <- + Rel8.catListTable =<< do + Rel8.many $ Rel8.values (map Rel8.lit rows) pure (a, b) selected' === liftA2 (,) rows rows @@ -906,8 +943,8 @@ data NestedMaybeTable f = NestedMaybeTable { nmt1 :: Rel8.Column f Bool , nmt2 :: Rel8.HMaybe f (TestTable f) } - deriving stock Generic - deriving anyclass Rel8.Rel8able + deriving stock (Generic) + deriving anyclass (Rel8.Rel8able) deriving stock instance Eq (NestedMaybeTable Result) @@ -917,7 +954,7 @@ deriving stock instance Show (NestedMaybeTable Result) testNestedMaybeTable :: IO TmpPostgres.DB -> TestTree testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other tables" \transaction -> do - let example = NestedMaybeTable { nmt1 = True, nmt2 = Just (TestTable "Hi" True) } + let example = NestedMaybeTable{nmt1 = True, nmt2 = Just (TestTable "Hi" True)} transaction do selected <- lift do @@ -930,7 +967,6 @@ testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other ta testEvaluate :: IO TmpPostgres.DB -> TestTree testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect" \transaction -> do - transaction do selected <- lift do statement () $ Rel8.select do @@ -938,11 +974,11 @@ testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect y <- Rel8.evaluate (Rel8.nextval "test_seq") pure (x, (y, y)) - normalize selected === - [ ('a', (0, 0)) - , ('b', (1, 1)) - , ('c', (2, 2)) - ] + normalize selected + === [ ('a', (0, 0)) + , ('b', (1, 1)) + , ('c', (2, 2)) + ] selected' <- lift do statement () $ Rel8.select do @@ -951,18 +987,17 @@ testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect z <- Rel8.evaluate (Rel8.nextval "test_seq") pure ((x, y), (z, z)) - normalize selected' === - [ (('a', 'd'), (0, 0)) - , (('a', 'e'), (1, 1)) - , (('a', 'f'), (2, 2)) - , (('b', 'd'), (3, 3)) - , (('b', 'e'), (4, 4)) - , (('b', 'f'), (5, 5)) - , (('c', 'd'), (6, 6)) - , (('c', 'e'), (7, 7)) - , (('c', 'f'), (8, 8)) - ] - + normalize selected' + === [ (('a', 'd'), (0, 0)) + , (('a', 'e'), (1, 1)) + , (('a', 'f'), (2, 2)) + , (('b', 'd'), (3, 3)) + , (('b', 'e'), (4, 4)) + , (('b', 'f'), (5, 5)) + , (('c', 'd'), (6, 6)) + , (('c', 'e'), (7, 7)) + , (('c', 'f'), (8, 8)) + ] where normalize :: [(x, (Int64, Int64))] -> [(x, (Int64, Int64))] normalize [] = [] diff --git a/tests/Rel8/Generic/Rel8able/Test.hs b/tests/Rel8/Generic/Rel8able/Test.hs index 88eda93c..d0728b2f 100644 --- a/tests/Rel8/Generic/Rel8able/Test.hs +++ b/tests/Rel8/Generic/Rel8able/Test.hs @@ -1,108 +1,107 @@ -{-# language DataKinds #-} -{-# language DeriveAnyClass #-} -{-# language DeriveGeneric #-} -{-# language DerivingStrategies #-} -{-# language DuplicateRecordFields #-} -{-# language FlexibleInstances #-} -{-# language MultiParamTypeClasses #-} -{-# language StandaloneKindSignatures #-} -{-# language TypeFamilies #-} -{-# language UndecidableInstances #-} - -{-# options_ghc -O0 #-} - -module Rel8.Generic.Rel8able.Test - ( module Rel8.Generic.Rel8able.Test - ) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -O0 #-} + +module Rel8.Generic.Rel8able.Test ( + module Rel8.Generic.Rel8able.Test, +) where -- base -import GHC.Generics ( Generic ) +import GHC.Generics (Generic) import Prelude -- rel8 import Rel8 -- text -import Data.Text ( Text ) +import Data.Text (Text) data TableTest f = TableTest { foo :: Column f Bool , bar :: Column f (Maybe Bool) } - deriving stock Generic - deriving anyclass Rel8able + deriving stock (Generic) + deriving anyclass (Rel8able) data TablePair f = TablePair { foo :: Column f Bool , bars :: (Column f Text, Column f Text) } - deriving stock Generic - deriving anyclass Rel8able + deriving stock (Generic) + deriving anyclass (Rel8able) data TableMaybe f = TableMaybe { foo :: Column f [Maybe Bool] , bars :: HMaybe f (TablePair f, TablePair f) } - deriving stock Generic - deriving anyclass Rel8able + 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 Char) } - deriving stock Generic - deriving anyclass Rel8able + 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 + 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 + deriving stock (Generic) + deriving anyclass (Rel8able) data TableNonEmpty f = TableNonEmpty { foo :: Column f Bool , bars :: HNonEmpty f (TableList f, TableMaybe f) } - deriving stock Generic - deriving anyclass Rel8able + deriving stock (Generic) + deriving anyclass (Rel8able) data TableNest f = TableNest { foo :: Column f Bool , bars :: HList f (HMaybe f (TablePair f)) } - deriving stock Generic - deriving anyclass Rel8able + deriving stock (Generic) + deriving anyclass (Rel8able) data S3Object = S3Object { bucketName :: Text , objectKey :: Text } - deriving stock Generic + deriving stock (Generic) instance x ~ HKD S3Object Expr => ToExprs x S3Object data HKDSum = HKDSumA Text | HKDSumB Bool Char | HKDSumC - deriving stock Generic + deriving stock (Generic) instance x ~ HKD HKDSum Expr => ToExprs x HKDSum @@ -112,37 +111,38 @@ data HKDTest f = HKDTest { s3Object :: Lift f S3Object , hkdSum :: Lift f HKDSum } - deriving stock Generic - deriving anyclass Rel8able - - -data NonRecord f = NonRecord - (Column f Bool) - (Column f Char) - (Column f Char) - (Column f Char) - (Column f Char) - (Column f Char) - (Column f Char) - (Column f Char) - (Column f Char) - (Column f Char) - deriving stock Generic - deriving anyclass Rel8able + deriving stock (Generic) + deriving anyclass (Rel8able) + + +data NonRecord f + = NonRecord + (Column f Bool) + (Column f Char) + (Column f Char) + (Column f Char) + (Column f Char) + (Column f Char) + (Column f Char) + (Column f Char) + (Column f Char) + (Column f Char) + deriving stock (Generic) + deriving anyclass (Rel8able) data TableSum f = TableSumA (Column f Bool) (Column f Text) | TableSumB | TableSumC (Column f Text) - deriving stock Generic + deriving stock (Generic) data BarbieSum f = BarbieSumA (f Bool) (f Text) | BarbieSumB | BarbieSumC (f Text) - deriving stock Generic + deriving stock (Generic) data TableProduct f = TableProduct @@ -150,16 +150,16 @@ data TableProduct f = TableProduct , list :: TableList f , foos :: HList f (HADT f TableSum, Lift f HKDSum, HKDTest f) } - deriving stock Generic - deriving anyclass Rel8able + deriving stock (Generic) + deriving anyclass (Rel8able) data TableTestB f = TableTestB { foo :: f Bool , bar :: f (Maybe Bool) } - deriving stock Generic - deriving anyclass Rel8able + deriving stock (Generic) + deriving anyclass (Rel8able) data NestedTableTestB f = NestedTableTestB @@ -168,12 +168,12 @@ data NestedTableTestB f = NestedTableTestB , baz :: Column f Char , nest :: TableTestB f } - deriving stock Generic - deriving anyclass Rel8able + deriving stock (Generic) + deriving anyclass (Rel8able) -newtype IdRecord a f = IdRecord { recordId :: Column f a } - deriving stock Generic +newtype IdRecord a f = IdRecord {recordId :: Column f a} + deriving stock (Generic) instance DBType a => Rel8able (IdRecord a) @@ -184,5 +184,5 @@ data Nest t u f = Nest { foo :: t f , bar :: u f } - deriving stock Generic - deriving anyclass Rel8able + deriving stock (Generic) + deriving anyclass (Rel8able) diff --git a/treefmt.toml b/treefmt.toml new file mode 100644 index 00000000..4c5f4810 --- /dev/null +++ b/treefmt.toml @@ -0,0 +1,24 @@ +[formatter.cabal] +command = "cabal-fmt" +options = [ "--tabular", "-i" ] +includes = [ "*.cabal" ] +excludes = [] + +[formatter.nix] +command = "nixpkgs-fmt" +options = [] +includes = ["*.nix"] + +# A bit of a hack, but until https://github.com/numtide/treefmt/issues/77 is +# resolved we need to manually sequence our Haskell formatters. +[formatter.haskell] +command = "/bin/sh" +options = [ + "-euc", + """ +fourmolu -i "$@" +ch-hs-imports --overwrite --local-modules-from-current-dir --report-progress "$@" + """, + "format-haskell" +] +includes = [ "*.hs" ]