mirror of
https://github.com/circuithub/rel8.git
synced 2024-09-12 00:07:34 +03:00
Merge branch 'master' of github.com:circuithub/rel8 into arbitrary-queries
This commit is contained in:
commit
bd2d852166
25
.github/workflows/build.yaml
vendored
Normal file
25
.github/workflows/build.yaml
vendored
Normal file
@ -0,0 +1,25 @@
|
||||
name: Build
|
||||
on: [push, pull_request, release]
|
||||
jobs:
|
||||
build:
|
||||
runs-on: ubuntu-latest
|
||||
steps:
|
||||
- uses: actions/checkout@v2.3.4
|
||||
with:
|
||||
persist-credentials: false
|
||||
submodules: true
|
||||
|
||||
- uses: cachix/install-nix-action@v12
|
||||
with:
|
||||
nix_path: nixpkgs=channel:nixos-unstable
|
||||
extra_nix_config: |
|
||||
trusted-public-keys = cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ=
|
||||
substituters = https://cache.nixos.org/ https://hydra.iohk.io
|
||||
|
||||
- uses: cachix/cachix-action@v8
|
||||
with:
|
||||
name: rel8
|
||||
authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}'
|
||||
|
||||
- run: nix-build -A hsPkgs.rel8.components.library
|
||||
- run: nix-build -A hsPkgs.rel8.checks.tests
|
53
Doctest.hs
53
Doctest.hs
@ -1,53 +0,0 @@
|
||||
{-# language BlockArguments #-}
|
||||
{-# language OverloadedStrings #-}
|
||||
|
||||
module Main where
|
||||
|
||||
-- base
|
||||
import Control.Exception ( bracket, throwIO )
|
||||
import Data.Foldable ( traverse_ )
|
||||
import System.Environment ( lookupEnv, setEnv )
|
||||
|
||||
-- base-compat
|
||||
import System.Environment.Compat ( unsetEnv )
|
||||
|
||||
-- bytestring
|
||||
import Data.ByteString.Char8 ( unpack )
|
||||
|
||||
-- doctest
|
||||
import Test.DocTest ( doctest )
|
||||
|
||||
-- hasql
|
||||
import Hasql.Connection ( acquire, release )
|
||||
import Hasql.Session ( run, sql )
|
||||
|
||||
-- rel8
|
||||
import Build_doctests ( flags, module_sources, pkgs )
|
||||
|
||||
-- tmp-postgres
|
||||
import Database.Postgres.Temp ( toConnectionString, verboseConfig, with, withConfig )
|
||||
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
nixGhcLibdir <- lookupEnv "NIX_GHC_LIBDIR"
|
||||
unsetEnv "GHC_ENVIRONMENT"
|
||||
either throwIO return =<< with \db -> do
|
||||
setEnv "TEST_DATABASE_URL" (unpack (toConnectionString db))
|
||||
bracket (either (error . show) return =<< acquire (toConnectionString db)) release \conn -> do
|
||||
flip run conn do
|
||||
sql "create table author ( author_id serial primary key, name text not null, url text )"
|
||||
sql "create table project ( author_id int not null references author (author_id), name text not null )"
|
||||
|
||||
sql "insert into author ( name, url ) values ( 'Ollie', 'https://ocharles.org.uk' )"
|
||||
sql "insert into author ( name, url ) values ( 'Bryan O''Sullivan', null )"
|
||||
sql "insert into author ( name, url ) values ( 'Emily Pillmore', 'https://cohomolo.gy' )"
|
||||
sql "insert into project ( author_id, name ) values ( 1, 'rel8' )"
|
||||
sql "insert into project ( author_id, name ) values ( 2, 'aeson' )"
|
||||
sql "insert into project ( author_id, name ) values ( 2, 'text' )"
|
||||
|
||||
doctest (args nixGhcLibdir)
|
||||
|
||||
where
|
||||
args nixGhcLibdir =
|
||||
flags ++ pkgs ++ foldMap (\x -> ["-package-db" <> x <> "/package.conf.d"]) nixGhcLibdir ++ module_sources
|
13
README.md
Normal file
13
README.md
Normal file
@ -0,0 +1,13 @@
|
||||
# Welcome!
|
||||
|
||||
Welcome to Rel8! Rel8 is a Haskell library for interacting with PostgreSQL databases, built on top of the fantastic Opaleye library.
|
||||
|
||||
The main objectives of Rel8 are:
|
||||
|
||||
* *Conciseness*: Users using Rel8 should not need to write boiler-plate code. By using expressive types, we can provide sufficient information for the compiler to infer code whenever possible.
|
||||
|
||||
* *Inferrable*: Despite using a lot of type level magic, Rel8 aims to have excellent and predictable type inference.
|
||||
|
||||
* *Familiar*: writing Rel8 queries should feel like normal Haskell programming.
|
||||
|
||||
For more details, check out the [official documentation](https://rel8.readthedocs.io/en/latest/).
|
6
Setup.hs
6
Setup.hs
@ -1,6 +0,0 @@
|
||||
module Main where
|
||||
|
||||
import Distribution.Extra.Doctest (defaultMainWithDoctests)
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMainWithDoctests "doctests"
|
@ -1 +1,6 @@
|
||||
packages: .
|
||||
|
||||
allow-newer: generic-monoid:base
|
||||
allow-newer: cryptohash-sha1:base
|
||||
allow-newer: cryptohash-md5:base
|
||||
allow-newer: entropy:Cabal
|
||||
|
10
cabal.project.haskell-nix
Normal file
10
cabal.project.haskell-nix
Normal file
@ -0,0 +1,10 @@
|
||||
-- Haskell.nix overrides. We don't put these in cabal.project, because Cabal
|
||||
-- will interpret them as local packages, and try to build them when we cabal
|
||||
-- build. The only reason we have to specify these is for Haskell.nix to know to
|
||||
-- override these packages by fetching them rather than using Hackage.
|
||||
|
||||
source-repository-package
|
||||
type: git
|
||||
location: git://github.com/galenhuntington/data-serializer
|
||||
tag: 070d681f97b705f47716e13b646512140524f940
|
||||
--sha256: 198g99ksglnc7c45sjm2xyay1m6hfj4afkp3sksdss5w5abp543f
|
@ -5,7 +5,7 @@ let
|
||||
|
||||
nixpkgsArgs = haskellNix.nixpkgsArgs;
|
||||
|
||||
compiler-nix-name = "ghc8103";
|
||||
compiler-nix-name = "ghc8104";
|
||||
|
||||
pkgs = import nixpkgsSrc nixpkgsArgs;
|
||||
|
||||
@ -13,6 +13,8 @@ in
|
||||
pkgs.haskell-nix.project {
|
||||
inherit compiler-nix-name;
|
||||
|
||||
cabalProjectLocal = builtins.readFile ./cabal.project.haskell-nix;
|
||||
|
||||
src = pkgs.haskell-nix.haskellLib.cleanGit {
|
||||
name = "rel8";
|
||||
src = ./.;
|
||||
|
19
docs/Makefile
Normal file
19
docs/Makefile
Normal file
@ -0,0 +1,19 @@
|
||||
# Minimal makefile for Sphinx documentation
|
||||
#
|
||||
|
||||
# You can set these variables from the command line.
|
||||
SPHINXOPTS =
|
||||
SPHINXBUILD = sphinx-build
|
||||
SOURCEDIR = .
|
||||
BUILDDIR = _build
|
||||
|
||||
# Put it first so that "make" without argument is like "make help".
|
||||
help:
|
||||
@$(SPHINXBUILD) -M help "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O)
|
||||
|
||||
.PHONY: help Makefile
|
||||
|
||||
# Catch-all target: route all unknown targets to Sphinx using the new
|
||||
# "make mode" option. $(O) is meant as a shortcut for $(SPHINXOPTS).
|
||||
%: Makefile
|
||||
@$(SPHINXBUILD) -M $@ "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O)
|
32
docs/conf.py
Normal file
32
docs/conf.py
Normal file
@ -0,0 +1,32 @@
|
||||
import sys
|
||||
import os
|
||||
import sphinx_rtd_theme
|
||||
|
||||
# Support for :base-ref:, etc.
|
||||
sys.path.insert(0, os.path.abspath('.'))
|
||||
|
||||
version = "1.0.0"
|
||||
|
||||
extensions = ['sphinx.ext.extlinks', 'sphinx.ext.todo']
|
||||
|
||||
templates_path = ['_templates']
|
||||
source_suffix = '.rst'
|
||||
source_encoding = 'utf-8-sig'
|
||||
master_doc = 'index'
|
||||
|
||||
project = u'Rel8'
|
||||
copyright = u'2021 CircuitHub'
|
||||
release = version
|
||||
|
||||
highlight_language = 'haskell'
|
||||
primary_domain = 'haskell'
|
||||
|
||||
exclude_patterns = ['.build', "*.gen.rst"]
|
||||
|
||||
# on_rtd is whether we are on readthedocs.org, this line of code grabbed from docs.readthedocs.org
|
||||
on_rtd = os.environ.get('READTHEDOCS', None) == 'True'
|
||||
|
||||
if not on_rtd: # only import and set the theme if we're building docs locally
|
||||
import sphinx_rtd_theme
|
||||
html_theme = 'sphinx_rtd_theme'
|
||||
html_theme_path = [sphinx_rtd_theme.get_html_theme_path()]
|
167
docs/cookbook.rst
Normal file
167
docs/cookbook.rst
Normal file
@ -0,0 +1,167 @@
|
||||
Cookbook
|
||||
========
|
||||
|
||||
This cookbook exists to help you easily form Rel8 queries. It's main purpose is
|
||||
to help those familiar with SQL to translate their queries into Rel8
|
||||
``Query``\s.
|
||||
|
||||
``SELECT * FROM table``
|
||||
-----------------------
|
||||
|
||||
To select from a table, use ``each``.
|
||||
|
||||
Inner joins
|
||||
-----------
|
||||
|
||||
To perform an inner join against two queries, use ``where_`` with a join
|
||||
condition. For example, the following SQL:
|
||||
|
||||
.. code-block:: sql
|
||||
|
||||
SELECT * FROM table_a JOIN table_b ON table_a.x = table_b.y
|
||||
|
||||
can be written as::
|
||||
|
||||
myQuery = do
|
||||
a <- each tableA
|
||||
b <- each tableB
|
||||
where_ $ tableAX a ==. tableBY b
|
||||
|
||||
Left (outer) joins
|
||||
------------------
|
||||
|
||||
A ``LEFT JOIN`` query is performed by using ``optional``.
|
||||
|
||||
For example, the query:
|
||||
|
||||
.. code-block:: sql
|
||||
|
||||
SELECT * FROM table_a LEFT JOIN table_b ON table_a.x = table_b.y
|
||||
|
||||
can be written as::
|
||||
|
||||
myQuery = do
|
||||
a <- each tableA
|
||||
|
||||
maybeB <- optional do
|
||||
b <- each tableB
|
||||
where_ $ tableAX a ==. tableBY b
|
||||
|
||||
return (a, maybeB)
|
||||
|
||||
Note that ``maybeB`` here will be a ``MaybeTable``, which is the Rel8
|
||||
``Query``-equivalent of ``Maybe``. This allows you to observe if a left join
|
||||
has succeeded or failed.
|
||||
|
||||
Ordering results
|
||||
----------------
|
||||
|
||||
A ``Query`` by default has no ordering - just like in SQL. If you rows back in
|
||||
a certain order, you can use ``orderBy`` with an ``Order``.
|
||||
|
||||
For example, the query:
|
||||
|
||||
.. code-block:: sql
|
||||
|
||||
SELECT * FROM my_table ORDER BY my_table.id ASC, my_table.x DESC NULLS FIRST
|
||||
|
||||
can be written as::
|
||||
|
||||
myQuery =
|
||||
orderBy (mconcat [ myTableId >$< asc, myTableX >$< nullsFirst desc ]) $
|
||||
each myTableSchema
|
||||
|
||||
Note that we use ``>$<`` (from ``Data.Functor.Contravariant``) to select table
|
||||
columns, and we can use `mconcat` to combine orderings.
|
||||
|
||||
If all columns of a table have an ordering, you can also use ``ascTable`` and
|
||||
``descTable``. For example::
|
||||
|
||||
myQuery = orderBy ascTable $ each myTableSchema
|
||||
|
||||
Aggregations
|
||||
------------
|
||||
|
||||
Aggregations in Rel8 work by using ``aggregate``, which takes a ``Query
|
||||
(Aggregate a)`` and gives you back a ``Query a``.
|
||||
|
||||
The following query:
|
||||
|
||||
.. code-block:: sql
|
||||
|
||||
SELECT sum(foo), count(distinct bar) FROM table_a
|
||||
|
||||
can be written as::
|
||||
|
||||
myQuery = aggregate do
|
||||
a <- each tableA
|
||||
return $ liftF2 (,) (sum (foo a)) (countDistinct (bar a))
|
||||
|
||||
where ``liftF2`` comes from ``Data.Functor.Apply`` from the ``semigroupoids``
|
||||
library.
|
||||
|
||||
Combining aggregations
|
||||
----------------------
|
||||
|
||||
As ``Aggregate`` is an instance of ``Apply`` (which is very similar to
|
||||
``Applicative``), individual aggregations can be combined. For example, one way
|
||||
to take the average rating would be to write the query:
|
||||
|
||||
.. code-block:: sql
|
||||
|
||||
SELECT sum(rating.score) / count(rating.score) FROM rating
|
||||
|
||||
In Rel8, we can write this as::
|
||||
|
||||
myQuery = aggregate do
|
||||
rating <- each ratingSchema
|
||||
return $ liftF2 (/) (sum (score rating)) (count (score rating))
|
||||
|
||||
You can also use ``RebindableSyntax`` and ``ApplicativeDo``::
|
||||
|
||||
{-# language ApplicativeDo, RebindableSyntax #-}
|
||||
|
||||
import Data.Functor.Apply ((<.>))
|
||||
|
||||
myQuery = aggregate do
|
||||
rating <- each ratingSchema
|
||||
return do
|
||||
scoreSum <- sum (score rating)
|
||||
numberOfRatings <- count (score rating)
|
||||
return (scoreSum / numberOfRatings)
|
||||
where (<*>) = (<.>)
|
||||
|
||||
For large aggregations, this can often make queries easier to read.
|
||||
|
||||
Tree-like queries
|
||||
-----------------
|
||||
|
||||
Rel8 has a fairly unique feature in that it's able to return not just lists of
|
||||
rows, but can also return *tree*\s.
|
||||
|
||||
To understand what this means, we'll consider a small example query for blog
|
||||
posts. We want our query to return:
|
||||
|
||||
1. The latest 5 blog posts.
|
||||
2. For each blog post, all tags.
|
||||
3. For each blog post, the latest 3 comments.
|
||||
|
||||
In Rel8, we can write this query as::
|
||||
|
||||
latestBlogPosts = do
|
||||
post <- each postSchema
|
||||
|
||||
tags <- aggregate do
|
||||
tag <- each tagSchema
|
||||
where_ (tagPostId tag ==. postId post)
|
||||
return (listAgg (tagName tag))
|
||||
|
||||
latestComments <-
|
||||
many $
|
||||
limit 3 $
|
||||
orderBy (commentCreatedAt >$< desc) do
|
||||
comment <- each commentSchema
|
||||
where_ (commentPostId comment ==. postId post)
|
||||
|
||||
return (post, tags, latestComments)
|
||||
|
38
docs/index.rst
Normal file
38
docs/index.rst
Normal file
@ -0,0 +1,38 @@
|
||||
Welcome to Rel8!
|
||||
================================
|
||||
|
||||
Welcome to Rel8! Rel8 is a Haskell library for interacting with PostgreSQL
|
||||
databases, built on top of the fantastic `Opaleye
|
||||
<https://hackage.haskell.org/package/opaleye>`_ library.
|
||||
|
||||
The main objectives of Rel8 are:
|
||||
|
||||
* *Conciseness*: Users using Rel8 should not need to write boiler-plate code.
|
||||
By using expressive types, we can provide sufficient information for the
|
||||
compiler to infer code whenever possible.
|
||||
|
||||
* *Inferrable*: Despite using a lot of type level magic, Rel8 aims to have
|
||||
excellent and predictable type inference.
|
||||
|
||||
* *Familiar*: writing Rel8 queries should feel like normal Haskell programming.
|
||||
|
||||
.. toctree::
|
||||
:maxdepth: 3
|
||||
:caption: Contents:
|
||||
|
||||
tutorial
|
||||
cookbook
|
||||
|
||||
|
||||
More Resources
|
||||
==============
|
||||
|
||||
* The `Haskell API documentation <https://hackage.haskell.org/package/rel8>`_
|
||||
describes how individual functions are types are to be used.
|
||||
|
||||
* If you have a question about how to use Rel8, feel free to open a `GitHub
|
||||
discussion <https://github.com/circuithub/rel8/discussions>`_.
|
||||
|
||||
* If you think you've found a bug, confusing behavior, or have a feature
|
||||
request, please raise an issue at `Rel8's issue tracker
|
||||
<https://github.com/circuithub/rel8>`_.
|
3
docs/requirements.txt
Normal file
3
docs/requirements.txt
Normal file
@ -0,0 +1,3 @@
|
||||
sphinx == 3.1.*
|
||||
sphinx_rtd_theme
|
||||
|
368
docs/tutorial.rst
Normal file
368
docs/tutorial.rst
Normal file
@ -0,0 +1,368 @@
|
||||
.. highlight:: haskell
|
||||
|
||||
Getting Started
|
||||
===============
|
||||
|
||||
In this section, we'll take a look at using Rel8 to work with a small database
|
||||
for Haskell packages. We'll take a look at idiomatic usage of Rel8, mapping
|
||||
tables to Haskell, and then look at writing some simple queries.
|
||||
|
||||
Before we get started, we'll be using the following language extensions and
|
||||
imports throughout this guide::
|
||||
|
||||
{-# language -XBlockArguments #-}
|
||||
{-# language -XDeriveAnyClass #-}
|
||||
{-# language -XDeriveGeneric #-}
|
||||
{-# language -XDerivingStrategies #-}
|
||||
{-# language -XDerivingVia #-}
|
||||
{-# language -XDuplicateRecordFields #-}
|
||||
{-# language -XGeneralizedNewtypeDeriving #-}
|
||||
{-# language -XOverloadedStrings #-}
|
||||
{-# language -XStandaloneDeriving #-}
|
||||
{-# language -XTypeApplications #-}
|
||||
{-# language -XTypeFamilies #-}
|
||||
|
||||
import Prelude
|
||||
|
||||
The Example Schema
|
||||
------------------
|
||||
|
||||
Before we start writing any Haskell, let's take a look at the schema we'll work
|
||||
with. The `author` table has three columns:
|
||||
|
||||
+-----------------+-------------+----------+
|
||||
| Column Name | Type | Nullable |
|
||||
+=================+=============+==========+
|
||||
| ``author_id`` | ``integer`` | not null |
|
||||
+-----------------+-------------+----------+
|
||||
| ``name`` | ``text`` | not null |
|
||||
+-----------------+-------------+----------+
|
||||
| ``url`` | ``text`` | |
|
||||
+-----------------+-------------+----------+
|
||||
|
||||
and the `project` table has two:
|
||||
|
||||
+-----------------+-------------+----------+
|
||||
| Column Name | Type | Nullable |
|
||||
+=================+=============+==========+
|
||||
| ``author_id`` | ``integer`` | not null |
|
||||
+-----------------+-------------+----------+
|
||||
| ``name`` | ``text`` | not null |
|
||||
+-----------------+-------------+----------+
|
||||
|
||||
A ``project`` always has an ``author``, but not all ``author``\s have projects.
|
||||
Each ``author`` has a name and (maybe) an associated website, and each project
|
||||
has a name.
|
||||
|
||||
Mapping Schemas to Haskell
|
||||
--------------------------
|
||||
|
||||
Now that we've seen our schema, we can begin writing a mapping in Rel8. The
|
||||
idiomatic way to map a table is to use a record that is parameterised what Rel8
|
||||
calls an *interpretation functor*, and to define each field with ``Column``.
|
||||
For this type to be usable with Rel8 we need it to be an instance of
|
||||
``Rel8able``, which can be derived with a combination of ``DeriveAnyClass`` and
|
||||
``DeriveGeneric`` language extensions.
|
||||
|
||||
Following these steps for ``author``, we have::
|
||||
|
||||
data Author f = Author
|
||||
{ authorId :: Column f Int64
|
||||
, name :: Column f Text
|
||||
, url :: Column f (Maybe Text)
|
||||
}
|
||||
deriving stock (Generic)
|
||||
deriving anyclass (Rel8able)
|
||||
|
||||
This is a perfectly reasonable definition, but cautious readers might notice a
|
||||
problem - in particular, with the type of the ``authorId`` field. While
|
||||
``Int64`` is correct, it's not the best type. If we had other identifier types
|
||||
in our project, it would be too easy to accidentally mix them up and create
|
||||
nonsensical joins. As Haskell programmers, we often solve this problem by
|
||||
creating ``newtype`` wrappers, and we can also use this technique with Rel8::
|
||||
|
||||
newtype AuthorId = AuthorId { toInt64 :: Int64 }
|
||||
deriving newtype (DBEq, DBType, Eq, Show)
|
||||
|
||||
Now we can write our final schema mapping. First, the ``author`` table::
|
||||
|
||||
data Author f = Author
|
||||
{ authorId :: Column f AuthorId
|
||||
, authorName :: Column f Text
|
||||
, authorUrl :: Column f (Maybe Text)
|
||||
}
|
||||
deriving stock (Generic)
|
||||
deriving anyclass (Rel8able)
|
||||
|
||||
And similarly, the ``project`` table::
|
||||
|
||||
data Project f = Project
|
||||
{ projectAuthorId :: Column f AuthorId
|
||||
, projectName :: Column f Text
|
||||
}
|
||||
deriving stock (Generic)
|
||||
deriving anyclass (Rel8able
|
||||
|
||||
To show query results in this documentation, we'll also need ``Show`` instances:
|
||||
Unfortunately these definitions look a bit scary, but they are essentially just
|
||||
``deriving (Show)``::
|
||||
|
||||
deriving stock instance f ~ Identity => Show (Author f)
|
||||
deriving stock instance f ~ Identity => Show (Project f)
|
||||
|
||||
These data types describe the structural mapping of the tables, but we also
|
||||
need to specify a ``TableSchema`` for each table. A ``TableSchema`` contains
|
||||
the name of the table and the name of all columns in the table, which will
|
||||
ultimately allow us to ``SELECT`` and ``INSERT`` rows for these tables.
|
||||
|
||||
To define a ``TableSchema``, we just need to fill construct appropriate
|
||||
``TableSchema`` values. When it comes to the ``tableColumns`` field, we
|
||||
construct values of our data types above, and set each field to the name of the
|
||||
column that it maps to.
|
||||
|
||||
First, ``authorSchema`` describes the column names of the ``author`` table when
|
||||
associated with the ``Author`` type::
|
||||
|
||||
authorSchema :: TableSchema (Author Name)
|
||||
authorSchema = TableSchema
|
||||
{ tableName = "author"
|
||||
, tableSchema = Nothing
|
||||
, tableColumns = Author
|
||||
{ authorId = "author_id"
|
||||
, authorName = "name"
|
||||
, authorUrl = "url"
|
||||
}
|
||||
}
|
||||
|
||||
And likewise for ``project`` and ``Project``::
|
||||
|
||||
projectSchema :: TableSchema (Project Name)
|
||||
projectSchema = TableSchema
|
||||
{ tableName = "project"
|
||||
, tableSchema = Nothing
|
||||
, tableColumns = Project
|
||||
{ projectAuthorId = "author_id"
|
||||
, projectName = "name"
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
.. note::
|
||||
|
||||
You might be wondering why this information isn't in the definitions of
|
||||
``Author`` and ``Project`` above. Rel8 decouples ``TableSchema`` from the data
|
||||
types themselves, as not all tables you define will necessarily have a schema.
|
||||
For example, Rel8 allows you to define helper types to simplify the types of
|
||||
queries - these tables only exist at query time, but there is no corresponding
|
||||
base table. We'll see more on this idea later!
|
||||
|
||||
With these table definitions, we can now start writing some queries!
|
||||
|
||||
Writing Queries
|
||||
---------------
|
||||
|
||||
Simple Queries
|
||||
~~~~~~~~~~~~~~
|
||||
|
||||
First, we'll take a look at ``SELECT`` statements - usually the bulk of most
|
||||
database heavy applications.
|
||||
|
||||
In Rel8, ``SELECT`` statements are built using the ``Query`` monad. You can
|
||||
think of this monad like the ordinary ``[]`` (List) monad - but this isn't
|
||||
required knowledge.
|
||||
|
||||
To start, we'll look at one of the simplest queries possible - a basic ``SELECT
|
||||
* FROM`` statement. To select all rows from a table, we use ``each``, and
|
||||
supply a ``TableSchema``. So to select all ``project`` rows, we can write::
|
||||
|
||||
>>> :t each projectSchema
|
||||
each projectSchema :: Query (Project Expr)
|
||||
|
||||
Notice that ``each`` gives us a ``Query`` that yields ``Project Expr`` rows. To
|
||||
see what this means, let's have a look at a single field of a ``Project Expr``::
|
||||
|
||||
>>> let aProjectExpr = undefined :: Project Expr
|
||||
>>> :t projectAuthorId aProjectExpr
|
||||
projectAuthorId aProjectExpr :: Expr AuthorId
|
||||
|
||||
Recall we defined ``projectAuthorId`` as ``Column f AuthorId``. Now we have
|
||||
``f`` is ``Expr``, and ``Column Expr AuthorId`` reduces to ``Expr AuthorId``.
|
||||
We'll see more about ``Expr`` soon, but you can think of ``Expr a`` as "SQL
|
||||
expressions of type ``a``\".
|
||||
|
||||
To execute this ``Query``, we pass it to ``select``::
|
||||
|
||||
>>> :t select c (each projectSchema)
|
||||
select c (each projectSchema) :: MonadIO m => m [Project Identity]
|
||||
|
||||
When we ``select`` things containing ``Expr``s, Rel8 builds a new response
|
||||
table with the ``Identity`` interpretation. This means you'll get back plain
|
||||
Haskell values. Studying ``projectAuthorId`` again, we have::
|
||||
|
||||
>>> let aProjectIdentity = undefined :: Project Identity
|
||||
>>> :t projectAuthorId aProjectIdentity
|
||||
projectAuthorId aProjectIdentity :: AuthorId
|
||||
|
||||
Here ``Column Identity AuthorId`` reduces to just ``AuthorId``, with no
|
||||
wrappping type at all.
|
||||
|
||||
Putting this all together, we can run our first query::
|
||||
|
||||
>>> select c (each projectSchema) >>= mapM_ print
|
||||
Project {projectAuthorId = 1, projectName = "rel8"}
|
||||
Project {projectAuthorId = 2, projectName = "aeson"}
|
||||
Project {projectAuthorId = 2, projectName = "text"}
|
||||
|
||||
We now know that ``each`` is the equivalent of a ``SELECT *`` query, but
|
||||
sometimes we're only interested in a subset of the columns of a table. To
|
||||
restrict the returned columns, we can specify a projection by using ``Query``\s
|
||||
``Functor`` instance::
|
||||
|
||||
>>> select c $ projectName <$> each projectSchema
|
||||
["rel8","aeson","text"]
|
||||
|
||||
Joins
|
||||
~~~~~
|
||||
|
||||
Another common operation in relational databases is to take the ``JOIN`` of
|
||||
multiple tables. Rel8 doesn't have a specific join operation, but we can
|
||||
recover the functionality of a join by selecting all rows of two tables, and
|
||||
then using ``where_`` to filter them.
|
||||
|
||||
To see how this works, first let's look at taking the product of two tables.
|
||||
We can do this by simply calling ``each`` twice, and then returning a tuple of
|
||||
their results::
|
||||
|
||||
>>> :{
|
||||
mapM_ print =<< select c do
|
||||
author <- each authorSchema
|
||||
project <- each projectSchema
|
||||
return (projectName project, authorName author)
|
||||
:}
|
||||
("rel8","Ollie")
|
||||
("rel8","Bryan O'Sullivan")
|
||||
("rel8","Emily Pillmore")
|
||||
("aeson","Ollie")
|
||||
("aeson","Bryan O'Sullivan")
|
||||
("aeson","Emily Pillmore")
|
||||
("text","Ollie")
|
||||
("text","Bryan O'Sullivan")
|
||||
("text","Emily Pillmore")
|
||||
|
||||
This isn't quite right, though, as we have ended up pairing up the wrong
|
||||
projects and authors. To fix this, we can use ``where_`` to restrict the
|
||||
returned rows. We could write::
|
||||
|
||||
select c $ do
|
||||
author <- each authorSchema
|
||||
project <- each projectSchema
|
||||
where_ $ projectAuthorId project ==. authorId author
|
||||
return (project, author)
|
||||
|
||||
but doing this every time you need a join can obscure the meaning of the
|
||||
query you're writing. A good practice is to introduce specialised functions
|
||||
for the particular joins in your database. In our case, this would be::
|
||||
|
||||
projectsForAuthor :: Author Expr -> Query (Project Expr)
|
||||
projectsForAuthor a = each projectSchema >>= filter \p ->
|
||||
projectAuthorId p ==. authorId a
|
||||
|
||||
Our final query is then::
|
||||
|
||||
>>> :{
|
||||
mapM_ print =<< select c do
|
||||
author <- each authorSchema
|
||||
project <- projectsForAuthor author
|
||||
return (projectName project, authorName author)
|
||||
:}
|
||||
("rel8","Ollie")
|
||||
("aeson","Bryan O'Sullivan")
|
||||
("text","Bryan O'Sullivan")
|
||||
|
||||
Left Joins
|
||||
~~~~~~~~~~
|
||||
|
||||
Rel8 is also capable of performing ``LEFT JOIN``\s. To perform ``LEFT JOIN``\s,
|
||||
we follow the same approach as before, but use the ``optional`` query
|
||||
transformer to allow for the possibility of the join to fail.
|
||||
|
||||
In our test database, we can see that there's another author who we haven't
|
||||
seen yet::
|
||||
|
||||
>>> select c $ authorName <$> each authorSchema
|
||||
["Ollie","Bryan O'Sullivan","Emily Pillmore"]
|
||||
|
||||
Emily wasn't returned in our earlier query because - in our database - she
|
||||
doesn't have any registered projects. We can account for this partiality in our
|
||||
original query by wrapping the ``projectsForAuthor`` call with ``optional``::
|
||||
|
||||
>>> :{
|
||||
mapM_ print =<< select c do
|
||||
author <- each authorSchema
|
||||
mproject <- optional $ projectsForAuthor author
|
||||
return (authorName author, projectName <$> mproject)
|
||||
:}
|
||||
("Ollie",Just "rel8")
|
||||
("Bryan O'Sullivan",Just "aeson")
|
||||
("Bryan O'Sullivan",Just "text")
|
||||
("Emily Pillmore",Nothing)
|
||||
|
||||
|
||||
Aggregation
|
||||
~~~~~~~~~~~
|
||||
|
||||
Aggregations are operations like ``sum`` and ``count`` - operations that reduce
|
||||
multiple rows to single values. To perform aggregations in Rel8, we can use the
|
||||
``aggregate`` function, which takes a ``Query`` of aggregated expressions, runs
|
||||
the aggregation, and returns aggregated rows.
|
||||
|
||||
To start, let's look at a simple aggregation that tells us how many projects
|
||||
exist::
|
||||
|
||||
>>> error "TODO"
|
||||
|
||||
Rel8 is also capable of aggregating multiple rows into a single row by
|
||||
concatenating all rows as a list. This aggregation allows us to break free of
|
||||
the row-orientated nature of SQL and write queries that return tree-like
|
||||
structures. Earlier we saw an example of returning authors with their projects,
|
||||
but the query didn't do a great job of describing the one-to-many relationship
|
||||
between authors and their projects.
|
||||
|
||||
Let's look again at a query that returns authors and their projects, and
|
||||
focus on the /type/ of that query::
|
||||
|
||||
projectsForAuthor a = each projectSchema >>= filter \p ->
|
||||
projectAuthorId p ==. authorId a
|
||||
|
||||
let authorsAndProjects = do
|
||||
author <- each authorSchema
|
||||
project <- projectsForAuthor author
|
||||
return (author, project)
|
||||
where
|
||||
|
||||
>>> :t select c authorsAndProjects
|
||||
select c authorsAndProjects
|
||||
:: MonadIO m => m [(Author Identity, Project Identity)]
|
||||
|
||||
|
||||
Our query gives us a single list of pairs of authors and projects. However,
|
||||
with our domain knowledge of the schema, this isn't a great type - what we'd
|
||||
rather have is a list of pairs of authors and /lists/ of projects. That is,
|
||||
what we'd like is::
|
||||
|
||||
[(Author Identity, [Project Identity])]
|
||||
|
||||
This would be a much better type! Rel8 can produce a query with this type by
|
||||
simply wrapping the call to ``projectsForAuthor`` with either ``some`` or
|
||||
``many``. Here we'll use ``many``, which allows for the possibility of an
|
||||
author to have no projects::
|
||||
|
||||
>>> :{
|
||||
mapM_ print =<< select c do
|
||||
author <- each authorSchema
|
||||
projectNames <- many $ projectName <$> projectsForAuthor author
|
||||
return (authorName author, projectNames)
|
||||
:}
|
||||
("Ollie",["rel8"])
|
||||
("Bryan O'Sullivan",["aeson","text"])
|
||||
("Emily Pillmore",[])
|
5
jobs.nix
5
jobs.nix
@ -1,5 +0,0 @@
|
||||
let rel8 = (import ./.).hsPkgs.rel8;
|
||||
in {
|
||||
rel8 = rel8.components.library;
|
||||
tests = rel8.checks.tests;
|
||||
}
|
@ -1,14 +1,14 @@
|
||||
{
|
||||
"haskell.nix": {
|
||||
"branch": "circuithub",
|
||||
"branch": "master",
|
||||
"description": "Alternative Haskell Infrastructure for Nixpkgs",
|
||||
"homepage": "https://input-output-hk.github.io/haskell.nix",
|
||||
"owner": "circuithub",
|
||||
"owner": "input-output-hk",
|
||||
"repo": "haskell.nix",
|
||||
"rev": "2902f9b49484a87afb0e1a33b1d88a2c7b8ca0a0",
|
||||
"sha256": "0a01g5b46z5yaf2mnl415hc4lciwiyqhj22qhgwgwd261w4068iy",
|
||||
"rev": "486de5bfd4e7a93d999dc09969cb1278b9a43f30",
|
||||
"sha256": "12mal6p6z946z1w0knv04dkhpjmyqlaccmkf7skv23bf8iqg6gaz",
|
||||
"type": "tarball",
|
||||
"url": "https://github.com/circuithub/haskell.nix/archive/2902f9b49484a87afb0e1a33b1d88a2c7b8ca0a0.tar.gz",
|
||||
"url": "https://github.com/input-output-hk/haskell.nix/archive/486de5bfd4e7a93d999dc09969cb1278b9a43f30.tar.gz",
|
||||
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
|
||||
},
|
||||
"niv": {
|
||||
@ -17,10 +17,10 @@
|
||||
"homepage": "https://github.com/nmattia/niv",
|
||||
"owner": "nmattia",
|
||||
"repo": "niv",
|
||||
"rev": "ba57d5a29b4e0f2085917010380ef3ddc3cf380f",
|
||||
"sha256": "1kpsvc53x821cmjg1khvp1nz7906gczq8mp83664cr15h94sh8i4",
|
||||
"rev": "af958e8057f345ee1aca714c1247ef3ba1c15f5e",
|
||||
"sha256": "1qjavxabbrsh73yck5dcq8jggvh3r2jkbr6b5nlz5d9yrqm9255n",
|
||||
"type": "tarball",
|
||||
"url": "https://github.com/nmattia/niv/archive/ba57d5a29b4e0f2085917010380ef3ddc3cf380f.tar.gz",
|
||||
"url": "https://github.com/nmattia/niv/archive/af958e8057f345ee1aca714c1247ef3ba1c15f5e.tar.gz",
|
||||
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
|
||||
},
|
||||
"nixpkgs": {
|
||||
@ -29,22 +29,10 @@
|
||||
"homepage": null,
|
||||
"owner": "nixos",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "6e7f25001fe6874f7ae271891f709bbf50a22c45",
|
||||
"sha256": "1x04j4351pqiqbpkq6g308mxcvb5aqnwv8l2vmlxkgvq5phzky7z",
|
||||
"rev": "da7f4c4842520167f65c20ad75ecdbd14e27ae91",
|
||||
"sha256": "0vdq6lkc1sqj85x8r8idpck3igjns8ix57fqf1r5pm4k0qhy7p2m",
|
||||
"type": "tarball",
|
||||
"url": "https://github.com/nixos/nixpkgs/archive/6e7f25001fe6874f7ae271891f709bbf50a22c45.tar.gz",
|
||||
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
|
||||
},
|
||||
"nixpkgs-unstable": {
|
||||
"branch": "master",
|
||||
"description": "Nix Packages collection",
|
||||
"homepage": "",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "059d331839e2a60dfbc0dce6fbc30fa54772fd2c",
|
||||
"sha256": "06nrv2j65gfkqfqzji5vhwngdi5pmra7sq9493j74msrb19kq595",
|
||||
"type": "tarball",
|
||||
"url": "https://github.com/NixOS/nixpkgs/archive/059d331839e2a60dfbc0dce6fbc30fa54772fd2c.tar.gz",
|
||||
"url": "https://github.com/nixos/nixpkgs/archive/da7f4c4842520167f65c20ad75ecdbd14e27ae91.tar.gz",
|
||||
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
|
||||
}
|
||||
}
|
||||
|
29
rel8.cabal
29
rel8.cabal
@ -6,18 +6,12 @@ license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Oliver Charles
|
||||
maintainer: ollie@ocharles.org.uk
|
||||
build-type: Custom
|
||||
|
||||
custom-setup
|
||||
setup-depends:
|
||||
base >= 4 && <5,
|
||||
Cabal,
|
||||
cabal-doctest >= 1 && <1.1
|
||||
build-type: Simple
|
||||
|
||||
library
|
||||
build-depends:
|
||||
aeson
|
||||
, base ^>=4.12 || ^>= 4.13 || ^>= 4.14
|
||||
, base ^>= 4.14 || ^>=4.15
|
||||
, bytestring
|
||||
, case-insensitive
|
||||
, casing
|
||||
@ -48,6 +42,9 @@ library
|
||||
Rel8.Expr.Time
|
||||
Rel8.Tabulate
|
||||
|
||||
-- deprecated
|
||||
Rel8.Aggregate.Legacy
|
||||
|
||||
other-modules:
|
||||
Rel8.Aggregate
|
||||
|
||||
@ -147,6 +144,7 @@ library
|
||||
Rel8.Table.Order
|
||||
Rel8.Table.Recontextualize
|
||||
Rel8.Table.Serialize
|
||||
Rel8.Table.Tag
|
||||
Rel8.Table.These
|
||||
Rel8.Table.Undefined
|
||||
|
||||
@ -198,21 +196,6 @@ test-suite tests
|
||||
-Wno-missing-import-lists -Wno-prepositive-qualified-module
|
||||
-Wno-deprecations -Wno-monomorphism-restriction
|
||||
-Wno-missing-local-signatures -Wno-implicit-prelude
|
||||
buildable: False
|
||||
|
||||
test-suite doctests
|
||||
type: exitcode-stdio-1.0
|
||||
build-depends:
|
||||
base
|
||||
, base-compat
|
||||
, bytestring
|
||||
, doctest
|
||||
, hasql
|
||||
, tmp-postgres
|
||||
|
||||
main-is: Doctest.hs
|
||||
default-language: Haskell2010
|
||||
buildable: False
|
||||
|
||||
test-suite random-queries
|
||||
type: exitcode-stdio-1.0
|
||||
|
@ -6,7 +6,7 @@ let
|
||||
in
|
||||
hsPkgs.shellFor {
|
||||
withHoogle = true;
|
||||
tools = { cabal = "3.2.0.0"; haskell-language-server = "latest"; };
|
||||
tools = { cabal = "latest"; };
|
||||
exactDeps = false;
|
||||
buildInputs = [ unstable.postgresql_13 ];
|
||||
buildInputs = [ unstable.postgresql_13 pkgs.pythonPackages.sphinx ];
|
||||
}
|
||||
|
383
src/Rel8.hs
383
src/Rel8.hs
@ -1,19 +1,7 @@
|
||||
{-# language DuplicateRecordFields #-}
|
||||
|
||||
module Rel8
|
||||
( -- * Getting Started
|
||||
-- $setup
|
||||
|
||||
-- ** Writing Queries
|
||||
-- $guideQueries
|
||||
|
||||
-- ** Joins
|
||||
-- $guideJoins
|
||||
|
||||
-- ** Aggregation
|
||||
-- $guideAggregation
|
||||
|
||||
-- * Database types
|
||||
( -- * Database types
|
||||
-- ** @DBType@
|
||||
DBType(..)
|
||||
|
||||
@ -39,7 +27,7 @@ module Rel8
|
||||
|
||||
-- * Tables and higher-kinded tables
|
||||
, Rel8able
|
||||
, Column
|
||||
, Column, Field, Necessity( Required, Optional )
|
||||
, Default, Label
|
||||
, HMaybe
|
||||
, HList
|
||||
@ -200,11 +188,6 @@ module Rel8
|
||||
, and
|
||||
, or
|
||||
|
||||
, Aggregates
|
||||
, sequenceAggregate
|
||||
, distributeAggregate
|
||||
|
||||
|
||||
-- ** Ordering
|
||||
, orderBy
|
||||
, Order
|
||||
@ -264,9 +247,11 @@ import Rel8.Expr.Bool
|
||||
import Rel8.Expr.Eq
|
||||
import Rel8.Expr.Function
|
||||
import Rel8.Expr.Null
|
||||
import Rel8.Expr.Opaleye (unsafeCastExpr)
|
||||
import Rel8.Expr.Ord
|
||||
import Rel8.Expr.Order
|
||||
import Rel8.Expr.Serialize
|
||||
import Rel8.Kind.Necessity
|
||||
import Rel8.Order
|
||||
import Rel8.Query
|
||||
import Rel8.Query.Aggregate
|
||||
@ -286,6 +271,7 @@ import Rel8.Query.These
|
||||
import Rel8.Query.Values
|
||||
import Rel8.Schema.Column
|
||||
import Rel8.Schema.Context.Label
|
||||
import Rel8.Schema.Field (Field)
|
||||
import Rel8.Schema.Generic
|
||||
import Rel8.Schema.HTable
|
||||
import Rel8.Schema.Name
|
||||
@ -315,8 +301,8 @@ import Rel8.Table.These
|
||||
import Rel8.Type
|
||||
import Rel8.Type.Eq
|
||||
import Rel8.Type.Information
|
||||
import Rel8.Type.JSONEncoded
|
||||
import Rel8.Type.JSONBEncoded
|
||||
import Rel8.Type.JSONEncoded
|
||||
import Rel8.Type.Monoid
|
||||
import Rel8.Type.Num
|
||||
import Rel8.Type.Ord
|
||||
@ -324,362 +310,5 @@ import Rel8.Type.ReadShow
|
||||
import Rel8.Type.Semigroup
|
||||
import Rel8.Type.String
|
||||
import Rel8.Type.Sum
|
||||
import Rel8.Expr.Opaleye (unsafeCastExpr)
|
||||
|
||||
|
||||
-- $setup
|
||||
--
|
||||
-- In this section, we'll take a look at using Rel8 to work with a small
|
||||
-- database for Haskell packages. We'll take a look at idiomatic usage of Rel8,
|
||||
-- mapping tables to Haskell, and then look at writing some simple queries.
|
||||
--
|
||||
-- The documentation in this library uses the following language extensions:
|
||||
--
|
||||
-- >>> :set -XBlockArguments
|
||||
-- >>> :set -XDeriveAnyClass
|
||||
-- >>> :set -XDeriveGeneric
|
||||
-- >>> :set -XDerivingStrategies
|
||||
-- >>> :set -XDerivingVia
|
||||
-- >>> :set -XDuplicateRecordFields
|
||||
-- >>> :set -XGeneralizedNewtypeDeriving
|
||||
-- >>> :set -XOverloadedStrings
|
||||
-- >>> :set -XStandaloneDeriving
|
||||
-- >>> :set -XTypeApplications
|
||||
-- >>> :set -XTypeFamilies
|
||||
--
|
||||
-- Before we start writing any Haskell, let's take a look at the schema we'll
|
||||
-- work with.
|
||||
--
|
||||
-- > author: project:
|
||||
-- >
|
||||
-- > Column │ Type │ Nullable Column │ Type │ Nullable
|
||||
-- > ═══════════╪═════════╪══════════ ═══════════╪═════════╪══════════
|
||||
-- > author_id │ integer │ not null author_id │ integer │ not null
|
||||
-- > name │ text │ not null name │ text │ not null
|
||||
-- > url │ text │
|
||||
--
|
||||
-- Our schema consists of two tables - @author@ and @project@. A @project@
|
||||
-- always has an @author@, but not all @author@s have projects. Each @author@
|
||||
-- has a name and (maybe) an associated website, and each project has a name.
|
||||
--
|
||||
-- Now that we've seen our schema, we can begin writing a mapping in Rel8. The
|
||||
-- idiomatic way to map a table is to use a record that is parameterised what
|
||||
-- Rel8 calls an /interpretation functor/, and to define each field with
|
||||
-- 'Column'. For this type to be usable with Rel8 we need it to be an instance
|
||||
-- of 'HigherKindedTable', which can be derived with a combination of
|
||||
-- @DeriveAnyClass@ and @DeriveGeneric@.
|
||||
--
|
||||
-- Following these steps for @author@, we have:
|
||||
--
|
||||
-- > data Author f = Author
|
||||
-- > { authorId :: Column f Int64
|
||||
-- > , name :: Column f Text
|
||||
-- > , url :: Column f (Maybe Text)
|
||||
-- > } deriving (Generic, HigherKindedTable)
|
||||
--
|
||||
-- This is a perfectly reasonable definition, but cautious readers might notice
|
||||
-- a problem - in particular, with the type of the @authorId@ field. While
|
||||
-- @Int64@ is correct, it's not the best type. If we had other identifier types
|
||||
-- in our project, it would be too easy to accidentally mix them up and create
|
||||
-- nonsensical joins. As Haskell programmers, we often solve this problem by
|
||||
-- creating @newtype@ wrappers, and we can also use this technique with Rel8:
|
||||
--
|
||||
-- >>> :{
|
||||
-- newtype AuthorId = AuthorId { toInt64 :: Int64 }
|
||||
-- deriving newtype (DBEq, DBType, Eq, Show)
|
||||
-- :}
|
||||
--
|
||||
-- Now we can write our final schema mapping. First, the @author@ table:
|
||||
--
|
||||
-- >>> :{
|
||||
-- data Author f = Author
|
||||
-- { authorId :: Column f AuthorId
|
||||
-- , authorName :: Column f Text
|
||||
-- , authorUrl :: Column f (Maybe Text)
|
||||
-- }
|
||||
-- deriving stock Generic
|
||||
-- deriving anyclass HigherKindedTable
|
||||
-- :}
|
||||
--
|
||||
-- And similarly, the @project@ table:
|
||||
--
|
||||
-- >>> :{
|
||||
-- data Project f = Project
|
||||
-- { projectAuthorId :: Column f AuthorId
|
||||
-- , projectName :: Column f Text
|
||||
-- }
|
||||
-- deriving stock Generic
|
||||
-- deriving anyclass HigherKindedTable
|
||||
-- :}
|
||||
--
|
||||
-- To show query results in this documentation, we'll also need @Show@
|
||||
-- instances: Unfortunately these definitions look a bit scary, but they are
|
||||
-- essentially just @deriving (Show)@:
|
||||
--
|
||||
-- >>> deriving stock instance f ~ Identity => Show (Author f)
|
||||
-- >>> deriving stock instance f ~ Identity => Show (Project f)
|
||||
--
|
||||
-- These data types describe the structural mapping of the tables, but we also
|
||||
-- need to specify a 'TableSchema' for each table. A @TableSchema@ contains the
|
||||
-- name of the table and the name of all columns in the table, which will
|
||||
-- ultimately allow us to @SELECT@ and @INSERT@ rows for these tables.
|
||||
--
|
||||
-- To define a @TableSchema@, we just need to fill construct appropriate
|
||||
-- @TableSchema@ values. When it comes to the @tableColumns@ field, we
|
||||
-- construct values of our data types above, and set each field to the name of
|
||||
-- the column that it maps to:
|
||||
--
|
||||
-- First, @authorSchema@ describes the column names of the @author@ table when
|
||||
-- associated with the @Author@ type:
|
||||
--
|
||||
-- >>> :{
|
||||
-- authorSchema :: TableSchema (Author ColumnSchema)
|
||||
-- authorSchema = TableSchema
|
||||
-- { tableName = "author"
|
||||
-- , tableSchema = Nothing
|
||||
-- , tableColumns = Author
|
||||
-- { authorId = "author_id"
|
||||
-- , authorName = "name"
|
||||
-- , authorUrl = "url"
|
||||
-- }
|
||||
-- }
|
||||
-- :}
|
||||
--
|
||||
-- And likewise for @project@ and @Project@:
|
||||
--
|
||||
-- >>> :{
|
||||
-- projectSchema :: TableSchema (Project ColumnSchema)
|
||||
-- projectSchema = TableSchema
|
||||
-- { tableName = "project"
|
||||
-- , tableSchema = Nothing
|
||||
-- , tableColumns = Project
|
||||
-- { projectAuthorId = "author_id"
|
||||
-- , projectName = "name"
|
||||
-- }
|
||||
-- }
|
||||
-- :}
|
||||
--
|
||||
-- Aside: you might be wondering why this information isn't in the definitions
|
||||
-- of @Author@ and @Project@ above. Rel8 decouples @TableSchema@ from the data
|
||||
-- types themselves, as not all tables you define will necessarily have a
|
||||
-- schema. For example, Rel8 allows you to define helper types to simplify the
|
||||
-- types of queries - these tables only exist at query time, but there is no
|
||||
-- corresponding base table. We'll see more on this idea later!
|
||||
--
|
||||
-- With these table definitions, we can now start writing some queries! To
|
||||
-- actually run a query, we'll need a database connection. Rel8 uses the
|
||||
-- @hasql@ library, and for this documentation we'll get the connection string
|
||||
-- from the @$TEST_DATABASE_URL@ environment variable.
|
||||
--
|
||||
-- >>> connectionString <- System.Environment.getEnv "TEST_DATABASE_URL"
|
||||
-- >>> Right c <- Hasql.Connection.acquire (Data.ByteString.Char8.pack connectionString)
|
||||
-- >>> Control.Monad.void $ Hasql.Session.run (Hasql.Session.sql "BEGIN") c
|
||||
|
||||
-- $guideQueries
|
||||
--
|
||||
-- First, we'll take a look at @SELECT@ statements - usually the bulk of most
|
||||
-- database heavy applications.
|
||||
--
|
||||
-- In Rel8, @SELECT@ statements are built using the 'Query' monad. You can
|
||||
-- think of this monad like the ordinary @[]@ (List) monad - but this isn't
|
||||
-- required knowledge.
|
||||
--
|
||||
-- To start, we'll look at one of the simplest queries possible - a basic
|
||||
-- @SELECT * FROM@ statement. To select all rows from a table, we use 'each',
|
||||
-- and supply a 'TableSchema'. So to select all @project@ rows, we can write:
|
||||
--
|
||||
-- >>> :t each projectSchema
|
||||
-- each projectSchema :: Query (Project Expr)
|
||||
--
|
||||
-- Notice that @each@ gives us a @Query@ that yields @Project Expr@ rows. To
|
||||
-- see what this means, let's have a look at a single field of a
|
||||
-- @Project Expr@:
|
||||
--
|
||||
-- >>> let aProjectExpr = undefined :: Project Expr
|
||||
-- >>> :t projectAuthorId aProjectExpr
|
||||
-- projectAuthorId aProjectExpr :: Expr AuthorId
|
||||
--
|
||||
-- Recall we defined @projectAuthorId@ as @Column f AuthorId@. Now we have @f@
|
||||
-- is @Expr@, and @Column Expr AuthorId@ reduces to @Expr AuthorId@. We'll see
|
||||
-- more about @Expr@ soon, but you can think of @Expr a@ as "SQL expressions of
|
||||
-- type @a@".
|
||||
--
|
||||
-- To execute this @Query@, we pass it to 'select':
|
||||
--
|
||||
-- >>> :t select c (each projectSchema)
|
||||
-- select c (each projectSchema) :: MonadIO m => m [Project Identity]
|
||||
--
|
||||
-- When we @select@ things containing @Expr@s, Rel8 builds a new response table
|
||||
-- with the @Identity@ interpretation. This means you'll get back plain Haskell
|
||||
-- values. Studying @projectAuthorId@ again, we have:
|
||||
--
|
||||
-- >>> let aProjectIdentity = undefined :: Project Identity
|
||||
-- >>> :t projectAuthorId aProjectIdentity
|
||||
-- projectAuthorId aProjectIdentity :: AuthorId
|
||||
--
|
||||
-- Here @Column Identity AuthorId@ reduces to just @AuthorId@, with no
|
||||
-- wrappping type at all.
|
||||
--
|
||||
-- Putting this all together, we can run our first query:
|
||||
--
|
||||
-- >>> select c (each projectSchema) >>= mapM_ print
|
||||
-- Project {projectAuthorId = 1, projectName = "rel8"}
|
||||
-- Project {projectAuthorId = 2, projectName = "aeson"}
|
||||
-- Project {projectAuthorId = 2, projectName = "text"}
|
||||
--
|
||||
-- Cool!
|
||||
--
|
||||
-- We now know that 'each' is the equivalent of a @SELECT *@ query, but
|
||||
-- sometimes we're only interested in a subset of the columns of a table. To
|
||||
-- restrict the returned columns, we can specify a projection by using 'Query's
|
||||
-- @Functor@ instance:
|
||||
--
|
||||
-- >>> select c $ projectName <$> each projectSchema
|
||||
-- ["rel8","aeson","text"]
|
||||
|
||||
-- $guideJoins
|
||||
--
|
||||
-- Another common operation in relational databases is to take the @JOIN@ of
|
||||
-- multiple tables. Rel8 doesn't have a specific join operation, but we can
|
||||
-- recover the functionality of a join by selecting all rows of two tables, and
|
||||
-- then using 'where_' to filter them.
|
||||
--
|
||||
-- To see how this works, first let's look at taking the product of two tables.
|
||||
-- We can do this by simply calling 'each' twice, and then returning a tuple of
|
||||
-- their results.
|
||||
--
|
||||
-- >>> :{
|
||||
-- mapM_ print =<< select c do
|
||||
-- author <- each authorSchema
|
||||
-- project <- each projectSchema
|
||||
-- return (projectName project, authorName author)
|
||||
-- :}
|
||||
-- ("rel8","Ollie")
|
||||
-- ("rel8","Bryan O'Sullivan")
|
||||
-- ("rel8","Emily Pillmore")
|
||||
-- ("aeson","Ollie")
|
||||
-- ("aeson","Bryan O'Sullivan")
|
||||
-- ("aeson","Emily Pillmore")
|
||||
-- ("text","Ollie")
|
||||
-- ("text","Bryan O'Sullivan")
|
||||
-- ("text","Emily Pillmore")
|
||||
--
|
||||
-- This isn't quite right, though, as we have ended up pairing up the wrong
|
||||
-- projects and authors. To fix this, we can use 'where_' to restrict the
|
||||
-- returned rows. We could write:
|
||||
--
|
||||
-- > select c $ do
|
||||
-- > author <- each authorSchema
|
||||
-- > project <- each projectSchema
|
||||
-- > where_ $ projectAuthorId project ==. authorId author
|
||||
-- > return (project, author)
|
||||
--
|
||||
-- but doing this every time you need a join can obscure the meaning of the
|
||||
-- query you're writing. A good practice is to introduce specialised functions
|
||||
-- for the particular joins in your database. In our case, this would be:
|
||||
--
|
||||
-- >>> :{
|
||||
-- projectsForAuthor :: Author Expr -> Query (Project Expr)
|
||||
-- projectsForAuthor a = each projectSchema >>= filter \p ->
|
||||
-- projectAuthorId p ==. authorId a
|
||||
-- :}
|
||||
--
|
||||
-- Our final query is then:
|
||||
--
|
||||
-- >>> :{
|
||||
-- mapM_ print =<< select c do
|
||||
-- author <- each authorSchema
|
||||
-- project <- projectsForAuthor author
|
||||
-- return (projectName project, authorName author)
|
||||
-- :}
|
||||
-- ("rel8","Ollie")
|
||||
-- ("aeson","Bryan O'Sullivan")
|
||||
-- ("text","Bryan O'Sullivan")
|
||||
--
|
||||
-- == @LEFT JOIN@s
|
||||
--
|
||||
-- Rel8 is also capable of performing @LEFT JOIN@s. To perform @LEFT JOIN@s, we
|
||||
-- follow the same approach as before, but use the 'optional' query transformer
|
||||
-- to allow for the possibility of the join to fail.
|
||||
--
|
||||
-- In our test database, we can see that there's another author who we haven't
|
||||
-- seen yet:
|
||||
--
|
||||
-- >>> select c $ authorName <$> each authorSchema
|
||||
-- ["Ollie","Bryan O'Sullivan","Emily Pillmore"]
|
||||
--
|
||||
-- Emily wasn't returned in our earlier query because - in our database - she
|
||||
-- doesn't have any registered projects. We can account for this partiality in
|
||||
-- our original query by wrapping the @projectsForAuthor@ call with 'optional':
|
||||
--
|
||||
-- >>> :{
|
||||
-- mapM_ print =<< select c do
|
||||
-- author <- each authorSchema
|
||||
-- mproject <- optional $ projectsForAuthor author
|
||||
-- return (authorName author, projectName <$> mproject)
|
||||
-- :}
|
||||
-- ("Ollie",Just "rel8")
|
||||
-- ("Bryan O'Sullivan",Just "aeson")
|
||||
-- ("Bryan O'Sullivan",Just "text")
|
||||
-- ("Emily Pillmore",Nothing)
|
||||
|
||||
-- $guideAggregation
|
||||
--
|
||||
-- Aggregations are operations like @sum@ and @count@ - operations that reduce
|
||||
-- multiple rows to single values. To perform aggregations in Rel8, we can use
|
||||
-- the 'aggregate' function, which takes a 'Query' of aggregated expressions,
|
||||
-- runs the aggregation, and returns aggregated rows.
|
||||
--
|
||||
-- To start, let's look at a simple aggregation that tells us how many projects
|
||||
-- exist:
|
||||
--
|
||||
-- >>> error "TODO"
|
||||
--
|
||||
-- Rel8 is also capable of aggregating multiple rows into a single row by
|
||||
-- concatenating all rows as a list. This aggregation allows us to break free
|
||||
-- of the row-orientated nature of SQL and write queries that return tree-like
|
||||
-- structures. Earlier we saw an example of returning authors with their
|
||||
-- projects, but the query didn't do a great job of describing the one-to-many
|
||||
-- relationship between authors and their projects.
|
||||
--
|
||||
-- Let's look again at a query that returns authors and their projects, and
|
||||
-- focus on the /type/ of that query.
|
||||
--
|
||||
-- >>> :{
|
||||
-- projectsForAuthor a = each projectSchema >>= filter \p ->
|
||||
-- projectAuthorId p ==. authorId a
|
||||
-- :}
|
||||
--
|
||||
-- >>> :{
|
||||
-- let authorsAndProjects = do
|
||||
-- author <- each authorSchema
|
||||
-- project <- projectsForAuthor author
|
||||
-- return (author, project)
|
||||
-- where
|
||||
-- :}
|
||||
--
|
||||
-- >>> :t select c authorsAndProjects
|
||||
-- select c authorsAndProjects
|
||||
-- :: MonadIO m => m [(Author Identity, Project Identity)]
|
||||
--
|
||||
-- Our query gives us a single list of pairs of authors and projects. However,
|
||||
-- with our domain knowledge of the schema, this isn't a great type - what we'd
|
||||
-- rather have is a list of pairs of authors and /lists/ of projects. That is,
|
||||
-- what we'd like is:
|
||||
--
|
||||
-- > [(Author Identity, [Project Identity])]
|
||||
--
|
||||
-- This would be a much better type! Rel8 can produce a query with this type by
|
||||
-- simply wrapping the call to @projectsForAuthor@ with either 'some' or
|
||||
-- 'many'. Here we'll use 'many', which allows for the possibility of an author
|
||||
-- to have no projects:
|
||||
--
|
||||
-- >>> :{
|
||||
-- mapM_ print =<< select c do
|
||||
-- author <- each authorSchema
|
||||
-- projectNames <- many $ projectName <$> projectsForAuthor author
|
||||
-- return (authorName author, projectNames)
|
||||
-- :}
|
||||
-- ("Ollie",["rel8"])
|
||||
-- ("Bryan O'Sullivan",["aeson","text"])
|
||||
-- ("Emily Pillmore",[])
|
||||
|
@ -12,7 +12,7 @@
|
||||
{-# language UndecidableSuperClasses #-}
|
||||
|
||||
module Rel8.Aggregate
|
||||
( Aggregate(..)
|
||||
( Aggregate(..), foldInputs, mapInputs
|
||||
, Aggregator(..), unsafeMakeAggregate
|
||||
, Aggregates
|
||||
, Col( Aggregation )
|
||||
@ -20,12 +20,9 @@ module Rel8.Aggregate
|
||||
where
|
||||
|
||||
-- base
|
||||
import Control.Applicative ( empty )
|
||||
import Data.Foldable ( fold )
|
||||
import Data.Functor.Const ( Const( Const ), getConst )
|
||||
import Data.Functor.Identity ( Identity )
|
||||
import Data.Kind ( Constraint, Type )
|
||||
import Data.Monoid ( First( First ), getFirst )
|
||||
import Prelude
|
||||
|
||||
-- opaleye
|
||||
@ -35,14 +32,9 @@ import qualified Opaleye.Internal.PackMap as Opaleye
|
||||
|
||||
-- rel8
|
||||
import Rel8.Expr ( Expr, Col(..) )
|
||||
import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
|
||||
import Rel8.Opaque ( Opaque )
|
||||
import Rel8.Schema.Context ( Interpretation(..) )
|
||||
import Rel8.Schema.Context.Label ( Labelable(..) )
|
||||
import Rel8.Schema.Context.Nullify
|
||||
( Nullifiable, encodeTag, decodeTag, nullifier, unnullifier
|
||||
, runTag, unnull
|
||||
)
|
||||
import Rel8.Schema.HTable ( hfield, htabulate, htabulateA, hspecs )
|
||||
import Rel8.Schema.Name ( Name )
|
||||
import Rel8.Schema.Nullability ( Sql )
|
||||
@ -56,7 +48,7 @@ import Data.Functor.Apply ( Apply, WrappedApplicative(..) )
|
||||
|
||||
|
||||
-- | An @Aggregate a@ describes how to aggregate @Table@s of type @a@. You can
|
||||
-- unpack an @Aggregate@ back to @a@ by running it with 'aggregate'. As
|
||||
-- unpack an @Aggregate@ back to @a@ by running it with 'Rel8.aggregate'. As
|
||||
-- @Aggregate@ is almost an 'Applicative' functor - but there is no 'pure'
|
||||
-- operation. This means 'Aggregate' is an instance of 'Apply', and you can
|
||||
-- combine @Aggregate@s using the @<.>@ combinator.
|
||||
@ -117,30 +109,6 @@ instance Labelable Aggregate where
|
||||
unlabeler (Aggregation aggregate) = Aggregation aggregate
|
||||
|
||||
|
||||
instance Nullifiable Aggregate where
|
||||
encodeTag = Aggregation . groupByExpr
|
||||
where
|
||||
groupByExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr Nothing
|
||||
decodeTag (Aggregation aggregate) = fold $ undoGroupBy aggregate
|
||||
where
|
||||
undoGroupBy = getFirst . foldInputs go
|
||||
where
|
||||
go Nothing = pure . fromPrimExpr
|
||||
go _ = const $ First empty
|
||||
|
||||
nullifier tag SSpec {nullability} (Aggregation aggregate) = Aggregation $
|
||||
mapInputs (toPrimExpr . runTag nullability tag . fromPrimExpr) $
|
||||
runTag nullability tag <$> aggregate
|
||||
|
||||
unnullifier _ SSpec {nullability} (Aggregation aggregate) =
|
||||
Aggregation $ unnull nullability <$> aggregate
|
||||
|
||||
{-# INLINABLE encodeTag #-}
|
||||
{-# INLINABLE decodeTag #-}
|
||||
{-# INLINABLE nullifier #-}
|
||||
{-# INLINABLE unnullifier #-}
|
||||
|
||||
|
||||
-- | @Aggregates a b@ means that the columns in @a@ are all 'Aggregate' 'Expr's
|
||||
-- for the columns in @b@.
|
||||
type Aggregates :: Type -> Type -> Constraint
|
||||
|
93
src/Rel8/Aggregate/Legacy.hs
Normal file
93
src/Rel8/Aggregate/Legacy.hs
Normal file
@ -0,0 +1,93 @@
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language NamedFieldPuns #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language ViewPatterns #-}
|
||||
|
||||
module Rel8.Aggregate.Legacy
|
||||
( Aggregates
|
||||
, aggregate
|
||||
, aggregateTabulation
|
||||
, groupBy
|
||||
, listAgg
|
||||
, nonEmptyAgg
|
||||
)
|
||||
where
|
||||
|
||||
-- base
|
||||
import Data.Functor.Identity ( Identity( Identity ) )
|
||||
import Prelude
|
||||
|
||||
-- opaleye
|
||||
import qualified Opaleye.Aggregate as Opaleye
|
||||
|
||||
-- rel8
|
||||
import Rel8.Aggregate ( Aggregates, Col(..) )
|
||||
import Rel8.Expr ( Col(..) )
|
||||
import Rel8.Expr.Aggregate ( groupByExpr, listAggExpr, nonEmptyAggExpr )
|
||||
import Rel8.Query ( Query )
|
||||
import Rel8.Query.Opaleye ( mapOpaleye )
|
||||
import Rel8.Schema.Dict ( Dict( Dict ) )
|
||||
import Rel8.Schema.HTable ( htabulate, hfield )
|
||||
import Rel8.Schema.HTable.Vectorize ( hvectorize )
|
||||
import Rel8.Table ( toColumns, fromColumns )
|
||||
import Rel8.Table.Eq ( EqTable, eqTable )
|
||||
import Rel8.Table.List ( ListTable )
|
||||
import Rel8.Table.NonEmpty ( NonEmptyTable )
|
||||
import Rel8.Table.Opaleye ( aggregator )
|
||||
import Rel8.Tabulate ( Tabulation )
|
||||
import qualified Rel8.Tabulate
|
||||
|
||||
|
||||
-- | Apply an aggregation to all rows returned by a 'Query'.
|
||||
aggregate :: Aggregates aggregates exprs => Query aggregates -> Query exprs
|
||||
aggregate = mapOpaleye (Opaleye.aggregate aggregator) . fmap (fromColumns . toColumns)
|
||||
|
||||
|
||||
aggregateTabulation
|
||||
:: (EqTable k, Aggregates aggregates exprs)
|
||||
=> (t -> aggregates) -> Tabulation k t -> Tabulation k exprs
|
||||
aggregateTabulation f =
|
||||
Rel8.Tabulate.aggregateTabulation . fmap (fromColumns . toColumns . f)
|
||||
|
||||
|
||||
-- | Group equal tables together. This works by aggregating each column in the
|
||||
-- given table with 'groupByExpr'.
|
||||
groupBy :: forall exprs aggregates. (EqTable exprs, Aggregates aggregates exprs)
|
||||
=> exprs -> aggregates
|
||||
groupBy (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
|
||||
case hfield (eqTable @exprs) field of
|
||||
Dict -> case hfield exprs field of
|
||||
DB expr -> Aggregation $ groupByExpr expr
|
||||
|
||||
|
||||
-- | 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 (Item Expr))
|
||||
-- ordersWithItems = do
|
||||
-- order <- each orderSchema
|
||||
-- items <- aggregate $ listAgg <$> itemsFromOrder order
|
||||
-- return (order, items)
|
||||
-- @
|
||||
listAgg :: Aggregates aggregates exprs => exprs -> ListTable aggregates
|
||||
listAgg (toColumns -> exprs) = fromColumns $
|
||||
hvectorize
|
||||
(\_ (Identity (DB a)) -> Aggregation $ listAggExpr a)
|
||||
(pure exprs)
|
||||
|
||||
|
||||
-- | Like 'listAgg', but the result is guaranteed to be a non-empty list.
|
||||
nonEmptyAgg :: Aggregates aggregates exprs => exprs -> NonEmptyTable aggregates
|
||||
nonEmptyAgg (toColumns -> exprs) = fromColumns $
|
||||
hvectorize
|
||||
(\_ (Identity (DB a)) -> Aggregation $ nonEmptyAggExpr a)
|
||||
(pure exprs)
|
@ -38,16 +38,12 @@ import Rel8.Expr.Opaleye
|
||||
import Rel8.Expr.Serialize ( litExpr )
|
||||
import Rel8.Schema.Context ( Interpretation, Col )
|
||||
import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
|
||||
import Rel8.Schema.Context.Nullify
|
||||
( Nullifiable, encodeTag, decodeTag, nullifier, unnullifier
|
||||
, runTag, unnull
|
||||
)
|
||||
import Rel8.Schema.HTable.Type ( HType( HType ) )
|
||||
import Rel8.Schema.Nullability
|
||||
( Nullability( Nullable, NonNullable )
|
||||
, Sql, nullabilization
|
||||
)
|
||||
import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
|
||||
import Rel8.Schema.Spec ( Spec( Spec ) )
|
||||
import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
|
||||
import Rel8.Table.Recontextualize ( Recontextualize )
|
||||
import Rel8.Type ( DBType )
|
||||
@ -128,15 +124,3 @@ instance Sql DBType a => Recontextualize Identity Expr (Identity a) (Expr a)
|
||||
instance Labelable Expr where
|
||||
labeler (DB a) = DB a
|
||||
unlabeler (DB a) = DB a
|
||||
|
||||
|
||||
instance Nullifiable Expr where
|
||||
encodeTag = DB
|
||||
decodeTag (DB a) = a
|
||||
nullifier tag SSpec {nullability} (DB a) = DB $ runTag nullability tag a
|
||||
unnullifier _ SSpec {nullability} (DB a) = DB $ unnull nullability a
|
||||
|
||||
{-# INLINABLE encodeTag #-}
|
||||
{-# INLINABLE decodeTag #-}
|
||||
{-# INLINABLE nullifier #-}
|
||||
{-# INLINABLE unnullifier #-}
|
||||
|
@ -130,6 +130,7 @@ sum = unsafeMakeAggregate toPrimExpr (castExpr . fromPrimExpr) $
|
||||
}
|
||||
|
||||
|
||||
-- | Take the sum of all expressions that satisfy a predicate.
|
||||
sumWhere :: (Sql DBNum a, Sql DBSum a)
|
||||
=> Expr Bool -> Expr a -> Aggregate (Expr a)
|
||||
sumWhere condition a = sum (caseExpr [(condition, a)] 0)
|
||||
|
@ -32,68 +32,28 @@ true = litExpr True
|
||||
|
||||
|
||||
-- | The SQL @AND@ operator.
|
||||
--
|
||||
-- >>> :{
|
||||
-- mapM_ print =<< select c do
|
||||
-- x <- values [lit True, lit False]
|
||||
-- y <- values [lit True, lit False]
|
||||
-- return (x, y, x &&. y)
|
||||
-- :}
|
||||
-- (True,True,True)
|
||||
-- (True,False,False)
|
||||
-- (False,True,False)
|
||||
-- (False,False,False)
|
||||
(&&.) :: Expr Bool -> Expr Bool -> Expr Bool
|
||||
(&&.) = zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpAnd)
|
||||
infixr 3 &&.
|
||||
|
||||
|
||||
-- | The SQL @OR@ operator.
|
||||
--
|
||||
-- >>> :{
|
||||
-- mapM_ print =<< select c do
|
||||
-- x <- values [lit True, lit False]
|
||||
-- y <- values [lit True, lit False]
|
||||
-- return (x, y, x ||. y)
|
||||
-- :}
|
||||
-- (True,True,True)
|
||||
-- (True,False,True)
|
||||
-- (False,True,True)
|
||||
-- (False,False,False)
|
||||
(||.) :: Expr Bool -> Expr Bool -> Expr Bool
|
||||
(||.) = zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpOr)
|
||||
infixr 2 ||.
|
||||
|
||||
|
||||
-- | The SQL @NOT@ operator.
|
||||
--
|
||||
-- >>> select c $ pure $ not_ $ lit True
|
||||
-- [False]
|
||||
--
|
||||
-- >>> select c $ pure $ not_ $ lit False
|
||||
-- [True]
|
||||
not_ :: Expr Bool -> Expr Bool
|
||||
not_ = mapPrimExpr (Opaleye.UnExpr Opaleye.OpNot)
|
||||
|
||||
|
||||
-- | Fold @AND@ over a collection of expressions.
|
||||
--
|
||||
-- >>> select c $ pure $ and_ [ lit True ==. lit False, lit False, lit True ]
|
||||
-- [False]
|
||||
--
|
||||
-- >>> select c $ pure $ and_ []
|
||||
-- [True]
|
||||
and_ :: Foldable f => f (Expr Bool) -> Expr Bool
|
||||
and_ = foldl' (&&.) true
|
||||
|
||||
|
||||
-- | Fold @OR@ over a collection of expressions.
|
||||
--
|
||||
-- >>> select c $ pure $ or_ [ lit True ==. lit False, lit False, lit True ]
|
||||
-- [True]
|
||||
--
|
||||
-- >>> select c $ pure $ or_ []
|
||||
-- [False]
|
||||
or_ :: Foldable f => f (Expr Bool) -> Expr Bool
|
||||
or_ = foldl' (||.) false
|
||||
|
||||
@ -118,6 +78,10 @@ caseExpr branches (Expr fallback) =
|
||||
go (Expr condition, Expr value) = (condition, 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.
|
||||
coalesce :: Expr (Maybe Bool) -> Expr Bool
|
||||
coalesce (Expr a) = Expr a &&. Expr (Opaleye.FunExpr "COALESCE" [a, untrue])
|
||||
where
|
||||
|
@ -74,12 +74,6 @@ infix 4 /=.
|
||||
--
|
||||
-- This corresponds to the SQL @=@ operator, though it will always return a
|
||||
-- 'Bool'.
|
||||
--
|
||||
-- >>> select c $ pure $ lit Nothing ==? lit True
|
||||
-- False
|
||||
--
|
||||
-- >>> select c $ pure $ lit Nothing ==? lit Nothing
|
||||
-- False
|
||||
(==?) :: DBEq a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
|
||||
a ==? b = coalesce $ unsafeLiftOpNullable eq a b
|
||||
infix 4 ==?
|
||||
@ -89,12 +83,6 @@ infix 4 ==?
|
||||
--
|
||||
-- This corresponds to the SQL @<>@ operator, though it will always return a
|
||||
-- 'Bool'.
|
||||
--
|
||||
-- >>> select c $ pure $ lit Nothing /=? lit True
|
||||
-- True
|
||||
--
|
||||
-- >>> select c $ pure $ lit Nothing /=? lit Nothing
|
||||
-- False
|
||||
(/=?) :: DBEq a => Expr (Maybe a) -> Expr (Maybe a) -> Expr Bool
|
||||
a /=? b = coalesce $ unsafeLiftOpNullable ne a b
|
||||
infix 4 /=?
|
||||
@ -102,12 +90,6 @@ infix 4 /=?
|
||||
|
||||
-- | Like the SQL @IN@ operator, but implemented by folding over a list with
|
||||
-- '==.' and '||.'.
|
||||
--
|
||||
-- >>> select c $ return $ lit (5 :: Int32) `in_` [ lit x | x <- [1..5] ]
|
||||
-- [True]
|
||||
--
|
||||
-- >>> select c $ return $ lit (42 :: Int32) `in_` [ lit x | x <- [1..5] ]
|
||||
-- [False]
|
||||
in_ :: forall a f. (Sql DBEq a, Foldable f)
|
||||
=> Expr a -> f (Expr a) -> Expr Bool
|
||||
in_ a (toList -> as) = case nullabilization @a of
|
||||
|
@ -47,42 +47,11 @@ instance (arg ~ Expr a, Function args res) => Function arg (args -> res) where
|
||||
|
||||
-- | Construct an n-ary function that produces an 'Expr' that when called runs
|
||||
-- a SQL function.
|
||||
--
|
||||
-- For example, here's how we can wrap PostgreSQL's @factorial@ function:
|
||||
--
|
||||
-- >>> :{
|
||||
-- factorial :: Expr Int64 -> Expr Data.Scientific.Scientific
|
||||
-- factorial = function "factorial"
|
||||
-- :}
|
||||
--
|
||||
-- >>> select c $ pure $ factorial 5
|
||||
-- [120.0]
|
||||
--
|
||||
-- The same approach works for any number of arguments:
|
||||
--
|
||||
-- >>> :{
|
||||
-- power :: Expr Float -> Expr Float -> Expr Double
|
||||
-- power = function "power"
|
||||
-- :}
|
||||
--
|
||||
-- >>> select c $ pure $ power 9 3
|
||||
-- [729.0]
|
||||
function :: Function args result => String -> args -> result
|
||||
function = applyArgument . Opaleye.FunExpr
|
||||
|
||||
|
||||
-- | Construct a function call for functions with no arguments.
|
||||
--
|
||||
-- For example, we can call the database function @pi()@ by using
|
||||
-- @nullaryFunction@:
|
||||
--
|
||||
-- >>> :{
|
||||
-- sqlPi :: Expr Double
|
||||
-- sqlPi = nullaryFunction "pi"
|
||||
-- :}
|
||||
--
|
||||
-- >>> select c $ pure $ sqlPi
|
||||
-- [3.141592653589793]
|
||||
nullaryFunction :: Sql DBType a => String -> Expr a
|
||||
nullaryFunction name = castExpr $ Expr (Opaleye.FunExpr name [])
|
||||
|
||||
|
@ -40,12 +40,6 @@ unsafeUnnullify (Expr a) = Expr a
|
||||
|
||||
|
||||
-- | Like 'maybe', but to eliminate @null@.
|
||||
--
|
||||
-- >>> select c $ pure $ null 0 id (nullExpr :: Expr (Maybe Int32))
|
||||
-- [0]
|
||||
--
|
||||
-- >>> select c $ pure $ null 0 id (lit (Just 42) :: Expr (Maybe Int32))
|
||||
-- [42]
|
||||
nullable :: Expr b -> (Expr a -> Expr b) -> Expr (Maybe a) -> Expr b
|
||||
nullable b f ma = boolExpr (f (unsafeUnnullify ma)) b (isNull ma)
|
||||
|
||||
@ -54,18 +48,12 @@ nullableOf :: DBType a => Maybe (Expr a) -> Expr (Maybe a)
|
||||
nullableOf = maybe null nullify
|
||||
|
||||
|
||||
-- | Like 'isNothing', but for @null@.
|
||||
--
|
||||
-- >>> select c $ pure $ isNull (nullExpr :: Expr (Maybe Int32))
|
||||
-- [True]
|
||||
--
|
||||
-- >>> select c $ pure $ isNull (lit (Just 42) :: Expr (Maybe Int32))
|
||||
-- [False]
|
||||
-- | Like 'Data.Maybe.isNothing', but for @null@.
|
||||
isNull :: Expr (Maybe a) -> Expr Bool
|
||||
isNull = mapPrimExpr (Opaleye.UnExpr Opaleye.OpIsNull)
|
||||
|
||||
|
||||
-- | Like 'isJust', but for @null@.
|
||||
-- | Like 'Data.Maybe.isJust', but for @null@.
|
||||
isNonNull :: Expr (Maybe a) -> Expr Bool
|
||||
isNonNull = mapPrimExpr (Opaleye.UnExpr Opaleye.OpIsNotNull)
|
||||
|
||||
|
@ -19,39 +19,59 @@ import Rel8.Schema.Nullability ( Homonullable, Sql )
|
||||
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
|
||||
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
|
||||
ceiling = function "CEILING"
|
||||
|
||||
|
||||
-- | Perform integral division. Corresponds to the @div()@ function.
|
||||
div :: Sql DBIntegral a => Expr a -> Expr a -> Expr a
|
||||
div = function "DIV"
|
||||
|
||||
|
||||
-- | Corresponds to the @mod()@ function.
|
||||
mod :: Sql DBIntegral a => Expr a -> Expr a -> Expr a
|
||||
mod = function "MOD"
|
||||
|
||||
|
||||
-- | 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 = 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
|
||||
truncate = function "TRUNC"
|
||||
|
@ -34,6 +34,8 @@ castExpr :: Sql DBType a => Expr a -> Expr a
|
||||
castExpr = scastExpr typeInformation
|
||||
|
||||
|
||||
-- | Cast an expression to a different type. Corresponds to a @CAST()@ function
|
||||
-- call.
|
||||
unsafeCastExpr :: Sql DBType b => Expr a -> Expr b
|
||||
unsafeCastExpr = sunsafeCastExpr typeInformation
|
||||
|
||||
|
@ -28,9 +28,6 @@ import Rel8.Type.Ord ( DBOrd )
|
||||
|
||||
|
||||
-- | Sort a column in ascending order.
|
||||
--
|
||||
-- >>> select c $ orderBy asc $ values [ lit x | x <- [1..5 :: Int32] ]
|
||||
-- [1,2,3,4,5]
|
||||
asc :: DBOrd a => Order (Expr a)
|
||||
asc = Order $ Opaleye.Order (\expr -> [(orderOp, toPrimExpr expr)])
|
||||
where
|
||||
@ -42,9 +39,6 @@ asc = Order $ Opaleye.Order (\expr -> [(orderOp, toPrimExpr expr)])
|
||||
|
||||
|
||||
-- | Sort a column in descending order.
|
||||
--
|
||||
-- >>> select c $ orderBy desc $ values [ lit x | x <- [1..5 :: Int32] ]
|
||||
-- [5,4,3,2,1]
|
||||
desc :: DBOrd a => Order (Expr a)
|
||||
desc = Order $ Opaleye.Order (\expr -> [(orderOp, toPrimExpr expr)])
|
||||
where
|
||||
@ -57,9 +51,6 @@ desc = Order $ Opaleye.Order (\expr -> [(orderOp, toPrimExpr expr)])
|
||||
|
||||
-- | Transform an ordering so that @null@ values appear first. This corresponds
|
||||
-- to @NULLS FIRST@ in SQL.
|
||||
--
|
||||
-- >>> select c $ orderBy (nullsFirst desc) $ values $ [ nullExpr, nullExpr ] <> [ lit (Just x) | x <- [1..5 :: Int32] ]
|
||||
-- [Nothing,Nothing,Just 5,Just 4,Just 3,Just 2,Just 1]
|
||||
nullsFirst :: Order (Expr a) -> Order (Expr (Maybe a))
|
||||
nullsFirst (Order (Opaleye.Order f)) =
|
||||
Order $ Opaleye.Order $ fmap (first g) . f . unsafeUnnullify
|
||||
@ -70,9 +61,6 @@ nullsFirst (Order (Opaleye.Order f)) =
|
||||
|
||||
-- | Transform an ordering so that @null@ values appear first. This corresponds
|
||||
-- to @NULLS LAST@ in SQL.
|
||||
--
|
||||
-- >>> select c $ orderBy (nullsLast desc) $ values $ [ nullExpr, nullExpr ] <> [ lit (Just x) | x <- [1..5 :: Int32] ]
|
||||
-- [Just 5,Just 4,Just 3,Just 2,Just 1,Nothing,Nothing]
|
||||
nullsLast :: Order (Expr a) -> Order (Expr (Maybe a))
|
||||
nullsLast (Order (Opaleye.Order f)) =
|
||||
Order $ Opaleye.Order $ fmap (first g) . f . unsafeUnnullify
|
||||
|
@ -30,6 +30,10 @@ 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.
|
||||
litExpr :: Sql DBType a => a -> Expr a
|
||||
litExpr = slitExpr nullabilization typeInformation
|
||||
|
||||
@ -44,6 +48,6 @@ slitExpr nullability info@TypeInformation {encode} =
|
||||
|
||||
|
||||
sparseValue :: Nullability a -> TypeInformation (Unnullify a) -> Hasql.Row a
|
||||
sparseValue nullability TypeInformation {decode, out} = case nullability of
|
||||
Nullable -> Hasql.column $ Hasql.nullable $ out <$> decode
|
||||
NonNullable -> Hasql.column $ Hasql.nonNullable $ out <$> decode
|
||||
sparseValue nullability TypeInformation {decode} = case nullability of
|
||||
Nullable -> Hasql.column $ Hasql.nullable decode
|
||||
NonNullable -> Hasql.column $ Hasql.nonNullable decode
|
||||
|
@ -16,7 +16,7 @@ module Rel8.Expr.Text
|
||||
, initcap, left, length, lengthEncoding, lpad, ltrim, md5
|
||||
, pgClientEncoding, quoteIdent, quoteLiteral, quoteNullable, regexpReplace
|
||||
, regexpSplitToArray, repeat, replace, reverse, right, rpad, rtrim
|
||||
, splitPart, strpos, substr, toAscii, toHex, translate
|
||||
, splitPart, strpos, substr, translate
|
||||
)
|
||||
where
|
||||
|
||||
@ -50,24 +50,32 @@ infixr 6 ++.
|
||||
|
||||
|
||||
-- | Matches regular expression, case sensitive
|
||||
--
|
||||
-- Corresponds to the @~.@ operator.
|
||||
(~.) :: Expr Text -> Expr Text -> Expr Bool
|
||||
(~.) = binaryOperator "~."
|
||||
infix 2 ~.
|
||||
|
||||
|
||||
-- | 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.
|
||||
(!~) :: Expr Text -> Expr Text -> Expr Bool
|
||||
(!~) = binaryOperator "!~"
|
||||
infix 2 !~
|
||||
|
||||
|
||||
-- | Does not match regular expression, case insensitive
|
||||
--
|
||||
-- Corresponds to the @!~*@ operator.
|
||||
(!~*) :: Expr Text -> Expr Text -> Expr Bool
|
||||
(!~*) = binaryOperator "!~*"
|
||||
infix 2 !~*
|
||||
@ -78,164 +86,191 @@ infix 2 !~*
|
||||
-- * Standard SQL functions
|
||||
|
||||
|
||||
-- | Corresponds to the @bit_length@ function.
|
||||
bitLength :: Expr Text -> Expr Int32
|
||||
bitLength = function "bit_length"
|
||||
|
||||
|
||||
-- | Corresponds to the @char_length@ function.
|
||||
charLength :: Expr Text -> Expr Int32
|
||||
charLength = function "char_length"
|
||||
|
||||
|
||||
-- | Corresponds to the @lower@ function.
|
||||
lower :: Expr Text -> Expr Text
|
||||
lower = function "lower"
|
||||
|
||||
|
||||
-- | Corresponds to the @octet_length@ function.
|
||||
octetLength :: Expr Text -> Expr Int32
|
||||
octetLength = function "octet_length"
|
||||
|
||||
|
||||
-- | Corresponds to the @upper@ function.
|
||||
upper :: Expr Text -> Expr Text
|
||||
upper = function "upper"
|
||||
|
||||
|
||||
-- * PostgreSQL functions
|
||||
-- | Corresponds to the @ascii@ function.
|
||||
ascii :: Expr Text -> Expr Int32
|
||||
ascii = function "ascii"
|
||||
|
||||
|
||||
-- | Corresponds to the @btrim@ function.
|
||||
btrim :: Expr Text -> Maybe (Expr Text) -> Expr Text
|
||||
btrim a (Just b) = function "btrim" a b
|
||||
btrim a Nothing = function "btrim" a
|
||||
|
||||
|
||||
-- | Corresponds to the @chr@ function.
|
||||
chr :: Expr Int32 -> Expr Text
|
||||
chr = function "chr"
|
||||
|
||||
|
||||
-- | Corresponds to the @convert@ function.
|
||||
convert :: Expr ByteString -> Expr Text -> Expr Text -> Expr ByteString
|
||||
convert = function "convert"
|
||||
|
||||
|
||||
-- | Corresponds to the @convert_from@ function.
|
||||
convertFrom :: Expr ByteString -> Expr Text -> Expr Text
|
||||
convertFrom = function "convert_from"
|
||||
|
||||
|
||||
-- | Corresponds to the @convert_to@ function.
|
||||
convertTo :: Expr Text -> Expr Text -> Expr ByteString
|
||||
convertTo = function "convert_to"
|
||||
|
||||
|
||||
-- | Corresponds to the @decode@ function.
|
||||
decode :: Expr Text -> Expr Text -> Expr ByteString
|
||||
decode = function "decode"
|
||||
|
||||
|
||||
-- | Corresponds to the @encode@ function.
|
||||
encode :: Expr ByteString -> Expr Text -> Expr Text
|
||||
encode = function "encode"
|
||||
|
||||
|
||||
-- | Corresponds to the @initcap@ function.
|
||||
initcap :: Expr Text -> Expr Text
|
||||
initcap = function "initcap"
|
||||
|
||||
|
||||
-- | Corresponds to the @left@ function.
|
||||
left :: Expr Text -> Expr Int32 -> Expr Text
|
||||
left = function "left"
|
||||
|
||||
|
||||
-- | Corresponds to the @length@ function.
|
||||
length :: Expr Text -> Expr Int32
|
||||
length = function "length"
|
||||
|
||||
|
||||
-- | Corresponds to the @length@ function.
|
||||
lengthEncoding :: Expr ByteString -> Expr Text -> Expr Int32
|
||||
lengthEncoding = function "length"
|
||||
|
||||
|
||||
-- | Corresponds to the @lpad@ function.
|
||||
lpad :: Expr Text -> Expr Int32 -> Maybe (Expr Text) -> Expr Text
|
||||
lpad a b (Just c) = function "lpad" a b c
|
||||
lpad a b Nothing = function "lpad" a b
|
||||
|
||||
|
||||
-- | Corresponds to the @ltrim@ function.
|
||||
ltrim :: Expr Text -> Maybe (Expr Text) -> Expr Text
|
||||
ltrim a (Just b) = function "ltrim" a b
|
||||
ltrim a Nothing = function "ltrim" a
|
||||
|
||||
|
||||
-- | Corresponds to the @md5@ function.
|
||||
md5 :: Expr Text -> Expr Text
|
||||
md5 = function "md5"
|
||||
|
||||
|
||||
-- | Corresponds to the @pg_client_encoding()@ expression.
|
||||
pgClientEncoding :: Expr Text
|
||||
pgClientEncoding = nullaryFunction "pg_client_encoding"
|
||||
|
||||
|
||||
-- | Corresponds to the @quote_ident@ function.
|
||||
quoteIdent :: Expr Text -> Expr Text
|
||||
quoteIdent = function "quote_ident"
|
||||
|
||||
|
||||
-- | Corresponds to the @quote_literal@ function.
|
||||
quoteLiteral :: Expr Text -> Expr Text
|
||||
quoteLiteral = function "quote_literal"
|
||||
|
||||
|
||||
-- | Corresponds to the @quote_nullable@ function.
|
||||
quoteNullable :: Expr Text -> Expr Text
|
||||
quoteNullable = function "quote_nullable"
|
||||
|
||||
|
||||
-- | Corresponds to the @regexp_replace@ function.
|
||||
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 (Array1D 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
|
||||
|
||||
|
||||
-- | Corresponds to the @repeat@ function.
|
||||
repeat :: Expr Text -> Expr Int32 -> Expr Text
|
||||
repeat = function "repeat"
|
||||
|
||||
|
||||
-- | Corresponds to the @replace@ function.
|
||||
replace :: Expr Text -> Expr Text -> Expr Text -> Expr Text
|
||||
replace = function "replace"
|
||||
|
||||
|
||||
-- | Corresponds to the @reverse@ function.
|
||||
reverse :: Expr Text -> Expr Text
|
||||
reverse = function "reverse"
|
||||
|
||||
|
||||
-- | Corresponds to the @right@ function.
|
||||
right :: Expr Text -> Expr Int32 -> Expr Text
|
||||
right = function "right"
|
||||
|
||||
|
||||
-- | Corresponds to the @rpad@ function.
|
||||
rpad :: Expr Text -> Expr Int32 -> Maybe (Expr Text) -> Expr Text
|
||||
rpad a b (Just c) = function "rpad" a b c
|
||||
rpad a b Nothing = function "rpad" a b
|
||||
|
||||
|
||||
-- | Corresponds to the @rtrim@ function.
|
||||
rtrim :: Expr Text -> Maybe (Expr Text) -> Expr Text
|
||||
rtrim a (Just b) = function "rtrim" a b
|
||||
rtrim a Nothing = function "rtrim" a
|
||||
|
||||
|
||||
-- | Corresponds to the @split_part@ function.
|
||||
splitPart :: Expr Text -> Expr Text -> Expr Int32 -> Expr Text
|
||||
splitPart = function "split_part"
|
||||
|
||||
|
||||
-- | Corresponds to the @strpos@ function.
|
||||
strpos :: Expr Text -> Expr Text -> Expr Int32
|
||||
strpos = function "strpos"
|
||||
|
||||
|
||||
-- | Corresponds to the @substr@ function.
|
||||
substr :: Expr Text -> Expr Int32 -> Maybe (Expr Int32) -> Expr Text
|
||||
substr a b (Just c) = function "substr" a b c
|
||||
substr a b Nothing = function "substr" a b
|
||||
|
||||
|
||||
toAscii :: Expr Text -> Expr Text -> Expr Text
|
||||
toAscii = function "toAscii"
|
||||
|
||||
|
||||
toHex :: Expr Int32 -> Expr Text
|
||||
toHex = function "toHex"
|
||||
|
||||
|
||||
-- | Corresponds to the @translate@ function.
|
||||
translate :: Expr Text -> Expr Text -> Expr Text -> Expr Text
|
||||
translate = function "translate"
|
||||
|
@ -13,7 +13,7 @@ module Rel8.Expr.Time
|
||||
, diffTime
|
||||
, subtractTime
|
||||
|
||||
-- * Working with @NominalDiffTime@
|
||||
-- * Working with @CalendarDiffTime@
|
||||
, scaleInterval
|
||||
, second, seconds
|
||||
, minute, minutes
|
||||
@ -35,7 +35,8 @@ import Rel8.Expr.Opaleye ( unsafeCastExpr, unsafeLiteral )
|
||||
|
||||
-- time
|
||||
import Data.Time.Calendar ( Day )
|
||||
import Data.Time.Clock ( NominalDiffTime, UTCTime )
|
||||
import Data.Time.Clock ( UTCTime )
|
||||
import Data.Time.LocalTime ( CalendarDiffTime )
|
||||
|
||||
|
||||
-- | Corresponds to @date(now())@.
|
||||
@ -74,93 +75,93 @@ now = nullaryFunction "now"
|
||||
|
||||
|
||||
-- | Add a time interval to a point in time, yielding a new point in time.
|
||||
addTime :: Expr NominalDiffTime -> Expr UTCTime -> Expr UTCTime
|
||||
addTime :: Expr CalendarDiffTime -> Expr UTCTime -> Expr UTCTime
|
||||
addTime = flip (binaryOperator "+")
|
||||
|
||||
|
||||
-- | Find the duration between two times.
|
||||
diffTime :: Expr UTCTime -> Expr UTCTime -> Expr NominalDiffTime
|
||||
diffTime :: Expr UTCTime -> Expr UTCTime -> Expr CalendarDiffTime
|
||||
diffTime = binaryOperator "-"
|
||||
|
||||
|
||||
-- | Subtract a time interval from a point in time, yielding a new point in time.
|
||||
subtractTime :: Expr NominalDiffTime -> Expr UTCTime -> Expr UTCTime
|
||||
subtractTime :: Expr CalendarDiffTime -> Expr UTCTime -> Expr UTCTime
|
||||
subtractTime = flip (binaryOperator "-")
|
||||
|
||||
|
||||
scaleInterval :: Expr Double -> Expr NominalDiffTime -> Expr NominalDiffTime
|
||||
scaleInterval :: Expr Double -> Expr CalendarDiffTime -> Expr CalendarDiffTime
|
||||
scaleInterval = binaryOperator "*"
|
||||
|
||||
|
||||
-- | An interval of one second.
|
||||
second :: Expr NominalDiffTime
|
||||
second :: Expr CalendarDiffTime
|
||||
second = singleton "second"
|
||||
|
||||
|
||||
-- | Create a literal interval from a number of seconds.
|
||||
seconds :: Expr Double -> Expr NominalDiffTime
|
||||
seconds :: Expr Double -> Expr CalendarDiffTime
|
||||
seconds = (`scaleInterval` second)
|
||||
|
||||
|
||||
-- | An interval of one minute.
|
||||
minute :: Expr NominalDiffTime
|
||||
minute :: Expr CalendarDiffTime
|
||||
minute = singleton "minute"
|
||||
|
||||
|
||||
-- | Create a literal interval from a number of minutes.
|
||||
minutes :: Expr Double -> Expr NominalDiffTime
|
||||
minutes :: Expr Double -> Expr CalendarDiffTime
|
||||
minutes = (`scaleInterval` minute)
|
||||
|
||||
|
||||
-- | An interval of one hour.
|
||||
hour :: Expr NominalDiffTime
|
||||
hour :: Expr CalendarDiffTime
|
||||
hour = singleton "hour"
|
||||
|
||||
|
||||
-- | Create a literal interval from a number of hours.
|
||||
hours :: Expr Double -> Expr NominalDiffTime
|
||||
hours :: Expr Double -> Expr CalendarDiffTime
|
||||
hours = (`scaleInterval` hour)
|
||||
|
||||
|
||||
-- | An interval of one day.
|
||||
day :: Expr NominalDiffTime
|
||||
day :: Expr CalendarDiffTime
|
||||
day = singleton "day"
|
||||
|
||||
|
||||
-- | Create a literal interval from a number of days.
|
||||
days :: Expr Double -> Expr NominalDiffTime
|
||||
days :: Expr Double -> Expr CalendarDiffTime
|
||||
days = (`scaleInterval` day)
|
||||
|
||||
|
||||
-- | An interval of one week.
|
||||
week :: Expr NominalDiffTime
|
||||
week :: Expr CalendarDiffTime
|
||||
week = singleton "week"
|
||||
|
||||
|
||||
-- | Create a literal interval from a number of weeks.
|
||||
weeks :: Expr Double -> Expr NominalDiffTime
|
||||
weeks :: Expr Double -> Expr CalendarDiffTime
|
||||
weeks = (`scaleInterval` week)
|
||||
|
||||
|
||||
-- | An interval of one month.
|
||||
month :: Expr NominalDiffTime
|
||||
month :: Expr CalendarDiffTime
|
||||
month = singleton "month"
|
||||
|
||||
|
||||
-- | Create a literal interval from a number of months.
|
||||
months :: Expr Double -> Expr NominalDiffTime
|
||||
months :: Expr Double -> Expr CalendarDiffTime
|
||||
months = (`scaleInterval` month)
|
||||
|
||||
|
||||
-- | An interval of one year.
|
||||
year :: Expr NominalDiffTime
|
||||
year :: Expr CalendarDiffTime
|
||||
year = singleton "year"
|
||||
|
||||
|
||||
-- | Create a literal interval from a number of years.
|
||||
years :: Expr Double -> Expr NominalDiffTime
|
||||
years :: Expr Double -> Expr CalendarDiffTime
|
||||
years = (`scaleInterval` year)
|
||||
|
||||
|
||||
singleton :: String -> Expr NominalDiffTime
|
||||
singleton :: String -> Expr CalendarDiffTime
|
||||
singleton unit = unsafeLiteral $ "'1 " ++ unit ++ "'"
|
||||
|
@ -19,21 +19,12 @@ import Data.Functor.Contravariant.Divisible ( Decidable, Divisible )
|
||||
import qualified Opaleye.Internal.Order as Opaleye
|
||||
|
||||
|
||||
-- | An ordering expression for @a@. Primitive orderings are defined with 'asc'
|
||||
-- and 'desc', and you can combine @Order@ via its various instances.
|
||||
-- | 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 '>$<' (from 'Contravariant') to select individual columns. For example,
|
||||
-- to sort a @Query@ on two columns, we could do:
|
||||
--
|
||||
-- >>> import Data.Functor.Contravariant ((>$<))
|
||||
-- >>> :{
|
||||
-- select c $ orderBy (mconcat [fst >$< asc, snd >$< desc]) $ do
|
||||
-- x <- values [ lit x | x <- [1..3 :: Int32 ] ]
|
||||
-- y <- values [ lit x | x <- [1..3 :: Int32 ] ]
|
||||
-- return (x, y)
|
||||
-- :}
|
||||
-- [(1,3),(1,2),(1,1),(2,3),(2,2),(2,1),(3,3),(3,2),(3,1)]
|
||||
-- and '>$<' (from 'Contravariant') to select individual columns.
|
||||
type Order :: Type -> Type
|
||||
newtype Order a = Order (Opaleye.Order a)
|
||||
deriving newtype (Contravariant, Divisible, Decidable, Semigroup, Monoid)
|
||||
|
@ -29,5 +29,8 @@ aggregate :: Query (Aggregate exprs) -> Query exprs
|
||||
aggregate = 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@.
|
||||
countRows :: Query a -> Query (Expr Int64)
|
||||
countRows = fmap (maybeTable 0 id) . optional . aggregate . fmap (const countStar)
|
||||
|
@ -25,9 +25,6 @@ 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 c $ distinct $ values [ lit True, lit True, lit False ]
|
||||
-- [False,True]
|
||||
distinct :: EqTable a => Query a -> Query a
|
||||
distinct = mapOpaleye (Opaleye.distinctExplicit distinctspec)
|
||||
|
||||
|
@ -22,11 +22,6 @@ import Rel8.Table.Opaleye ( table, unpackspec )
|
||||
|
||||
-- | Select each row from a table definition. This is equivalent to @FROM
|
||||
-- table@.
|
||||
--
|
||||
-- >>> mapM_ print =<< select c (each projectSchema)
|
||||
-- Project {projectAuthorId = 1, projectName = "rel8"}
|
||||
-- Project {projectAuthorId = 2, projectName = "aeson"}
|
||||
-- Project {projectAuthorId = 2, projectName = "text"}
|
||||
each :: Selects names exprs => TableSchema names -> Query exprs
|
||||
each =
|
||||
fmap fromColumns .
|
||||
|
@ -24,18 +24,6 @@ import Rel8.Table.Maybe ( isJustTable )
|
||||
|
||||
|
||||
-- | Checks if a query returns at least one row.
|
||||
--
|
||||
-- >>> :{
|
||||
-- mapM_ print =<< select c do
|
||||
-- author <- each authorSchema
|
||||
-- hasProjects <- exists do
|
||||
-- project <- each projectSchema
|
||||
-- where_ $ authorId author ==. projectAuthorId project
|
||||
-- return (authorName author, hasProjects)
|
||||
-- :}
|
||||
-- ("Ollie",True)
|
||||
-- ("Bryan O'Sullivan",True)
|
||||
-- ("Emily Pillmore",False)
|
||||
exists :: Query a -> Query (Expr Bool)
|
||||
exists = fmap isJustTable . optional . whereExists
|
||||
-- FIXME: change this when b7aacc07c6392654cae439fc3b997620c3aa7a87 makes it
|
||||
@ -48,47 +36,33 @@ inQuery a = exists . (>>= filter (a ==:))
|
||||
|
||||
-- | Produce the empty query if the given query returns no rows. @whereExists@
|
||||
-- is equivalent to @WHERE EXISTS@ in SQL.
|
||||
--
|
||||
-- >>> :{
|
||||
-- select c do
|
||||
-- author <- each authorSchema
|
||||
-- whereExists do
|
||||
-- project <- each projectSchema
|
||||
-- where_ $ projectAuthorId project ==. authorId author
|
||||
-- return $ authorName author
|
||||
-- :}
|
||||
-- ["Ollie","Bryan O'Sullivan"]
|
||||
whereExists :: Query a -> Query ()
|
||||
whereExists = mapOpaleye Opaleye.restrictExists
|
||||
|
||||
|
||||
-- | Produce the empty query if the given query returns rows. @whereNotExists@
|
||||
-- is equivalent to @WHERE NOT EXISTS@ in SQL.
|
||||
--
|
||||
-- >>> :{
|
||||
-- select c do
|
||||
-- author <- each authorSchema
|
||||
-- whereNotExists do
|
||||
-- project <- each projectSchema
|
||||
-- where_ $ projectAuthorId project ==. authorId author
|
||||
-- return $ authorName author
|
||||
-- :}
|
||||
-- ["Emily Pillmore"]
|
||||
whereNotExists :: Query a -> Query ()
|
||||
whereNotExists = mapOpaleye Opaleye.restrictNotExists
|
||||
|
||||
|
||||
-- | @with@ is similar to 'filter', but allows the predicate to be a full query.
|
||||
--
|
||||
-- @with f a = a <$ whereExists (f a)@, but this form matches 'filter'.
|
||||
with :: (a -> Query b) -> a -> Query a
|
||||
with f a = a <$ whereExists (f a)
|
||||
|
||||
|
||||
withBy :: (a -> b -> Expr Bool) -> Query b -> a -> Query a
|
||||
-- | Like @with@, but with a custom membership test.
|
||||
withBy :: (a -> b -> Expr Bool) -> Query b -> a -> Query a
|
||||
withBy predicate bs = with $ \a -> bs >>= filter (predicate a)
|
||||
|
||||
|
||||
-- | Filter rows where @a -> Query b@ yields no rows.
|
||||
without :: (a -> Query b) -> a -> Query a
|
||||
without f a = a <$ whereNotExists (f a)
|
||||
|
||||
|
||||
-- | Like @without@, but with a custom membership test.
|
||||
withoutBy :: (a -> b -> Expr Bool) -> Query b -> a -> Query a
|
||||
withoutBy predicate bs = without $ \a -> bs >>= filter (predicate a)
|
||||
|
@ -24,23 +24,12 @@ import Rel8.Query.Opaleye ( fromOpaleye )
|
||||
-- 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.
|
||||
--
|
||||
-- >>> select c $ values [ lit x | x <- [ 1..5 :: Int32 ] ] >>= filter (>. 3)
|
||||
-- [4,5]
|
||||
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@.
|
||||
--
|
||||
-- >>> :{
|
||||
-- select c $ do
|
||||
-- x <- values [ lit x | x <- [ 1..5 :: Int32 ] ]
|
||||
-- where_ $ x >. lit 2
|
||||
-- return x
|
||||
-- :}
|
||||
-- [3,4,5]
|
||||
where_ :: Expr Bool -> Query ()
|
||||
where_ condition =
|
||||
fromOpaleye $ lmap (\_ -> toColumn $ toPrimExpr condition) Opaleye.restrict
|
||||
|
@ -17,17 +17,11 @@ import Rel8.Query.Opaleye ( mapOpaleye )
|
||||
|
||||
-- | @limit n@ select at most @n@ rows from a query. @limit n@ is equivalent
|
||||
-- to the SQL @LIMIT n@.
|
||||
--
|
||||
-- >>> select c $ limit 3 $ values [ lit x | x <- [ 1..5 :: Int32 ] ]
|
||||
-- [1,2,3]
|
||||
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@.
|
||||
--
|
||||
-- >>> select c $ offset 3 $ values [ lit x | x <- [ 1..5 :: Int32 ] ]
|
||||
-- [4,5]
|
||||
offset :: Word -> Query a -> Query a
|
||||
offset = mapOpaleye . Opaleye.offset . fromIntegral
|
||||
|
@ -25,14 +25,21 @@ import Rel8.Query.Filter ( where_ )
|
||||
import Rel8.Query.Opaleye ( mapOpaleye )
|
||||
import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
|
||||
import Rel8.Table.Opaleye ( unpackspec )
|
||||
import Rel8.Table.Tag ( Tag(..), fromExpr )
|
||||
|
||||
|
||||
-- | 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 a)
|
||||
optional = mapOpaleye $ Opaleye.QueryArr . go
|
||||
where
|
||||
go query (i, left, tag) = (MaybeTable t' a, join, Opaleye.next tag')
|
||||
go query (i, left, tag) =
|
||||
(MaybeTable (fromExpr t') a, join, Opaleye.next tag')
|
||||
where
|
||||
(MaybeTable t a, right, tag') =
|
||||
(MaybeTable Tag {expr = t} a, right, tag') =
|
||||
Opaleye.runSimpleQueryArr (pure <$> query) (i, tag)
|
||||
(t', bindings) = Opaleye.run $
|
||||
Opaleye.runUnpackspec unpackspec (Opaleye.extractAttr "maybe" tag') t
|
||||
@ -45,34 +52,6 @@ optional = mapOpaleye $ Opaleye.QueryArr . go
|
||||
-- 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'.
|
||||
--
|
||||
-- To see this in action, first consider the following 'optional' query:
|
||||
--
|
||||
-- >>> :{
|
||||
-- select c $ do
|
||||
-- author <- each authorSchema
|
||||
-- maybeRel8 <- optional $
|
||||
-- each projectSchema
|
||||
-- >>= filter (\p -> projectAuthorId p ==. authorId author)
|
||||
-- >>= filter (\p -> projectName p ==. "rel8")
|
||||
-- return (authorName author, projectName <$> maybeRel8)
|
||||
-- :}
|
||||
-- [("Ollie",Just "rel8"),("Bryan O'Sullivan",Nothing),("Emily Pillmore",Nothing)]
|
||||
--
|
||||
-- Here @optional@ is acting as a @LEFT JOIN@. We can turn this into a proper
|
||||
-- join by using @catMaybeTable@ to filter out rows where the join failed:
|
||||
--
|
||||
-- >>> :{
|
||||
-- select c $ do
|
||||
-- author <- each authorSchema
|
||||
-- maybeRel8 <- optional $
|
||||
-- each projectSchema
|
||||
-- >>= filter (\p -> projectAuthorId p ==. authorId author)
|
||||
-- >>= filter (\p -> projectName p ==. "rel8")
|
||||
-- rel8 <- catMaybeTable maybeRel8
|
||||
-- return (authorName author, projectName rel8)
|
||||
-- :}
|
||||
-- [("Ollie","rel8")]
|
||||
catMaybeTable :: MaybeTable a -> Query a
|
||||
catMaybeTable ma@(MaybeTable _ a) = do
|
||||
where_ $ isJustTable ma
|
||||
@ -81,19 +60,11 @@ catMaybeTable ma@(MaybeTable _ a) = do
|
||||
|
||||
-- | @bindMaybeTable f x@ is similar to the monadic bind (@>>=@) operation. It
|
||||
-- allows you to "extend" an optional query with another query. If either the
|
||||
-- input or output are 'noTable', then the result is 'noTable'.
|
||||
-- input or output are 'Rel8.nothingTable', then the result is
|
||||
-- 'Rel8.nothingTable'.
|
||||
--
|
||||
-- This is similar to 'traverseMaybeTable', followed by a @join@ on the
|
||||
-- resulting @MaybeTable@s.
|
||||
--
|
||||
-- >>> select c $ bindMaybeTable (optional . values . pure . not_) =<< optional (values [lit True])
|
||||
-- [Just False]
|
||||
--
|
||||
-- >>> select c $ bindMaybeTable (\_ -> return (noTable :: MaybeTable (Expr Bool))) =<< optional (values [lit True])
|
||||
-- [Nothing]
|
||||
--
|
||||
-- >>> select c $ bindMaybeTable (optional . values . pure . not_) =<< return (noTable :: MaybeTable (Expr Bool))
|
||||
-- [Nothing]
|
||||
bindMaybeTable :: Monad m
|
||||
=> (a -> m (MaybeTable b)) -> MaybeTable a -> m (MaybeTable b)
|
||||
bindMaybeTable query (MaybeTable input a) = do
|
||||
@ -105,32 +76,12 @@ bindMaybeTable query (MaybeTable input a) = do
|
||||
-- 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.
|
||||
--
|
||||
-- >>> :{
|
||||
-- duplicate :: Expr Bool -> Query (Expr Bool)
|
||||
-- duplicate x = unionAll (return x) (return x)
|
||||
-- :}
|
||||
--
|
||||
-- >>> select c $ traverseMaybeTable duplicate =<< optional (values [lit True])
|
||||
-- [Just True,Just True]
|
||||
--
|
||||
-- Note that if the @a -> Query b@ function returns no rows, then the resulting
|
||||
-- query will also have no rows:
|
||||
--
|
||||
-- >>> select c $ traverseMaybeTable (limit 0 . pure) =<< optional (values [lit True])
|
||||
-- []
|
||||
--
|
||||
-- However, regardless of the given @a -> Query b@ function, if the input is
|
||||
-- @noTable@, you will always get exactly one @noTable@ back:
|
||||
--
|
||||
-- >>> select c $ traverseMaybeTable duplicate (noTable :: MaybeTable (Expr Bool))
|
||||
-- [Nothing]
|
||||
--
|
||||
-- >>> select c $ traverseMaybeTable (limit 0 . pure) (noTable :: MaybeTable (Expr Bool))
|
||||
-- [Nothing]
|
||||
-- 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 @noTable@, you will always get exactly one @noTable@ back.
|
||||
traverseMaybeTable :: (a -> Query b) -> MaybeTable a -> Query (MaybeTable b)
|
||||
traverseMaybeTable query ma@(MaybeTable input _) = do
|
||||
MaybeTable output b <- optional (query =<< catMaybeTable ma)
|
||||
where_ $ output ==. input
|
||||
where_ $ expr output ==. expr input
|
||||
pure $ MaybeTable input b
|
||||
|
@ -17,21 +17,6 @@ import Rel8.Query.Filter ( where_ )
|
||||
-- @null@s.
|
||||
--
|
||||
-- Corresponds to 'Data.Maybe.catMaybes'.
|
||||
--
|
||||
-- >>> select c $ pure (nullExpr :: Expr (Maybe Bool))
|
||||
-- [Nothing]
|
||||
--
|
||||
-- >>> select c $ catNullable (nullExpr :: Expr (Maybe Bool))
|
||||
-- []
|
||||
--
|
||||
-- >>> select c $ catNullable (lit (Just True))
|
||||
-- [True]
|
||||
--
|
||||
-- Notice how in the last example a @Bool@ is returned (rather than @Maybe
|
||||
-- Bool@):
|
||||
--
|
||||
-- >>> :t catNullable (lit (Just True))
|
||||
-- catMaybe (lit (Just True)) :: Query (Expr Bool)
|
||||
catNullable :: Expr (Maybe a) -> Query (Expr a)
|
||||
catNullable a = do
|
||||
where_ $ isNonNull a
|
||||
|
@ -24,53 +24,35 @@ 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 @x UNION b@.
|
||||
--
|
||||
-- >>> select c $ values [lit True, lit True, lit False] `union` values [lit True]
|
||||
-- [False,True]
|
||||
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 @x UNION ALL b@.
|
||||
--
|
||||
-- >>> select c $ values [lit True, lit True, lit False] `unionAll` values [lit True]
|
||||
-- [True,True,False,True]
|
||||
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 @x INTERSECT b@.
|
||||
--
|
||||
-- >>> select c $ values [lit True, lit True, lit False] `intersect` values [lit True]
|
||||
-- [True]
|
||||
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 @x INTERSECT ALL b@.
|
||||
--
|
||||
-- >>> select c $ values [lit True, lit True, lit False] `intersectAll` values [lit True, lit True]
|
||||
-- [True,True]
|
||||
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 @x INTERSECT b@.
|
||||
--
|
||||
-- >>> select c $ values [lit True, lit False, lit False] `except` values [lit True]
|
||||
-- [False]
|
||||
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 @x EXCEPT ALL b@.
|
||||
--
|
||||
-- >>> select c $ values [lit True, lit False, lit False] `exceptAll` values [lit True]
|
||||
-- [False,False]
|
||||
exceptAll :: EqTable a => Query a -> Query a -> Query a
|
||||
exceptAll = zipOpaleyeWith (Opaleye.exceptAllExplicit binaryspec)
|
||||
|
@ -33,6 +33,7 @@ import Rel8.Table ( Table )
|
||||
import Rel8.Table.Either ( EitherTable( EitherTable ) )
|
||||
import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
|
||||
import Rel8.Table.Opaleye ( unpackspec )
|
||||
import Rel8.Table.Tag ( Tag(..) )
|
||||
import Rel8.Table.These
|
||||
( TheseTable( TheseTable )
|
||||
, hasHereTable, hasThereTable
|
||||
@ -104,9 +105,10 @@ keepThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
|
||||
loseThoseTable :: TheseTable a b -> Query (EitherTable a b)
|
||||
loseThoseTable t@(TheseTable (MaybeTable _ a) (MaybeTable _ b)) = do
|
||||
where_ $ not_ $ isThoseTable t
|
||||
pure $ EitherTable tag a b
|
||||
pure $ EitherTable result a b
|
||||
where
|
||||
tag = boolExpr (litExpr IsLeft) (litExpr IsRight) (isThatTable t)
|
||||
result = (mempty `asTypeOf` result) {expr = tag}
|
||||
|
||||
|
||||
bindTheseTable :: (Table Expr a, Semigroup a, Monad m)
|
||||
|
@ -21,13 +21,7 @@ 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 'union', but uses the SQL
|
||||
-- folding a list of 'return' statements under 'Rel8.union', but uses the SQL
|
||||
-- @VALUES@ expression for efficiency.
|
||||
--
|
||||
-- Typically @values@ will be used with 'lit':
|
||||
--
|
||||
-- >>> mapM_ Data.Text.IO.putStrLn =<< select c (values [ lit "Hello", lit "World!" ])
|
||||
-- Hello
|
||||
-- World!
|
||||
values :: (Table Expr a, Foldable f) => f a -> Query a
|
||||
values = fromOpaleye . Opaleye.valuesExplicit valuesspec . toList
|
||||
|
@ -80,32 +80,6 @@ type family UnwrapDefault a where
|
||||
-- data types are single columns in queries. This type family has special
|
||||
-- support when a query is executed, allowing you to use a single data type for
|
||||
-- both query data and rows decoded to Haskell.
|
||||
--
|
||||
-- To understand why this type family is special, let's consider a simple
|
||||
-- higher-kinded data type of Haskell packages:
|
||||
--
|
||||
-- >>> :{
|
||||
-- data Package f = Package
|
||||
-- { packageName :: Column f Text
|
||||
-- , packageAuthor :: Column f Text
|
||||
-- }
|
||||
-- :}
|
||||
--
|
||||
-- In queries, @f@ will be some type of 'Expr', and @Column Expr a@ reduces to
|
||||
-- just @Expr a@:
|
||||
--
|
||||
-- >>> :t packageName (undefined :: Package Expr)
|
||||
-- packageName (undefined :: Package Expr) :: Expr Text
|
||||
--
|
||||
-- When we 'select' queries of this type, @f@ will be instantiated as
|
||||
-- @Identity@, at which point all wrapping entire disappears:
|
||||
--
|
||||
-- >>> :t packageName (undefined :: Package Identity)
|
||||
-- packageName (undefined :: Package Identity) :: Text
|
||||
--
|
||||
-- In @rel8@ we try hard to always know what @f@ is, which means holes should
|
||||
-- mention precise types, rather than the @Column@ type family. You should only
|
||||
-- need to be aware of the type family when defining your table types.
|
||||
type Column :: K.Context -> Type -> Type
|
||||
type Column context a =
|
||||
Field context (GetLabel a)
|
||||
|
@ -2,6 +2,7 @@
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language InstanceSigs #-}
|
||||
{-# language LambdaCase #-}
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language NamedFieldPuns #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
@ -12,29 +13,35 @@
|
||||
module Rel8.Schema.Context.Nullify
|
||||
( Nullifiable( ConstrainTag, encodeTag, decodeTag, nullifier, unnullifier )
|
||||
, HNullifiable( HConstrainTag, hencodeTag, hdecodeTag, hnullifier, hunnullifier )
|
||||
, unnull, runTag
|
||||
, runTag, unnull
|
||||
)
|
||||
where
|
||||
|
||||
-- base
|
||||
import Data.Kind ( Constraint, Type )
|
||||
import GHC.TypeLits ( KnownSymbol )
|
||||
import Prelude hiding ( null )
|
||||
|
||||
-- opaleye
|
||||
import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
|
||||
|
||||
-- rel8
|
||||
import {-# SOURCE #-} Rel8.Expr ( Expr )
|
||||
import Rel8.Aggregate
|
||||
( Aggregate, Col(..)
|
||||
, mapInputs
|
||||
, unsafeMakeAggregate
|
||||
)
|
||||
import Rel8.Expr ( Expr, Col(..) )
|
||||
import Rel8.Expr.Bool ( boolExpr )
|
||||
import Rel8.Expr.Null ( nullify, unsafeUnnullify )
|
||||
import Rel8.Expr.Opaleye ( fromPrimExpr )
|
||||
import Rel8.Kind.Labels ( KnownLabels )
|
||||
import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
|
||||
import Rel8.Kind.Necessity ( Necessity( Required ) )
|
||||
import Rel8.Schema.Context ( Interpretation, Col(..) )
|
||||
import Rel8.Schema.Context ( Interpretation )
|
||||
import qualified Rel8.Schema.Kind as K
|
||||
import Rel8.Schema.Name ( Name( Name ), Col(..) )
|
||||
import Rel8.Schema.Nullability
|
||||
( Nullify
|
||||
, Nullability( Nullable, NonNullable ), nullabilization
|
||||
, Nullability( Nullable, NonNullable )
|
||||
, Sql
|
||||
)
|
||||
import Rel8.Schema.Dict ( Dict( Dict ) )
|
||||
@ -43,8 +50,7 @@ import Rel8.Schema.Spec.ConstrainDBType
|
||||
( ConstrainDBType
|
||||
, dbTypeDict, dbTypeNullability, fromNullabilityDict
|
||||
)
|
||||
import Rel8.Type.Eq ( DBEq )
|
||||
import Rel8.Type.Monoid ( DBMonoid, memptyExpr )
|
||||
import Rel8.Table.Tag ( Tag(..), Taggable, fromAggregate, fromExpr, fromName )
|
||||
|
||||
|
||||
type Nullifiable :: K.Context -> Constraint
|
||||
@ -52,25 +58,80 @@ class Interpretation context => Nullifiable context where
|
||||
type ConstrainTag context :: Type -> Constraint
|
||||
type ConstrainTag _context = DefaultConstrainTag
|
||||
|
||||
encodeTag :: (Sql (ConstrainTag context) a, Sql DBEq a, KnownLabels labels)
|
||||
=> Expr a
|
||||
encodeTag ::
|
||||
( Sql (ConstrainTag context) a
|
||||
, KnownSymbol label
|
||||
, Taggable a
|
||||
)
|
||||
=> Tag label a
|
||||
-> Col context ('Spec labels 'Required a)
|
||||
|
||||
decodeTag :: (Sql (ConstrainTag context) a, Sql DBMonoid a)
|
||||
decodeTag ::
|
||||
( Sql (ConstrainTag context) a
|
||||
, KnownSymbol label
|
||||
, Taggable a
|
||||
)
|
||||
=> Col context ('Spec labels 'Required a)
|
||||
-> Expr a
|
||||
-> Tag label a
|
||||
|
||||
nullifier :: ()
|
||||
=> Expr Bool
|
||||
-> SSpec ('Spec labels necessity a)
|
||||
-> Col context ('Spec labels necessity a)
|
||||
-> Col context ('Spec labels necessity (Nullify a))
|
||||
=> Tag label a
|
||||
-> (Expr a -> Expr Bool)
|
||||
-> SSpec ('Spec labels necessity x)
|
||||
-> Col context ('Spec labels necessity x)
|
||||
-> Col context ('Spec labels necessity (Nullify x))
|
||||
|
||||
unnullifier :: ()
|
||||
=> Expr Bool
|
||||
-> SSpec ('Spec labels necessity a)
|
||||
-> Col context ('Spec labels necessity (Nullify a))
|
||||
-> Col context ('Spec labels necessity a)
|
||||
=> SSpec ('Spec labels necessity x)
|
||||
-> Col context ('Spec labels necessity (Nullify x))
|
||||
-> Col context ('Spec labels necessity x)
|
||||
|
||||
|
||||
instance Nullifiable Aggregate where
|
||||
encodeTag Tag {aggregator, expr} =
|
||||
Aggregation $ unsafeMakeAggregate toPrimExpr fromPrimExpr aggregator expr
|
||||
|
||||
decodeTag (Aggregation aggregate) = fromAggregate aggregate
|
||||
|
||||
nullifier Tag {expr} test SSpec {nullability} (Aggregation aggregate) =
|
||||
Aggregation $
|
||||
mapInputs (toPrimExpr . runTag nullability condition . fromPrimExpr) $
|
||||
runTag nullability condition <$> aggregate
|
||||
where
|
||||
condition = test expr
|
||||
|
||||
unnullifier SSpec {nullability} (Aggregation aggregate) =
|
||||
Aggregation $ unnull nullability <$> aggregate
|
||||
|
||||
{-# INLINABLE encodeTag #-}
|
||||
{-# INLINABLE decodeTag #-}
|
||||
{-# INLINABLE nullifier #-}
|
||||
{-# INLINABLE unnullifier #-}
|
||||
|
||||
|
||||
instance Nullifiable Expr where
|
||||
encodeTag Tag {expr} = DB expr
|
||||
decodeTag (DB a) = fromExpr a
|
||||
nullifier Tag {expr} test SSpec {nullability} (DB a) =
|
||||
DB $ runTag nullability (test expr) a
|
||||
unnullifier SSpec {nullability} (DB a) = DB $ unnull nullability a
|
||||
|
||||
{-# INLINABLE encodeTag #-}
|
||||
{-# INLINABLE decodeTag #-}
|
||||
{-# INLINABLE nullifier #-}
|
||||
{-# INLINABLE unnullifier #-}
|
||||
|
||||
|
||||
instance Nullifiable Name where
|
||||
encodeTag Tag {name = Name name} = NameCol name
|
||||
decodeTag (NameCol name) = fromName (Name name)
|
||||
nullifier _ _ _ (NameCol name) = NameCol name
|
||||
unnullifier _ (NameCol name) = NameCol name
|
||||
|
||||
{-# INLINABLE encodeTag #-}
|
||||
{-# INLINABLE decodeTag #-}
|
||||
{-# INLINABLE nullifier #-}
|
||||
{-# INLINABLE unnullifier #-}
|
||||
|
||||
|
||||
runTag :: Nullability a -> Expr Bool -> Expr a -> Expr (Nullify a)
|
||||
@ -92,25 +153,25 @@ class HNullifiable context where
|
||||
type HConstrainTag context :: Type -> Constraint
|
||||
type HConstrainTag _context = DefaultConstrainTag
|
||||
|
||||
hencodeTag :: (Sql (HConstrainTag context) a, Sql DBEq a, KnownLabels labels)
|
||||
=> Expr a
|
||||
hencodeTag :: (Sql (HConstrainTag context) a, KnownSymbol label, Taggable a)
|
||||
=> Tag label a
|
||||
-> context ('Spec labels 'Required a)
|
||||
|
||||
hdecodeTag :: (Sql (HConstrainTag context) a, Sql DBMonoid a)
|
||||
hdecodeTag :: (Sql (HConstrainTag context) a, KnownSymbol label, Taggable a)
|
||||
=> context ('Spec labels 'Required a)
|
||||
-> Expr a
|
||||
-> Tag label a
|
||||
|
||||
hnullifier :: ()
|
||||
=> Expr Bool
|
||||
-> SSpec ('Spec labels necessity a)
|
||||
-> context ('Spec labels necessity a)
|
||||
-> context ('Spec labels necessity (Nullify a))
|
||||
=> Tag label a
|
||||
-> (Expr a -> Expr Bool)
|
||||
-> SSpec ('Spec labels necessity x)
|
||||
-> context ('Spec labels necessity x)
|
||||
-> context ('Spec labels necessity (Nullify x))
|
||||
|
||||
hunnullifier :: ()
|
||||
=> Expr Bool
|
||||
-> SSpec ('Spec labels necessity a)
|
||||
-> context ('Spec labels necessity (Nullify a))
|
||||
-> context ('Spec labels necessity a)
|
||||
=> SSpec ('Spec labels necessity x)
|
||||
-> context ('Spec labels necessity (Nullify x))
|
||||
-> context ('Spec labels necessity x)
|
||||
|
||||
|
||||
instance Nullifiable context => HNullifiable (Col context) where
|
||||
@ -125,21 +186,14 @@ instance HNullifiable (Dict (ConstrainDBType constraint)) where
|
||||
type HConstrainTag (Dict (ConstrainDBType constraint)) = constraint
|
||||
|
||||
hencodeTag _ = Dict
|
||||
hdecodeTag = mempty
|
||||
|
||||
hdecodeTag :: forall a context labels. (Sql (HConstrainTag context) a, Sql DBMonoid a)
|
||||
=> context ('Spec labels 'Required a)
|
||||
-> Expr a
|
||||
hdecodeTag _ = case nullabilization @a of
|
||||
Nullable -> nullify memptyExpr
|
||||
NonNullable -> memptyExpr
|
||||
|
||||
|
||||
hnullifier _ SSpec {} dict = case dbTypeDict dict of
|
||||
hnullifier _ _ SSpec {} dict = case dbTypeDict dict of
|
||||
Dict -> case dbTypeNullability dict of
|
||||
Nullable -> Dict
|
||||
NonNullable -> Dict
|
||||
|
||||
hunnullifier _ SSpec {nullability} dict = case dbTypeDict dict of
|
||||
hunnullifier SSpec {nullability} dict = case dbTypeDict dict of
|
||||
Dict -> case nullability of
|
||||
Nullable -> Dict
|
||||
NonNullable -> case dbTypeNullability dict of
|
||||
|
@ -53,3 +53,9 @@ instance Sql DBType a => HTable (HType a) where
|
||||
, info = typeInformation
|
||||
, nullability = nullabilization
|
||||
}
|
||||
|
||||
{-# INLINABLE hfield #-}
|
||||
{-# INLINABLE htabulate #-}
|
||||
{-# INLINABLE htraverse #-}
|
||||
{-# INLINABLE hdicts #-}
|
||||
{-# INLINABLE hspecs #-}
|
||||
|
@ -47,6 +47,7 @@ import Rel8.Schema.Table ( TableSchema )
|
||||
import Rel8.Statement.Returning ( Returning )
|
||||
import Rel8.Table ( Table(..) )
|
||||
import Rel8.Table.Recontextualize ( Recontextualize )
|
||||
import Rel8.Table.Tag ( Tag(..), fromExpr )
|
||||
import Rel8.Type ( DBType )
|
||||
|
||||
|
||||
@ -134,14 +135,18 @@ instance Labelable Insert where
|
||||
|
||||
|
||||
instance Nullifiable Insert where
|
||||
encodeTag = RequiredInsert
|
||||
decodeTag (RequiredInsert a) = a
|
||||
encodeTag = RequiredInsert . expr
|
||||
decodeTag (RequiredInsert a) = fromExpr a
|
||||
|
||||
nullifier tag SSpec {nullability} = \case
|
||||
RequiredInsert a -> RequiredInsert $ runTag nullability tag a
|
||||
OptionalInsert ma -> OptionalInsert $ runTag nullability tag <$> ma
|
||||
nullifier Tag {expr} test SSpec {nullability} = \case
|
||||
RequiredInsert a ->
|
||||
RequiredInsert $ runTag nullability condition a
|
||||
OptionalInsert ma ->
|
||||
OptionalInsert $ runTag nullability condition <$> ma
|
||||
where
|
||||
condition = test expr
|
||||
|
||||
unnullifier _ SSpec {nullability} = \case
|
||||
unnullifier SSpec {nullability} = \case
|
||||
RequiredInsert a -> RequiredInsert $ unnull nullability a
|
||||
OptionalInsert ma -> OptionalInsert $ unnull nullability <$> ma
|
||||
|
||||
@ -151,7 +156,6 @@ instance Nullifiable Insert where
|
||||
{-# INLINABLE unnullifier #-}
|
||||
|
||||
|
||||
|
||||
-- | @Inserts a b@ means that the columns in @a@ are compatible for inserting
|
||||
-- with the table @b@.
|
||||
type Inserts :: Type -> Type -> Constraint
|
||||
|
@ -21,24 +21,18 @@ where
|
||||
|
||||
-- base
|
||||
import Data.Functor.Identity ( Identity )
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import Data.Kind ( Constraint, Type )
|
||||
import Data.String ( IsString )
|
||||
import Prelude
|
||||
|
||||
-- rel8
|
||||
import Rel8.Expr ( Expr )
|
||||
import Rel8.Kind.Labels ( KnownLabels, labelsSing, renderLabels )
|
||||
import Rel8.Opaque ( Opaque )
|
||||
import Rel8.Schema.Context ( Interpretation, Col )
|
||||
import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler )
|
||||
import Rel8.Schema.Context.Nullify
|
||||
( Nullifiable, encodeTag, decodeTag, nullifier, unnullifier
|
||||
)
|
||||
import Rel8.Schema.HTable.Type ( HType( HType ) )
|
||||
import qualified Rel8.Schema.Kind as K
|
||||
import Rel8.Schema.Nullability ( Sql )
|
||||
import Rel8.Schema.Spec ( Spec( Spec ) )
|
||||
import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
|
||||
import Rel8.Table.Recontextualize ( Recontextualize )
|
||||
import Rel8.Type ( DBType )
|
||||
@ -86,24 +80,6 @@ instance Labelable Name where
|
||||
unlabeler (NameCol a) = NameCol a
|
||||
|
||||
|
||||
instance Nullifiable Name where
|
||||
encodeTag _ = nameFromLabel
|
||||
decodeTag _ = mempty
|
||||
nullifier _ _ (NameCol name) = NameCol name
|
||||
unnullifier _ _ (NameCol name) = NameCol name
|
||||
|
||||
{-# INLINABLE encodeTag #-}
|
||||
{-# INLINABLE decodeTag #-}
|
||||
{-# INLINABLE nullifier #-}
|
||||
{-# INLINABLE unnullifier #-}
|
||||
|
||||
|
||||
nameFromLabel :: forall labels necessity a.
|
||||
KnownLabels labels => Col Name ('Spec labels necessity a)
|
||||
nameFromLabel = case labelsSing @labels of
|
||||
labels -> NameCol (NonEmpty.last (renderLabels labels))
|
||||
|
||||
|
||||
-- | @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
|
||||
|
@ -5,6 +5,7 @@
|
||||
{-# language FunctionalDependencies #-}
|
||||
{-# language GADTs #-}
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language RankNTypes #-}
|
||||
{-# language QuantifiedConstraints #-}
|
||||
{-# language StandaloneKindSignatures #-}
|
||||
{-# language TypeFamilies #-}
|
||||
@ -17,7 +18,7 @@ module Rel8.Schema.Nullability.Internal
|
||||
, Homonullable
|
||||
, Nullability( Nullable, NonNullable )
|
||||
, HasNullability, nullabilization
|
||||
, Sql, toSql
|
||||
, Sql, fromSql, mapSql, toSql
|
||||
)
|
||||
where
|
||||
|
||||
@ -56,12 +57,15 @@ type Nullify :: Type -> Type
|
||||
type Nullify a = Maybe (Unnullify a)
|
||||
|
||||
|
||||
-- | @NotNull a@ means @a@ cannot take @null@ as a value.
|
||||
type NotNull :: Type -> Constraint
|
||||
class (HasNullability a, IsMaybe a ~ 'False) => NotNull a
|
||||
instance (HasNullability a, IsMaybe a ~ 'False) => NotNull a
|
||||
instance {-# OVERLAPPING #-} NotNull Opaque
|
||||
|
||||
|
||||
-- | @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
|
||||
@ -92,6 +96,8 @@ instance IsMaybe a ~ 'False => HasNullability' 'True (Maybe a) where
|
||||
nullabilization' = Nullable
|
||||
|
||||
|
||||
-- | @HasNullability a@ means that @rel8@ is able to check if the type @a@ is a
|
||||
-- type that can take @null@ values or not.
|
||||
type HasNullability :: Type -> Constraint
|
||||
class HasNullability' (IsMaybe a) a => HasNullability a
|
||||
instance HasNullability' (IsMaybe a) a => HasNullability a
|
||||
@ -118,6 +124,19 @@ class
|
||||
instance (constraint (Unnullify a), HasNullability a) => Sql constraint a
|
||||
|
||||
|
||||
fromSql :: Dict (Sql constraint) a -> (Nullability a, Dict constraint (Unnullify a))
|
||||
fromSql Dict = (nullabilization, Dict)
|
||||
{-# INLINABLE fromSql #-}
|
||||
|
||||
|
||||
mapSql :: ()
|
||||
=> (forall x. Dict constraint x -> Dict constraint' x)
|
||||
-> Dict (Sql constraint) a -> Dict (Sql constraint') a
|
||||
mapSql f dict = case fromSql dict of
|
||||
(nullability, dict') -> toSql nullability (f dict')
|
||||
|
||||
|
||||
toSql :: Nullability a -> Dict constraint (Unnullify a) -> Dict (Sql constraint) a
|
||||
toSql NonNullable Dict = Dict
|
||||
toSql Nullable Dict = Dict
|
||||
{-# INLINABLE toSql #-}
|
||||
|
@ -15,20 +15,7 @@ import Prelude
|
||||
-- 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. For a table
|
||||
-- storing a list of projects (as defined in the introduction):
|
||||
--
|
||||
-- >>> :{
|
||||
-- projectSchema :: TableSchema (Project ColumnSchema)
|
||||
-- projectSchema = TableSchema
|
||||
-- { tableName = "project"
|
||||
-- , tableSchema = Nothing -- Assumes that the 'project' table is reachable from your connection's search_path
|
||||
-- , tableColumns = Project
|
||||
-- { projectAuthorId = "author_id"
|
||||
-- , projectName = "name"
|
||||
-- }
|
||||
-- }
|
||||
-- :}
|
||||
-- @TableSchema@ in order to interact with the table via Rel8.
|
||||
data TableSchema names = TableSchema
|
||||
{ name :: String
|
||||
-- ^ The name of the table.
|
||||
|
@ -56,24 +56,6 @@ data Delete a where
|
||||
|
||||
|
||||
-- | Run a @DELETE@ statement.
|
||||
--
|
||||
-- >>> mapM_ print =<< select c (each projectSchema)
|
||||
-- Project {projectAuthorId = 1, projectName = "rel8"}
|
||||
-- Project {projectAuthorId = 2, projectName = "aeson"}
|
||||
-- Project {projectAuthorId = 2, projectName = "text"}
|
||||
--
|
||||
-- >>> :{
|
||||
-- delete c Delete
|
||||
-- { from = projectSchema
|
||||
-- , deleteWhere = \p -> projectName p ==. lit "rel8"
|
||||
-- , returning = Projection projectName
|
||||
-- }
|
||||
-- :}
|
||||
-- ["rel8"]
|
||||
--
|
||||
-- >>> mapM_ print =<< select c (each projectSchema)
|
||||
-- Project {projectAuthorId = 2, projectName = "aeson"}
|
||||
-- Project {projectAuthorId = 2, projectName = "text"}
|
||||
delete :: Connection -> Delete a -> IO a
|
||||
delete c Delete {from, deleteWhere, returning} =
|
||||
case returning of
|
||||
|
@ -39,16 +39,6 @@ import Data.Text.Encoding ( encodeUtf8 )
|
||||
|
||||
|
||||
-- | Run an @INSERT@ statement
|
||||
--
|
||||
-- >>> :{
|
||||
-- insert c Insert
|
||||
-- { into = authorSchema
|
||||
-- , rows = [ lit Author{ authorName = "Gabriel Gonzales", authorId = AuthorId 4, authorUrl = Just "https://haskellforall.com" } ]
|
||||
-- , onConflict = Abort
|
||||
-- , returning = NumberOfRowsAffected
|
||||
-- }
|
||||
-- :}
|
||||
-- 1
|
||||
insert :: Connection -> Insert a -> IO a
|
||||
insert c Insert {into, rows, onConflict, returning} =
|
||||
case (rows, returning) of
|
||||
|
@ -61,26 +61,6 @@ data Update a where
|
||||
|
||||
|
||||
-- | Run an @UPDATE@ statement.
|
||||
--
|
||||
-- >>> mapM_ print =<< select c (each projectSchema)
|
||||
-- Project {projectAuthorId = 1, projectName = "rel8"}
|
||||
-- Project {projectAuthorId = 2, projectName = "aeson"}
|
||||
-- Project {projectAuthorId = 2, projectName = "text"}
|
||||
--
|
||||
-- >>> :{
|
||||
-- update c Update
|
||||
-- { target = projectSchema
|
||||
-- , set = \p -> p { projectName = "Rel8!" }
|
||||
-- , updateWhere = \p -> projectName p ==. lit "rel8"
|
||||
-- , returning = NumberOfRowsAffected
|
||||
-- }
|
||||
-- :}
|
||||
-- 1
|
||||
--
|
||||
-- >>> mapM_ print =<< select c (each projectSchema)
|
||||
-- Project {projectAuthorId = 2, projectName = "aeson"}
|
||||
-- Project {projectAuthorId = 2, projectName = "text"}
|
||||
-- Project {projectAuthorId = 1, projectName = "Rel8!"}
|
||||
update :: Connection -> Update a -> IO a
|
||||
update c Update {target, set, updateWhere, returning} =
|
||||
case returning of
|
||||
|
@ -31,6 +31,9 @@ import qualified Data.Text as Text
|
||||
import Data.Text.Encoding ( encodeUtf8 )
|
||||
|
||||
|
||||
-- | 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 -> Connection -> IO ()
|
||||
createView (TableSchema name mschema names) query =
|
||||
|
@ -42,11 +42,13 @@ import Rel8.Type ( DBType )
|
||||
-- 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 'Expr' context), aggregations (the 'Aggregate'
|
||||
-- context), insert values (the 'Insert' contex), among others.
|
||||
-- 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 'Rel8able' is always a '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) => Table context a | a -> context where
|
||||
-- | The 'HTable' functor that describes the schema of this table.
|
||||
|
@ -9,8 +9,6 @@ module Rel8.Table.Aggregate
|
||||
( groupBy
|
||||
, listAgg
|
||||
, nonEmptyAgg
|
||||
, sequenceAggregate
|
||||
, distributeAggregate
|
||||
)
|
||||
where
|
||||
|
||||
@ -19,7 +17,7 @@ import Data.Functor.Identity ( Identity( Identity ) )
|
||||
import Prelude
|
||||
|
||||
-- rel8
|
||||
import Rel8.Aggregate ( Aggregate, Aggregates, Col(..) )
|
||||
import Rel8.Aggregate ( Aggregate, Col(..) )
|
||||
import Rel8.Expr ( Expr, Col(..) )
|
||||
import Rel8.Expr.Aggregate ( groupByExpr, listAggExpr, nonEmptyAggExpr )
|
||||
import Rel8.Schema.Dict ( Dict( Dict ) )
|
||||
@ -69,11 +67,3 @@ nonEmptyAgg (toColumns -> exprs) = fromColumns $
|
||||
hvectorize
|
||||
(\_ (Identity (DB a)) -> Aggregation $ nonEmptyAggExpr a)
|
||||
(pure exprs)
|
||||
|
||||
|
||||
sequenceAggregate :: Aggregates aggregates exprs => aggregates -> Aggregate exprs
|
||||
sequenceAggregate = fromColumns . toColumns
|
||||
|
||||
|
||||
distributeAggregate :: Aggregates aggregates exprs => Aggregate exprs -> aggregates
|
||||
distributeAggregate = fromColumns . toColumns
|
||||
|
@ -20,8 +20,8 @@ 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'.
|
||||
--
|
||||
-- For example, using '<|>:' on '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.
|
||||
|
@ -18,14 +18,22 @@ import Rel8.Schema.HTable ( htabulate, hfield )
|
||||
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@.
|
||||
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
|
||||
(DB falseExpr, DB trueExpr) ->
|
||||
DB (boolExpr falseExpr trueExpr condition)
|
||||
{-# INLINABLE 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.
|
||||
case_ :: Table Expr a => [(Expr Bool, a)] -> a -> a
|
||||
case_ (map (fmap toColumns) -> branches) (toColumns -> fallback) =
|
||||
fromColumns $ htabulate $ \field -> case hfield fallback field of
|
||||
|
@ -15,6 +15,7 @@ module Rel8.Table.Either
|
||||
( EitherTable(..)
|
||||
, eitherTable, leftTable, rightTable
|
||||
, isLeftTable, isRightTable
|
||||
, aggregateEitherTable, nameEitherTable
|
||||
)
|
||||
where
|
||||
|
||||
@ -25,7 +26,9 @@ import Data.Kind ( Type )
|
||||
import Prelude hiding ( undefined )
|
||||
|
||||
-- rel8
|
||||
import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )
|
||||
import Rel8.Expr ( Expr )
|
||||
import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
|
||||
import Rel8.Expr.Serialize ( litExpr )
|
||||
import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler, hlabeler )
|
||||
import Rel8.Schema.Context.Nullify
|
||||
@ -37,6 +40,7 @@ import Rel8.Schema.HTable.Either ( HEitherTable(..), HEitherNullifiable )
|
||||
import Rel8.Schema.HTable.Identity ( HIdentity(..) )
|
||||
import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
|
||||
import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
|
||||
import Rel8.Schema.Name ( Name )
|
||||
import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
|
||||
import Rel8.Table.Bool ( bool )
|
||||
import Rel8.Table.Eq ( EqTable, eqTable )
|
||||
@ -45,21 +49,22 @@ import Rel8.Table.Lifted
|
||||
)
|
||||
import Rel8.Table.Ord ( OrdTable, ordTable )
|
||||
import Rel8.Table.Recontextualize ( Recontextualize )
|
||||
import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )
|
||||
import Rel8.Table.Undefined ( undefined )
|
||||
import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ), isLeft, isRight )
|
||||
|
||||
-- semigroupoids
|
||||
import Data.Functor.Apply ( Apply, (<.>) )
|
||||
import Data.Functor.Apply ( Apply, (<.>), liftF3 )
|
||||
import Data.Functor.Bind ( Bind, (>>-) )
|
||||
|
||||
|
||||
type EitherTable :: Type -> Type -> Type
|
||||
data EitherTable a b = EitherTable
|
||||
{ tag :: Expr EitherTag
|
||||
{ tag :: Tag "isRight" EitherTag
|
||||
, left :: a
|
||||
, right :: b
|
||||
}
|
||||
deriving stock (Show, Functor)
|
||||
deriving stock Functor
|
||||
|
||||
|
||||
instance Bifunctor EitherTable where
|
||||
@ -68,7 +73,7 @@ instance Bifunctor EitherTable where
|
||||
|
||||
instance Table Expr a => Apply (EitherTable a) where
|
||||
EitherTable tag l1 f <.> EitherTable tag' l2 a =
|
||||
EitherTable (tag <> tag') (bool l1 l2 (isLeft tag)) (f a)
|
||||
EitherTable (tag <> tag') (bool l1 l2 (isLeft (expr tag))) (f a)
|
||||
|
||||
|
||||
instance Table Expr a => Applicative (EitherTable a) where
|
||||
@ -79,7 +84,7 @@ instance Table Expr a => Applicative (EitherTable a) where
|
||||
instance Table Expr a => Bind (EitherTable a) where
|
||||
EitherTable tag l1 a >>- f = case f a of
|
||||
EitherTable tag' l2 b ->
|
||||
EitherTable (tag <> tag') (bool l1 l2 (isRight tag)) b
|
||||
EitherTable (tag <> tag') (bool l1 l2 (isRight (expr tag))) b
|
||||
|
||||
|
||||
instance Table Expr a => Monad (EitherTable a) where
|
||||
@ -96,8 +101,8 @@ instance Table2 EitherTable where
|
||||
|
||||
toColumns2 f g EitherTable {tag, left, right} = HEitherTable
|
||||
{ htag
|
||||
, hleft = hnullify (hnullifier (isLeft tag)) $ f left
|
||||
, hright = hnullify (hnullifier (isRight tag)) $ g right
|
||||
, hleft = hnullify (hnullifier tag isLeft) $ f left
|
||||
, hright = hnullify (hnullifier tag isRight) $ g right
|
||||
}
|
||||
where
|
||||
htag = HIdentity (hencodeTag tag)
|
||||
@ -106,9 +111,9 @@ instance Table2 EitherTable where
|
||||
EitherTable
|
||||
{ tag
|
||||
, left = f $ runIdentity $
|
||||
hunnullify (\a -> pure . hunnullifier (isLeft tag) a) hleft
|
||||
hunnullify (\a -> pure . hunnullifier a) hleft
|
||||
, right = g $ runIdentity $
|
||||
hunnullify (\a -> pure . hunnullifier (isRight tag) a) hright
|
||||
hunnullify (\a -> pure . hunnullifier a) hright
|
||||
}
|
||||
where
|
||||
tag = hdecodeTag $ unHIdentity htag
|
||||
@ -159,21 +164,21 @@ instance (OrdTable a, OrdTable b) => OrdTable (EitherTable a b) where
|
||||
|
||||
|
||||
isLeftTable :: EitherTable a b -> Expr Bool
|
||||
isLeftTable = isLeft . tag
|
||||
isLeftTable = isLeft . expr . tag
|
||||
|
||||
|
||||
isRightTable :: EitherTable a b -> Expr Bool
|
||||
isRightTable = isRight . tag
|
||||
isRightTable = isRight . expr . tag
|
||||
|
||||
|
||||
eitherTable :: Table Expr c
|
||||
=> (a -> c) -> (b -> c) -> EitherTable a b -> c
|
||||
eitherTable f g EitherTable {tag, left, right} =
|
||||
bool (f left) (g right) (isRight tag)
|
||||
bool (f left) (g right) (isRight (expr tag))
|
||||
|
||||
|
||||
leftTable :: Table Expr b => a -> EitherTable a b
|
||||
leftTable a = EitherTable (litExpr IsLeft) a undefined
|
||||
leftTable a = EitherTable (fromExpr (litExpr IsLeft)) a undefined
|
||||
|
||||
|
||||
rightTable :: Table Expr a => b -> EitherTable a b
|
||||
@ -181,4 +186,20 @@ rightTable = rightTableWith undefined
|
||||
|
||||
|
||||
rightTableWith :: a -> b -> EitherTable a b
|
||||
rightTableWith = EitherTable (litExpr IsRight)
|
||||
rightTableWith = EitherTable (fromExpr (litExpr IsRight))
|
||||
|
||||
|
||||
aggregateEitherTable :: ()
|
||||
=> (a -> Aggregate c)
|
||||
-> (b -> Aggregate d)
|
||||
-> EitherTable a b
|
||||
-> Aggregate (EitherTable c d)
|
||||
aggregateEitherTable f g EitherTable {tag, left, right} =
|
||||
liftF3 EitherTable (tag <$ aggregate) (f left) (g right)
|
||||
where
|
||||
Tag {aggregator, expr} = tag
|
||||
aggregate = unsafeMakeAggregate toPrimExpr fromPrimExpr aggregator expr
|
||||
|
||||
|
||||
nameEitherTable :: Name EitherTag -> a -> b -> EitherTable a b
|
||||
nameEitherTable = EitherTable . fromName
|
||||
|
@ -48,6 +48,9 @@ import Rel8.Type.Eq ( DBEq )
|
||||
import Rel8.Schema.Nullability ( Sql )
|
||||
|
||||
|
||||
-- | 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 (ConstrainDBType DBEq))
|
||||
|
@ -22,9 +22,9 @@ import Rel8.Table ( fromColumns, toColumns )
|
||||
|
||||
|
||||
-- | @toInsert@ converts a 'Table' of 'Expr's into a 'Table' that can be used
|
||||
-- with 'insert'. This will override any columns that have default values to
|
||||
-- use exactly what is given. If you want to use default values, you can either
|
||||
-- override the result of @toInsert@, or use 'toInsertDefaults'.
|
||||
-- with 'Rel8.insert'. This will override any columns that have default values
|
||||
-- to use exactly what is given. If you want to use default values, you can
|
||||
-- either override the result of @toInsert@, or use 'toInsertDefaults'.
|
||||
toInsert :: Inserts exprs inserts => exprs -> inserts
|
||||
toInsert (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
|
||||
case hfield hspecs field of
|
||||
@ -35,8 +35,8 @@ toInsert (toColumns -> exprs) = fromColumns $ htabulate $ \field ->
|
||||
|
||||
|
||||
-- | @toInsertDefaults@ converts a 'Table' of 'Expr's into a 'Table' that can
|
||||
-- be used with 'insert'. Any columns that have a default value will override
|
||||
-- whatever is in the input expression.
|
||||
-- be used with 'Rel8.insert'. Any columns that have a default value will
|
||||
-- override whatever is in the input expression.
|
||||
--
|
||||
-- One example where this is useful is for any table that has a special @id@
|
||||
-- column, which has a default value to draw a new value from a sequence. If we
|
||||
|
@ -39,7 +39,7 @@ import Rel8.Table.Recontextualize ( Recontextualize )
|
||||
|
||||
|
||||
-- | A @ListTable@ value contains zero or more instances of @a@. You construct
|
||||
-- @ListTable@s with 'many' or 'listAgg'.
|
||||
-- @ListTable@s with 'Rel8.many' or 'Rel8.listAgg'.
|
||||
type ListTable :: Type -> Type
|
||||
newtype ListTable a = ListTable (HListTable (Columns a) (Col (Context a)))
|
||||
|
||||
|
@ -16,6 +16,8 @@ module Rel8.Table.Maybe
|
||||
, maybeTable, nothingTable, justTable
|
||||
, isNothingTable, isJustTable
|
||||
, ($?)
|
||||
, aggregateMaybeTable
|
||||
, nameMaybeTable
|
||||
)
|
||||
where
|
||||
|
||||
@ -25,10 +27,11 @@ import Data.Kind ( Type )
|
||||
import Prelude hiding ( null, repeat, undefined, zipWith )
|
||||
|
||||
-- rel8
|
||||
import Rel8.Aggregate ( Aggregate, unsafeMakeAggregate )
|
||||
import Rel8.Expr ( Expr )
|
||||
import Rel8.Expr.Bool ( boolExpr )
|
||||
import Rel8.Expr.Null ( isNull, isNonNull, null, nullify )
|
||||
import Rel8.Expr.Serialize ( litExpr )
|
||||
import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )
|
||||
import Rel8.Schema.Context.Label ( Labelable, labeler, unlabeler, hlabeler )
|
||||
import Rel8.Schema.Context.Nullify
|
||||
( Nullifiable, ConstrainTag
|
||||
@ -39,6 +42,7 @@ import Rel8.Schema.HTable.Identity ( HIdentity(..) )
|
||||
import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
|
||||
import Rel8.Schema.HTable.Maybe ( HMaybeTable(..), HMaybeNullifiable )
|
||||
import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
|
||||
import Rel8.Schema.Name ( Name )
|
||||
import Rel8.Schema.Nullability
|
||||
( Nullify
|
||||
, Nullability( Nullable, NonNullable )
|
||||
@ -56,12 +60,13 @@ import Rel8.Table.Lifted
|
||||
)
|
||||
import Rel8.Table.Ord ( OrdTable, ordTable )
|
||||
import Rel8.Table.Recontextualize ( Recontextualize )
|
||||
import Rel8.Table.Tag ( Tag(..), fromExpr, fromName )
|
||||
import Rel8.Table.Undefined ( undefined )
|
||||
import Rel8.Type ( DBType )
|
||||
import Rel8.Type.Tag ( MaybeTag( IsJust ) )
|
||||
import Rel8.Type.Tag ( MaybeTag )
|
||||
|
||||
-- semigroupoids
|
||||
import Data.Functor.Apply ( Apply, (<.>) )
|
||||
import Data.Functor.Apply ( Apply, (<.>), liftF2 )
|
||||
import Data.Functor.Bind ( Bind, (>>-) )
|
||||
|
||||
|
||||
@ -75,10 +80,10 @@ import Data.Functor.Bind ( Bind, (>>-) )
|
||||
-- a "nullTag" - to track whether or not the outer join produced any rows.
|
||||
type MaybeTable :: Type -> Type
|
||||
data MaybeTable a = MaybeTable
|
||||
{ tag :: Expr (Maybe MaybeTag)
|
||||
{ tag :: Tag "isJust" (Maybe MaybeTag)
|
||||
, just :: a
|
||||
}
|
||||
deriving stock (Show, Functor)
|
||||
deriving stock Functor
|
||||
|
||||
|
||||
instance Apply MaybeTable where
|
||||
@ -86,7 +91,7 @@ instance Apply MaybeTable where
|
||||
|
||||
|
||||
-- | Has the same behavior as the @Applicative@ instance for @Maybe@. See also:
|
||||
-- 'traverseMaybeTable'.
|
||||
-- 'Rel8.traverseMaybeTable'.
|
||||
instance Applicative MaybeTable where
|
||||
(<*>) = (<.>)
|
||||
pure = justTable
|
||||
@ -98,14 +103,16 @@ instance Bind MaybeTable where
|
||||
|
||||
|
||||
-- | Has the same behavior as the @Monad@ instance for @Maybe@. See also:
|
||||
-- 'bindMaybeTable'.
|
||||
-- 'Rel8.bindMaybeTable'.
|
||||
instance Monad MaybeTable where
|
||||
(>>=) = (>>-)
|
||||
|
||||
|
||||
instance AltTable MaybeTable where
|
||||
ma@(MaybeTable tag a) <|>: MaybeTable tag' b = MaybeTable
|
||||
{ tag = boolExpr tag tag' condition
|
||||
{ tag = (tag <> tag')
|
||||
{ expr = boolExpr (expr tag) (expr tag') condition
|
||||
}
|
||||
, just = bool a b condition
|
||||
}
|
||||
where
|
||||
@ -130,7 +137,7 @@ instance Table1 MaybeTable where
|
||||
|
||||
toColumns1 f MaybeTable {tag, just} = HMaybeTable
|
||||
{ htag
|
||||
, hjust = hnullify (hnullifier (isNonNull tag)) $ f just
|
||||
, hjust = hnullify (hnullifier tag isNonNull) $ f just
|
||||
}
|
||||
where
|
||||
htag = HIdentity (hencodeTag tag)
|
||||
@ -138,7 +145,7 @@ instance Table1 MaybeTable where
|
||||
fromColumns1 f HMaybeTable {htag = HIdentity htag, hjust} = MaybeTable
|
||||
{ tag
|
||||
, just = f $ runIdentity $
|
||||
hunnullify (\a -> pure . hunnullifier (isNonNull tag) a) hjust
|
||||
hunnullify (\a -> pure . hunnullifier a) hjust
|
||||
}
|
||||
where
|
||||
tag = hdecodeTag htag
|
||||
@ -175,38 +182,36 @@ instance OrdTable a => OrdTable (MaybeTable a) where
|
||||
ordTable = toColumns1 (hlabel hlabeler) (justTable (ordTable @a))
|
||||
|
||||
|
||||
-- | Check if a @MaybeTable@ is absent of any row.. Like 'isNothing'.
|
||||
-- | Check if a @MaybeTable@ is absent of any row. Like 'Data.Maybe.isNothing'.
|
||||
isNothingTable :: MaybeTable a -> Expr Bool
|
||||
isNothingTable (MaybeTable tag _) = isNull tag
|
||||
isNothingTable (MaybeTable tag _) = isNull (expr tag)
|
||||
|
||||
|
||||
-- | Check if a @MaybeTable@ contains a row. Like 'isJust'.
|
||||
-- | Check if a @MaybeTable@ contains a row. Like 'Data.Maybe.isJust'.
|
||||
isJustTable :: MaybeTable a -> Expr Bool
|
||||
isJustTable (MaybeTable tag _) = isNonNull tag
|
||||
isJustTable (MaybeTable tag _) = isNonNull (expr tag)
|
||||
|
||||
|
||||
-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.
|
||||
maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable a -> b
|
||||
maybeTable b f ma@(MaybeTable _ a) = bool (f a) b (isNothingTable ma)
|
||||
{-# INLINABLE maybeTable #-}
|
||||
|
||||
|
||||
-- | The null table. Like 'Nothing'.
|
||||
nothingTable :: Table Expr a => MaybeTable a
|
||||
nothingTable = MaybeTable null undefined
|
||||
nothingTable = MaybeTable (fromExpr null) undefined
|
||||
|
||||
|
||||
-- | Lift any table into 'MaybeTable'. Like 'Just'. Note you can also use
|
||||
-- 'pure'.
|
||||
justTable :: a -> MaybeTable a
|
||||
justTable = MaybeTable (nullify (litExpr IsJust))
|
||||
justTable = MaybeTable (fromExpr mempty)
|
||||
|
||||
|
||||
-- | 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@.
|
||||
--
|
||||
-- >>> select c $ fmap (fst $?) (optional (values [lit (True, False)]))
|
||||
-- [Just True]
|
||||
($?) :: forall a b. Sql DBType b
|
||||
=> (a -> Expr b) -> MaybeTable a -> Expr (Nullify b)
|
||||
f $? ma@(MaybeTable _ a) = case nullabilization @b of
|
||||
@ -214,3 +219,14 @@ f $? ma@(MaybeTable _ a) = case nullabilization @b of
|
||||
NonNullable -> boolExpr (nullify (f a)) null (isNothingTable ma)
|
||||
infixl 4 $?
|
||||
|
||||
|
||||
aggregateMaybeTable :: ()
|
||||
=> (a -> Aggregate b) -> MaybeTable a -> Aggregate (MaybeTable b)
|
||||
aggregateMaybeTable f MaybeTable {tag = tag@Tag {aggregator, expr}, just} =
|
||||
liftF2 MaybeTable (tag <$ aggregate) (f just)
|
||||
where
|
||||
aggregate = unsafeMakeAggregate toPrimExpr fromPrimExpr aggregator expr
|
||||
|
||||
|
||||
nameMaybeTable :: Name (Maybe MaybeTag) -> a -> MaybeTable a
|
||||
nameMaybeTable = MaybeTable . fromName
|
||||
|
@ -38,7 +38,7 @@ import Rel8.Table.Recontextualize ( Recontextualize )
|
||||
|
||||
|
||||
-- | A @NonEmptyTable@ value contains one or more instances of @a@. You
|
||||
-- construct @NonEmptyTable@s with 'some' or 'nonEmptyAgg'.
|
||||
-- construct @NonEmptyTable@s with 'Rel8.some' or 'nonEmptyAgg'.
|
||||
type NonEmptyTable :: Type -> Type
|
||||
newtype NonEmptyTable a =
|
||||
NonEmptyTable (HNonEmptyTable (Columns a) (Col (Context a)))
|
||||
|
@ -35,8 +35,7 @@ import Data.Profunctor ( dimap, lmap )
|
||||
import Rel8.Aggregate ( Aggregate( Aggregate ) )
|
||||
import Rel8.Expr ( Expr, Col(..) )
|
||||
import Rel8.Expr.Opaleye
|
||||
( scastExpr
|
||||
, fromPrimExpr, toPrimExpr
|
||||
( fromPrimExpr, toPrimExpr
|
||||
, traversePrimExpr
|
||||
, fromColumn, toColumn
|
||||
)
|
||||
@ -94,14 +93,14 @@ tableFields (toColumns -> names) = dimap toColumns fromColumns $
|
||||
name -> lmap (`hfield` field) (go specs name)
|
||||
where
|
||||
go :: SSpec spec -> Col Name spec -> Opaleye.TableFields (Col Insert spec) (Col Expr spec)
|
||||
go SSpec {necessity, info} (NameCol name) = case necessity of
|
||||
go SSpec {necessity} (NameCol name) = case necessity of
|
||||
SRequired ->
|
||||
lmap (\(RequiredInsert a) -> toColumn $ toPrimExpr a) $
|
||||
DB . scastExpr info . fromPrimExpr . fromColumn <$>
|
||||
DB . fromPrimExpr . fromColumn <$>
|
||||
Opaleye.requiredTableField name
|
||||
SOptional ->
|
||||
lmap (\(OptionalInsert ma) -> toColumn . toPrimExpr <$> ma) $
|
||||
DB . scastExpr info . fromPrimExpr . fromColumn <$>
|
||||
DB . fromPrimExpr . fromColumn <$>
|
||||
Opaleye.optionalTableField name
|
||||
|
||||
|
||||
|
@ -279,6 +279,8 @@ instance (ToExprs a exprs, 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.
|
||||
lit :: forall exprs a. Serializable exprs a => a -> exprs
|
||||
lit = fromColumns . litHTable . toIdentity' @exprs
|
||||
|
||||
|
104
src/Rel8/Table/Tag.hs
Normal file
104
src/Rel8/Table/Tag.hs
Normal file
@ -0,0 +1,104 @@
|
||||
{-# language DataKinds #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language GADTs #-}
|
||||
{-# language InstanceSigs #-}
|
||||
{-# language NamedFieldPuns #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language StandaloneKindSignatures #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
|
||||
module Rel8.Table.Tag
|
||||
( Tag(..), Taggable
|
||||
, fromAggregate
|
||||
, fromExpr
|
||||
, fromName
|
||||
)
|
||||
where
|
||||
|
||||
-- base
|
||||
import Control.Applicative ( (<|>), empty )
|
||||
import Data.Kind ( Constraint, Type )
|
||||
import Data.Foldable ( fold )
|
||||
import Data.Monoid ( getFirst )
|
||||
import Data.Proxy ( Proxy( Proxy ) )
|
||||
import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )
|
||||
import Prelude
|
||||
|
||||
-- rel8
|
||||
import Rel8.Aggregate ( Aggregate, Aggregator, foldInputs )
|
||||
import Rel8.Expr ( Expr )
|
||||
import Rel8.Expr.Opaleye ( fromPrimExpr )
|
||||
import Rel8.Schema.Dict ( Dict( Dict ) )
|
||||
import Rel8.Schema.Name ( Name( Name ) )
|
||||
import Rel8.Schema.Nullability ( Sql, mapSql )
|
||||
import Rel8.Type.Monoid ( DBMonoid )
|
||||
import Rel8.Type.Semigroup ( DBSemigroup )
|
||||
|
||||
|
||||
type Tag :: Symbol -> Type -> Type
|
||||
data Tag label a = Tag
|
||||
{ expr :: Expr a
|
||||
, aggregator :: Maybe Aggregator
|
||||
, name :: Name a
|
||||
}
|
||||
|
||||
|
||||
type Taggable :: Type -> Constraint
|
||||
class Taggable a where
|
||||
tappend :: KnownSymbol label => Tag label a -> Tag label a -> Tag label a
|
||||
tempty :: KnownSymbol label => Tag label a
|
||||
|
||||
|
||||
instance Sql DBMonoid a => Taggable a where
|
||||
tappend :: forall label. KnownSymbol label
|
||||
=> Tag label a -> Tag label a -> Tag label a
|
||||
tappend a b = Tag
|
||||
{ expr = case mapSql dbSemigroupFromDBMonoid (Dict @_ @a) of
|
||||
Dict -> expr a <> expr b
|
||||
, aggregator = aggregator a <|> aggregator b
|
||||
, name = case (name a, symbolVal (Proxy @label)) of
|
||||
(Name x, y)
|
||||
| x == y -> name b
|
||||
| otherwise -> name a
|
||||
}
|
||||
{-# INLINABLE tappend #-}
|
||||
|
||||
tempty :: forall label. KnownSymbol label => Tag label a
|
||||
tempty = Tag
|
||||
{ expr = mempty
|
||||
, aggregator = empty
|
||||
, name = Name (symbolVal (Proxy @label))
|
||||
}
|
||||
{-# INLINABLE tempty #-}
|
||||
|
||||
|
||||
instance (KnownSymbol label, Taggable a) => Semigroup (Tag label a) where
|
||||
(<>) = tappend
|
||||
|
||||
|
||||
instance (KnownSymbol label, Taggable a) => Monoid (Tag label a) where
|
||||
mempty = tempty
|
||||
|
||||
|
||||
fromAggregate :: forall a label. (KnownSymbol label, Taggable a)
|
||||
=> Aggregate (Expr a) -> Tag label a
|
||||
fromAggregate = fold . getFirst . foldInputs go
|
||||
where
|
||||
go aggregator primExpr = pure $ (tempty @a @label)
|
||||
{ expr = fromPrimExpr primExpr
|
||||
, aggregator
|
||||
}
|
||||
|
||||
|
||||
fromExpr :: forall label a. (KnownSymbol label, Taggable a)
|
||||
=> Expr a -> Tag label a
|
||||
fromExpr expr = (tempty @a @label) {expr}
|
||||
|
||||
|
||||
fromName :: forall a label. Taggable a => Name a -> Tag label a
|
||||
fromName name = (tempty @a @"") {name}
|
||||
|
||||
|
||||
dbSemigroupFromDBMonoid :: Dict DBMonoid a -> Dict DBSemigroup a
|
||||
dbSemigroupFromDBMonoid Dict = Dict
|
@ -5,6 +5,7 @@
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language NamedFieldPuns #-}
|
||||
{-# language RecordWildCards #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language StandaloneKindSignatures #-}
|
||||
{-# language TupleSections #-}
|
||||
@ -18,6 +19,7 @@ module Rel8.Table.These
|
||||
, isThisTable, isThatTable, isThoseTable
|
||||
, hasHereTable, hasThereTable
|
||||
, justHereTable, justThereTable
|
||||
, aggregateTheseTable, nameTheseTable
|
||||
)
|
||||
where
|
||||
|
||||
@ -28,6 +30,7 @@ import Data.Kind ( Type )
|
||||
import Prelude hiding ( undefined )
|
||||
|
||||
-- rel8
|
||||
import Rel8.Aggregate ( Aggregate )
|
||||
import Rel8.Expr ( Expr )
|
||||
import Rel8.Expr.Bool ( (&&.), not_ )
|
||||
import Rel8.Expr.Null ( isNonNull )
|
||||
@ -42,6 +45,7 @@ import Rel8.Schema.HTable.Identity ( HIdentity(..) )
|
||||
import Rel8.Schema.HTable.Maybe ( HMaybeNullifiable )
|
||||
import Rel8.Schema.HTable.Nullify ( hnullify, hunnullify )
|
||||
import Rel8.Schema.HTable.These ( HTheseTable(..) )
|
||||
import Rel8.Schema.Name ( Name )
|
||||
import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
|
||||
import Rel8.Table.Eq ( EqTable, eqTable )
|
||||
import Rel8.Table.Lifted
|
||||
@ -51,14 +55,16 @@ import Rel8.Table.Maybe
|
||||
( MaybeTable(..)
|
||||
, maybeTable, justTable, nothingTable
|
||||
, isJustTable
|
||||
, aggregateMaybeTable, nameMaybeTable
|
||||
)
|
||||
import Rel8.Table.Ord ( OrdTable, ordTable )
|
||||
import Rel8.Table.Recontextualize ( Recontextualize )
|
||||
import Rel8.Table.Tag ( Tag(..) )
|
||||
import Rel8.Table.Undefined ( undefined )
|
||||
import Rel8.Type.Tag ( MaybeTag )
|
||||
|
||||
-- semigroupoids
|
||||
import Data.Functor.Apply ( Apply, (<.>) )
|
||||
import Data.Functor.Apply ( Apply, (<.>), liftF2 )
|
||||
import Data.Functor.Bind ( Bind, (>>-) )
|
||||
|
||||
|
||||
@ -67,7 +73,7 @@ data TheseTable a b = TheseTable
|
||||
{ here :: MaybeTable a
|
||||
, there :: MaybeTable b
|
||||
}
|
||||
deriving stock (Show, Functor)
|
||||
deriving stock Functor
|
||||
|
||||
|
||||
instance Bifunctor TheseTable where
|
||||
@ -116,10 +122,12 @@ instance Table2 TheseTable where
|
||||
type ConstrainHContext2 TheseTable = HMaybeNullifiable
|
||||
|
||||
toColumns2 f g TheseTable {here, there} = HTheseTable
|
||||
{ hhereTag = HIdentity $ hencodeTag (tag here)
|
||||
, hhere = hnullify (hnullifier (isNonNull (tag here))) $ f (just here)
|
||||
, hthereTag = HIdentity $ hencodeTag (tag there)
|
||||
, hthere = hnullify (hnullifier (isNonNull (tag there))) $ g (just there)
|
||||
{ hhereTag = HIdentity $ hencodeTag (toHereTag (tag here))
|
||||
, hhere =
|
||||
hnullify (hnullifier (tag here) isNonNull) $ f (just here)
|
||||
, hthereTag = HIdentity $ hencodeTag (toThereTag (tag there))
|
||||
, hthere =
|
||||
hnullify (hnullifier (tag there) isNonNull) $ g (just there)
|
||||
}
|
||||
|
||||
fromColumns2 f g HTheseTable {hhereTag, hhere, hthereTag, hthere} =
|
||||
@ -132,7 +140,7 @@ instance Table2 TheseTable where
|
||||
{ tag
|
||||
, just = f $
|
||||
runIdentity $
|
||||
hunnullify (\a -> pure . hunnullifier (isNonNull tag) a)
|
||||
hunnullify (\a -> pure . hunnullifier a)
|
||||
hhere
|
||||
}
|
||||
, there =
|
||||
@ -143,7 +151,7 @@ instance Table2 TheseTable where
|
||||
{ tag
|
||||
, just = g $
|
||||
runIdentity $
|
||||
hunnullify (\a -> pure . hunnullifier (isNonNull tag) a)
|
||||
hunnullify (\a -> pure . hunnullifier a)
|
||||
hthere
|
||||
}
|
||||
}
|
||||
@ -192,6 +200,14 @@ instance (OrdTable a, OrdTable b) => OrdTable (TheseTable a b) where
|
||||
(thoseTable (ordTable @a) (ordTable @b))
|
||||
|
||||
|
||||
toHereTag :: Tag "isJust" a -> Tag "hasHere" a
|
||||
toHereTag Tag {..} = Tag {..}
|
||||
|
||||
|
||||
toThereTag :: Tag "isJust" a -> Tag "hasThere" a
|
||||
toThereTag Tag {..} = Tag {..}
|
||||
|
||||
|
||||
isThisTable :: TheseTable a b -> Expr Bool
|
||||
isThisTable a = hasHereTable a &&. not_ (hasThereTable a)
|
||||
|
||||
@ -239,3 +255,25 @@ theseTable f g h TheseTable {here, there} =
|
||||
(maybeTable undefined f here)
|
||||
(\b -> maybeTable (g b) (`h` b) here)
|
||||
there
|
||||
|
||||
|
||||
aggregateTheseTable :: ()
|
||||
=> (a -> Aggregate c)
|
||||
-> (b -> Aggregate d)
|
||||
-> TheseTable a b
|
||||
-> Aggregate (TheseTable c d)
|
||||
aggregateTheseTable f g TheseTable {here, there} =
|
||||
liftF2 TheseTable (aggregateMaybeTable f here) (aggregateMaybeTable g there)
|
||||
|
||||
|
||||
nameTheseTable :: ()
|
||||
=> Name (Maybe MaybeTag)
|
||||
-> Name (Maybe MaybeTag)
|
||||
-> a
|
||||
-> b
|
||||
-> TheseTable a b
|
||||
nameTheseTable here there a b =
|
||||
TheseTable
|
||||
{ here = nameMaybeTable here a
|
||||
, there = nameMaybeTable there b
|
||||
}
|
||||
|
@ -60,6 +60,13 @@ import qualified Data.Functor.Bind
|
||||
import Data.Semigroup.Traversable.Class ( bitraverse1 )
|
||||
|
||||
|
||||
-- | @'Tabulation' k a@ is denotionally a @MultiMap k a@ — a @Map@ where each
|
||||
-- key @k@ corresponds to potentially multiple @a@ (i.e., @'Query' a@). This
|
||||
-- @MultiMap@ supports 'lookup' and other operations you would expect it to.
|
||||
--
|
||||
-- \"Identity\" 'Tabulation's are created using 'tabulate'. 'Tabulation's can
|
||||
-- be composed with 'Query's with 'prebind' or 'postbind' to form new
|
||||
-- 'Tabulation's.
|
||||
newtype Tabulation k a = Tabulation (k -> Query (Maybe k, a))
|
||||
deriving stock Functor
|
||||
|
||||
@ -93,6 +100,16 @@ instance EqTable k => Monad (Tabulation k) where
|
||||
pure (mk', b)
|
||||
|
||||
|
||||
-- | This "undoes" 'fromQuery'.
|
||||
--
|
||||
-- @
|
||||
-- 'runTabulation' . 'fromQuery' = id
|
||||
-- 'fromQuery' . 'runTabulation' = id
|
||||
-- @
|
||||
--
|
||||
-- Note however that it produces nonsense when passed a 'Tabulation' that was
|
||||
-- made with from 'liftQuery' or 'pure'. In such cases the returned 'Query'
|
||||
-- will always produce zero rows.
|
||||
runTabulation :: EqTable k => Tabulation k a -> Query (k, a)
|
||||
runTabulation (Tabulation f) = do
|
||||
(mk, a) <- f i
|
||||
@ -111,14 +128,41 @@ liftQuery :: Query a -> Tabulation k a
|
||||
liftQuery query = Tabulation $ const $ fmap (Nothing,) query
|
||||
|
||||
|
||||
-- | 'tabulate' creates an \"identity\" @'Tabulation' k a@ that allows @a@ be
|
||||
-- indexed by one or more of its columns @k@. Some examples:
|
||||
--
|
||||
-- [Tabulation by primary key]:
|
||||
-- @
|
||||
-- projectsById :: Project 'Expr' -> 'Tabulation' ('Expr' ProjectId) (Project 'Expr')
|
||||
-- projectsById = 'tabulate' projectId
|
||||
-- @
|
||||
--
|
||||
-- Note: the nature of primary keys means that each key will be mapped to a
|
||||
-- singleton value in this case.
|
||||
--
|
||||
-- [Tabulation by other unique key]:
|
||||
-- @
|
||||
-- projectsByName :: Project 'Expr' -> 'Tabulation' ('Expr' Text) (Project 'Expr')
|
||||
-- projectsByName = 'tabulate' projectName
|
||||
-- @
|
||||
--
|
||||
-- [Tabulation by foreign key (tabulate a child table by parent key)]:
|
||||
-- @
|
||||
-- revisionsByProjectId :: Revision 'Expr' -> 'Tabulation' ('Expr' ProjectId) (Revision 'Expr')
|
||||
-- revisionsByProjectId = 'tabulate' revisionProjectId
|
||||
-- @
|
||||
tabulate :: (a -> k) -> a -> Tabulation k a
|
||||
tabulate key a = fromQuery $ pure (key a, a)
|
||||
|
||||
|
||||
-- | Like 'tabulate' but takes a monadic 'Query' function instead of a pure
|
||||
-- one. This means you can filter rows while calculating the key, which is
|
||||
-- useful in conjunction with 'Rel8.Extra.catNulls'.
|
||||
tabulateA :: (a -> Query k) -> a -> Tabulation k a
|
||||
tabulateA key a = fromQuery $ (,a) <$> key a
|
||||
|
||||
|
||||
-- | Analgous to 'Data.Map.Strict.fromList'.
|
||||
fromQuery :: Query (k, a) -> Tabulation k a
|
||||
fromQuery = Tabulation . const . fmap (first Just)
|
||||
|
||||
@ -133,6 +177,7 @@ ifilter f tabulation = snd <$> do
|
||||
filter (uncurry f) `postbind` indexed tabulation
|
||||
|
||||
|
||||
-- | Map a 'Query' over the input side of a 'Tabulation'.
|
||||
prebind :: (a -> Tabulation k b) -> Query a -> Tabulation k b
|
||||
prebind f as = Tabulation $ \k -> do
|
||||
a <- as
|
||||
@ -141,6 +186,7 @@ prebind f as = Tabulation $ \k -> do
|
||||
infixr 1 `prebind`
|
||||
|
||||
|
||||
-- | Map a 'Query' over the output side of a 'Tabulation'.
|
||||
postbind :: (a -> Query b) -> Tabulation k a -> Tabulation k b
|
||||
postbind f (Tabulation as) = Tabulation $ \i -> do
|
||||
(k, a) <- as i
|
||||
@ -151,6 +197,8 @@ postbind f (Tabulation as) = Tabulation $ \i -> do
|
||||
infixr 1 `postbind`
|
||||
|
||||
|
||||
-- | Note that because 'Tabulation' is a @MultiMap@, the 'Query' returned by
|
||||
-- 'lookup' can and often does contain multiple results.
|
||||
lookup :: EqTable k => k -> Tabulation k a -> Query a
|
||||
lookup key (Tabulation query) = do
|
||||
(mk, a) <- query key
|
||||
@ -158,11 +206,19 @@ lookup key (Tabulation query) = do
|
||||
pure a
|
||||
|
||||
|
||||
-- | Analagous to
|
||||
-- [@align@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:align).
|
||||
--
|
||||
-- If 'zip' makes an @INNER JOIN@, then 'align' makes a @FULL OUTER JOIN@.
|
||||
align :: (EqTable k, Table Expr a, Table Expr b)
|
||||
=> Tabulation k a -> Tabulation k b -> Tabulation k (TheseTable a b)
|
||||
align = alignWith id
|
||||
|
||||
|
||||
-- | Analagous to
|
||||
-- [@alignWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:alignWith).
|
||||
--
|
||||
-- See 'zipWith' and 'align'.
|
||||
alignWith :: (EqTable k, Table Expr a, Table Expr b)
|
||||
=> (TheseTable a b -> c)
|
||||
-> Tabulation k a -> Tabulation k b -> Tabulation k c
|
||||
@ -177,27 +233,73 @@ alignWith f kas kbs = do
|
||||
pure (k', f tab)
|
||||
|
||||
|
||||
-- | If 'zip' makes an @INNER JOIN@, then 'leftAlign' makes a @LEFT JOIN@.
|
||||
-- This means it will return at least one row for every row in the left
|
||||
-- 'Tabulation', even if there is no corresponding row in the right (hence the
|
||||
-- 'Rel8.MaybeTable').
|
||||
--
|
||||
-- Analagous to
|
||||
-- [@rpadZip@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:rpadZip).
|
||||
leftAlign :: EqTable k
|
||||
=> Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable b)
|
||||
leftAlign = leftAlignWith (,)
|
||||
|
||||
|
||||
-- | See 'zipWith' and 'leftAlign'.
|
||||
--
|
||||
-- Analagous to
|
||||
-- [@rpadZipWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:rpadZipWith).
|
||||
leftAlignWith :: EqTable k
|
||||
=> (a -> MaybeTable b -> c)
|
||||
-> Tabulation k a -> Tabulation k b -> Tabulation k c
|
||||
leftAlignWith f left right = liftA2 f left (optionalTabulation right)
|
||||
|
||||
|
||||
-- | Analagous to
|
||||
-- [@zip@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:zip).
|
||||
--
|
||||
-- There are multiple correct ways of understanding what this does.
|
||||
--
|
||||
-- You can think of it as @'Data.Map.Strict.intersectionWith'
|
||||
-- ('Control.Applicative.liftA2' (,))@. That is, @intersect@ the two
|
||||
-- `Tabulation`s by matching their keys together (with 'Rel8.==:'), and combine
|
||||
-- their values (remembering that 'Tabulation' is a 'MultiMap' so that the
|
||||
-- values are keys) by getting their cartesian product.
|
||||
--
|
||||
-- You can think of it as performing a cross product of the underlying 'Query's
|
||||
-- of the given 'Tabulation's and filtering the results for 'match'ing keys.
|
||||
--
|
||||
-- You can think of it as a natural join in SQL terms.
|
||||
--
|
||||
-- The size of the resulting 'Tabulation' will be \(\sum_{k} min(n_k, m_k) \)
|
||||
-- in terms of the number of keys, but \(\sum_{k} n_k \times m_k\) in terms of
|
||||
-- the number of values.
|
||||
zip :: EqTable k
|
||||
=> Tabulation k a -> Tabulation k b -> Tabulation k (a, b)
|
||||
zip = zipWith (,)
|
||||
|
||||
|
||||
-- | Analagous to
|
||||
-- [@zipWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:zipWith).
|
||||
--
|
||||
-- See 'zip'.
|
||||
zipWith :: EqTable k
|
||||
=> (a -> b -> c) -> Tabulation k a -> Tabulation k b -> Tabulation k c
|
||||
zipWith = liftA2
|
||||
|
||||
|
||||
-- | 'similarity' returns all the entries in the left 'Tabulation' that have a
|
||||
-- corresponding entry in the right 'Tabulation'. This corresponds to a
|
||||
-- semijoin in relational algebra.
|
||||
--
|
||||
-- This differs from @'zipWith' const x y@ when the right 'Tabulation' @y@
|
||||
-- contains an entry with multiple rows. For 'similarity', the entries in the
|
||||
-- resulting 'Tabulation' will contain the same number of rows as their
|
||||
-- respective entries in the left 'Tabulation' @x@. With `zipWith const x y`,
|
||||
-- each entry would contain the /product/ of the number of rows of their
|
||||
-- respective entries in @x@ and @y@.
|
||||
--
|
||||
-- See 'Rel8.with'.
|
||||
similarity :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
|
||||
similarity kas kbs = do
|
||||
as <- toQuery kas
|
||||
@ -205,6 +307,11 @@ similarity kas kbs = do
|
||||
fromQuery $ as >>= withBy (\(k, _) (l, _) -> k ==: l) bs
|
||||
|
||||
|
||||
-- | 'difference' returns all the entries in the left 'Tabulation' that don't
|
||||
-- exist in the right 'Tabulation'. This corresponds to an antijoin in
|
||||
-- relational algebra.
|
||||
--
|
||||
-- See 'Rel8.without'.
|
||||
difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
|
||||
difference kas kbs = do
|
||||
as <- toQuery kas
|
||||
|
@ -58,8 +58,12 @@ import qualified Data.Text.Lazy.Encoding as Lazy ( decodeUtf8 )
|
||||
|
||||
-- time
|
||||
import Data.Time.Calendar ( Day )
|
||||
import Data.Time.Clock ( DiffTime, NominalDiffTime, UTCTime )
|
||||
import Data.Time.LocalTime ( LocalTime, TimeOfDay )
|
||||
import Data.Time.Clock ( UTCTime )
|
||||
import Data.Time.LocalTime
|
||||
( CalendarDiffTime( CalendarDiffTime )
|
||||
, LocalTime
|
||||
, TimeOfDay
|
||||
)
|
||||
import Data.Time.Format ( formatTime, defaultTimeLocale )
|
||||
|
||||
-- uuid
|
||||
@ -75,18 +79,6 @@ import qualified Data.UUID as UUID
|
||||
-- should only need to derive instances of this class for custom database
|
||||
-- types, such as types defined in PostgreSQL extensions, or custom domain
|
||||
-- types.
|
||||
--
|
||||
-- [ Creating @DBType@s using @newtype@ ]
|
||||
--
|
||||
-- Generalized newtype deriving can be used when you want use a @newtype@
|
||||
-- around a database type for clarity and accuracy in your Haskell code. A
|
||||
-- common example is to @newtype@ row id types:
|
||||
--
|
||||
-- >>> newtype UserId = UserId { toInt32 :: Int32 } deriving newtype (DBType)
|
||||
--
|
||||
-- You can now write queries using @UserId@ instead of @Int32@, which may help
|
||||
-- avoid making bad joins. However, when SQL is generated, it will be as if you
|
||||
-- just used integers (the type distinction does not impact query generation).
|
||||
type DBType :: Type -> Constraint
|
||||
class NotNull a => DBType a where
|
||||
typeInformation :: TypeInformation a
|
||||
@ -98,7 +90,6 @@ instance DBType Bool where
|
||||
{ encode = Opaleye.ConstExpr . Opaleye.BoolLit
|
||||
, decode = Hasql.bool
|
||||
, typeName = "bool"
|
||||
, out = id
|
||||
}
|
||||
|
||||
|
||||
@ -108,7 +99,6 @@ instance DBType Char where
|
||||
{ encode = Opaleye.ConstExpr . Opaleye.StringLit . pure
|
||||
, decode = Hasql.char
|
||||
, typeName = "char"
|
||||
, out = id
|
||||
}
|
||||
|
||||
|
||||
@ -118,7 +108,6 @@ instance DBType Int16 where
|
||||
{ encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger
|
||||
, decode = Hasql.int2
|
||||
, typeName = "int2"
|
||||
, out = id
|
||||
}
|
||||
|
||||
|
||||
@ -128,7 +117,6 @@ instance DBType Int32 where
|
||||
{ encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger
|
||||
, decode = Hasql.int4
|
||||
, typeName = "int4"
|
||||
, out = id
|
||||
}
|
||||
|
||||
|
||||
@ -138,7 +126,6 @@ instance DBType Int64 where
|
||||
{ encode = Opaleye.ConstExpr . Opaleye.IntegerLit . toInteger
|
||||
, decode = Hasql.int8
|
||||
, typeName = "int8"
|
||||
, out = id
|
||||
}
|
||||
|
||||
|
||||
@ -148,7 +135,6 @@ instance DBType Float where
|
||||
{ encode = Opaleye.ConstExpr . Opaleye.NumericLit . realToFrac
|
||||
, decode = Hasql.float4
|
||||
, typeName = "float4"
|
||||
, out = id
|
||||
}
|
||||
|
||||
|
||||
@ -158,7 +144,6 @@ instance DBType Double where
|
||||
{ encode = Opaleye.ConstExpr . Opaleye.NumericLit . realToFrac
|
||||
, decode = Hasql.float8
|
||||
, typeName = "float8"
|
||||
, out = id
|
||||
}
|
||||
|
||||
|
||||
@ -168,7 +153,6 @@ instance DBType Scientific where
|
||||
{ encode = Opaleye.ConstExpr . Opaleye.NumericLit
|
||||
, decode = Hasql.numeric
|
||||
, typeName = "numeric"
|
||||
, out = id
|
||||
}
|
||||
|
||||
|
||||
@ -180,7 +164,6 @@ instance DBType UTCTime where
|
||||
formatTime defaultTimeLocale "'%FT%T%QZ'"
|
||||
, decode = Hasql.timestamptz
|
||||
, typeName = "timestamptz"
|
||||
, out = id
|
||||
}
|
||||
|
||||
|
||||
@ -192,7 +175,6 @@ instance DBType Day where
|
||||
formatTime defaultTimeLocale "'%F'"
|
||||
, decode = Hasql.date
|
||||
, typeName = "date"
|
||||
, out = id
|
||||
}
|
||||
|
||||
|
||||
@ -204,7 +186,6 @@ instance DBType LocalTime where
|
||||
formatTime defaultTimeLocale "'%FT%T%Q'"
|
||||
, decode = Hasql.timestamp
|
||||
, typeName = "timestamp"
|
||||
, out = id
|
||||
}
|
||||
|
||||
|
||||
@ -216,34 +197,26 @@ instance DBType TimeOfDay where
|
||||
formatTime defaultTimeLocale "'%T%Q'"
|
||||
, decode = Hasql.time
|
||||
, typeName = "time"
|
||||
, out = id
|
||||
}
|
||||
|
||||
|
||||
-- | Corresponds to @interval@
|
||||
instance DBType DiffTime where
|
||||
instance DBType CalendarDiffTime where
|
||||
typeInformation = TypeInformation
|
||||
{ encode =
|
||||
Opaleye.ConstExpr . Opaleye.OtherLit .
|
||||
formatTime defaultTimeLocale "'%0Es'"
|
||||
, decode = Hasql.interval
|
||||
formatTime defaultTimeLocale "'%bmon %0Es'"
|
||||
, decode = CalendarDiffTime 0 . realToFrac <$> Hasql.interval
|
||||
, typeName = "interval"
|
||||
, out = id
|
||||
}
|
||||
|
||||
|
||||
instance DBType NominalDiffTime where
|
||||
typeInformation =
|
||||
mapTypeInformation @DiffTime realToFrac realToFrac typeInformation
|
||||
|
||||
|
||||
-- | Corresponds to @text@
|
||||
instance DBType Text where
|
||||
typeInformation = TypeInformation
|
||||
{ encode = Opaleye.ConstExpr . Opaleye.StringLit . Text.unpack
|
||||
, decode = Hasql.text
|
||||
, typeName = "text"
|
||||
, out = id
|
||||
}
|
||||
|
||||
|
||||
@ -273,7 +246,6 @@ instance DBType ByteString where
|
||||
{ encode = Opaleye.ConstExpr . Opaleye.ByteStringLit
|
||||
, decode = Hasql.bytea
|
||||
, typeName = "bytea"
|
||||
, out = id
|
||||
}
|
||||
|
||||
|
||||
@ -290,7 +262,6 @@ instance DBType UUID where
|
||||
{ encode = Opaleye.ConstExpr . Opaleye.StringLit . UUID.toString
|
||||
, decode = Hasql.uuid
|
||||
, typeName = "uuid"
|
||||
, out = id
|
||||
}
|
||||
|
||||
|
||||
@ -303,7 +274,6 @@ instance DBType Value where
|
||||
Lazy.unpack . Lazy.decodeUtf8 . Aeson.encode
|
||||
, decode = Hasql.jsonb
|
||||
, typeName = "jsonb"
|
||||
, out = id
|
||||
}
|
||||
|
||||
|
||||
|
@ -40,15 +40,14 @@ listTypeInformation :: ()
|
||||
-> TypeInformation [a]
|
||||
listTypeInformation nullability info =
|
||||
case info of
|
||||
TypeInformation{ encode, decode, out } -> TypeInformation
|
||||
TypeInformation{ encode, decode } -> TypeInformation
|
||||
{ decode = row $ case nullability of
|
||||
Nullable -> Hasql.listArray (Hasql.nullable (out <$> decode))
|
||||
NonNullable -> Hasql.listArray (Hasql.nonNullable (out <$> decode))
|
||||
Nullable -> Hasql.listArray (Hasql.nullable decode)
|
||||
NonNullable -> Hasql.listArray (Hasql.nonNullable decode)
|
||||
, encode = case nullability of
|
||||
Nullable -> array info . fmap (maybe null encode)
|
||||
NonNullable -> array info . fmap encode
|
||||
, typeName = "record"
|
||||
, out = id
|
||||
}
|
||||
where
|
||||
row = Hasql.composite . Hasql.field . Hasql.nonNullable
|
||||
|
@ -66,6 +66,7 @@ import Data.Semialign ( Semialign )
|
||||
import Data.Zip ( Repeat, Unzip, Zip )
|
||||
|
||||
|
||||
-- | A one dimensional array.
|
||||
newtype Array1D a = Array1D [a]
|
||||
deriving stock Traversable
|
||||
deriving newtype
|
||||
@ -98,15 +99,14 @@ array1DTypeInformation :: IsArray1D (Unnullify a) ~ 'False
|
||||
-> TypeInformation (Array1D a)
|
||||
array1DTypeInformation nullability info =
|
||||
case info of
|
||||
TypeInformation{ encode, decode, typeName, out } -> TypeInformation
|
||||
TypeInformation{ encode, decode, typeName } -> TypeInformation
|
||||
{ decode = case nullability of
|
||||
Nullable -> Array1D <$> Hasql.listArray (Hasql.nullable (out <$> decode))
|
||||
NonNullable -> Array1D <$> Hasql.listArray (Hasql.nonNullable (out <$> decode))
|
||||
Nullable -> Array1D <$> Hasql.listArray (Hasql.nullable decode)
|
||||
NonNullable -> Array1D <$> Hasql.listArray (Hasql.nonNullable decode)
|
||||
, encode = case nullability of
|
||||
Nullable -> Opaleye.ArrayExpr . fmap (maybe null encode) . getArray1D
|
||||
NonNullable -> Opaleye.ArrayExpr . fmap encode . getArray1D
|
||||
, typeName = typeName <> "[]"
|
||||
, out = id
|
||||
}
|
||||
where
|
||||
null = Opaleye.ConstExpr Opaleye.NullLit
|
||||
|
@ -39,8 +39,8 @@ import qualified Data.Text.Lazy as Lazy ( Text )
|
||||
|
||||
-- time
|
||||
import Data.Time.Calendar ( Day )
|
||||
import Data.Time.Clock ( UTCTime, DiffTime, NominalDiffTime )
|
||||
import Data.Time.LocalTime ( TimeOfDay, LocalTime )
|
||||
import Data.Time.Clock ( UTCTime )
|
||||
import Data.Time.LocalTime ( CalendarDiffTime, LocalTime, TimeOfDay )
|
||||
|
||||
-- uuid
|
||||
import Data.UUID ( UUID )
|
||||
@ -49,36 +49,6 @@ 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.
|
||||
--
|
||||
-- [ @DBEq@ with @newtype@s ]
|
||||
--
|
||||
-- Like with 'Rel8.DBType', @DBEq@ plays well with generalized newtype
|
||||
-- deriving. The example given for @DBType@ added a @UserId@ @newtype@, but
|
||||
-- without a @DBEq@ instance won't actually be able to use that in joins or
|
||||
-- where-clauses, because it lacks equality. We can add this by changing our
|
||||
-- @newtype@ definition to:
|
||||
--
|
||||
-- >>> newtype UserId = UserId { toInt32 :: Int32 } deriving newtype (DBType, DBEq)
|
||||
--
|
||||
-- This will re-use the equality logic for @Int32@, which is to just use the
|
||||
-- @=@ operator.
|
||||
--
|
||||
-- [ @DBEq@ with @DeriveAnyType@ ]
|
||||
--
|
||||
-- You can also use @DBEq@ with the @DeriveAnyType@ extension to easily add
|
||||
-- equality to your type, assuming that @=@ is sufficient on @DBType@ encoded
|
||||
-- values. Extending the example from 'Rel8.ReadShow''s 'Rel8.DBType' instance,
|
||||
-- we could add equality to @Color@ by writing:
|
||||
--
|
||||
-- >>> :{
|
||||
-- data Color = Red | Green | Blue | Purple | Gold
|
||||
-- deriving (Generic, Show, Read, DBEq)
|
||||
-- deriving DBType via ReadShow Color
|
||||
-- :}
|
||||
--
|
||||
-- This means @Color@s will be treated as the literal strings @"Red"@,
|
||||
-- @"Green"@, etc, in the database, and they can be compared for equality by
|
||||
-- just using @=@.
|
||||
type DBEq :: Type -> Constraint
|
||||
class DBType a => DBEq a
|
||||
|
||||
@ -95,8 +65,7 @@ instance DBEq UTCTime
|
||||
instance DBEq Day
|
||||
instance DBEq LocalTime
|
||||
instance DBEq TimeOfDay
|
||||
instance DBEq DiffTime
|
||||
instance DBEq NominalDiffTime
|
||||
instance DBEq CalendarDiffTime
|
||||
instance DBEq Text
|
||||
instance DBEq Lazy.Text
|
||||
instance DBEq (CI Text)
|
||||
|
@ -28,23 +28,19 @@ import qualified Data.Text as Text
|
||||
-- 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 where
|
||||
TypeInformation ::
|
||||
{ encode :: a -> Opaleye.PrimExpr
|
||||
-- ^ How to encode a single Haskell value as a SQL expression.
|
||||
, decode :: Hasql.Value x
|
||||
-- ^ How to deserialize a single result back to Haskell.
|
||||
, typeName :: String
|
||||
-- ^ The name of the SQL type.
|
||||
, out :: x -> a
|
||||
-- ^ A final output function - usually this will just be 'id'. This is
|
||||
-- needed to allow @TypeInformation@s to be coerced.
|
||||
} -> TypeInformation a
|
||||
data TypeInformation a = TypeInformation
|
||||
{ encode :: a -> Opaleye.PrimExpr
|
||||
-- ^ How to encode a single Haskell value as a SQL expression.
|
||||
, decode :: Hasql.Value a
|
||||
-- ^ How to deserialize a single result back to Haskell.
|
||||
, typeName :: String
|
||||
-- ^ 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 'DBType'.
|
||||
-- essentially @newtype@ another 'Rel8.DBType'.
|
||||
--
|
||||
-- The mapping is required to be total. If you have a partial mapping, see
|
||||
-- 'parseTypeInformation'.
|
||||
@ -60,31 +56,12 @@ mapTypeInformation = parseTypeInformation . fmap pure
|
||||
-- a given 'TypeInformation'. The parser is applied when deserializing rows
|
||||
-- returned - the encoder assumes that the input data is already in the
|
||||
-- appropriate form.
|
||||
--
|
||||
-- One example where this may be useful is with a database that stores data in
|
||||
-- some legacy encoding:
|
||||
--
|
||||
-- >>> import Data.Text (Text)
|
||||
--
|
||||
-- >>> data Color = Red | Green | Blue
|
||||
-- >>> :{
|
||||
-- instance DBType Color where
|
||||
-- typeInformation = parseTypeInformation parseLegacy toLegacy typeInformation
|
||||
-- where
|
||||
-- parseLegacy :: Text -> Either String Color
|
||||
-- parseLegacy "red" = Right Red
|
||||
-- parseLegacy "green" = Right Green
|
||||
-- parseLegacy _ = Left "Unexpected Color"
|
||||
-- toLegacy Red = "red"
|
||||
-- toLegacy Green = "green"
|
||||
-- :}
|
||||
parseTypeInformation :: ()
|
||||
=> (a -> Either String b) -> (b -> a)
|
||||
-> TypeInformation a -> TypeInformation b
|
||||
parseTypeInformation to from TypeInformation {encode, decode, typeName, out} =
|
||||
parseTypeInformation to from TypeInformation {encode, decode, typeName} =
|
||||
TypeInformation
|
||||
{ encode = encode . from
|
||||
, decode = Hasql.refine (first Text.pack . to) (out <$> decode)
|
||||
, decode = Hasql.refine (first Text.pack . to) decode
|
||||
, typeName
|
||||
, out = id
|
||||
}
|
||||
|
@ -19,7 +19,7 @@ import Rel8.Type.Information ( TypeInformation(..) )
|
||||
import Data.Text ( pack )
|
||||
|
||||
|
||||
-- | Like 'JSONEncoded', but works for @jsonb@ columns.
|
||||
-- | Like 'Rel8.JSONEncoded', but works for @jsonb@ columns.
|
||||
newtype JSONBEncoded a = JSONBEncoded { fromJSONBEncoded :: a }
|
||||
|
||||
|
||||
@ -28,5 +28,4 @@ instance (FromJSON a, ToJSON a) => DBType (JSONBEncoded a) where
|
||||
{ encode = encode typeInformation . toJSON . fromJSONBEncoded
|
||||
, decode = Hasql.refine (first pack . fmap JSONBEncoded . parseEither parseJSON) Hasql.jsonb
|
||||
, typeName = "jsonb"
|
||||
, out = id
|
||||
}
|
||||
|
@ -15,19 +15,6 @@ 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.
|
||||
--
|
||||
-- The declaration:
|
||||
--
|
||||
-- >>> import Data.Aeson
|
||||
--
|
||||
-- >>> :{
|
||||
-- data Pet = Pet { petName :: String, petAge :: Int }
|
||||
-- deriving (Generic, ToJSON, FromJSON)
|
||||
-- deriving PrimitiveType via JSONEncoded Pet
|
||||
-- :}
|
||||
--
|
||||
-- will allow you to store @Pet@ values in a single SQL column (stored as
|
||||
-- @json@ values).
|
||||
newtype JSONEncoded a = JSONEncoded { fromJSONEncoded :: a }
|
||||
|
||||
|
||||
|
@ -39,11 +39,11 @@ import Data.Text ( Text )
|
||||
import qualified Data.Text.Lazy as Lazy ( Text )
|
||||
|
||||
-- time
|
||||
import Data.Time.Clock ( DiffTime, NominalDiffTime )
|
||||
import Data.Time.LocalTime ( CalendarDiffTime( CalendarDiffTime ) )
|
||||
|
||||
|
||||
-- | The class of '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 '<>.'
|
||||
@ -54,12 +54,8 @@ instance Sql DBType a => DBMonoid [a] where
|
||||
memptyExpr = sempty nullabilization typeInformation
|
||||
|
||||
|
||||
instance DBMonoid DiffTime where
|
||||
memptyExpr = litExpr 0
|
||||
|
||||
|
||||
instance DBMonoid NominalDiffTime where
|
||||
memptyExpr = litExpr 0
|
||||
instance DBMonoid CalendarDiffTime where
|
||||
memptyExpr = litExpr (CalendarDiffTime 0 0)
|
||||
|
||||
|
||||
instance DBMonoid Text where
|
||||
|
@ -40,6 +40,9 @@ instance {-# INCOHERENT #-} (HasNullability a, DBNum (Unnullify a)) =>
|
||||
Sql DBNum a
|
||||
|
||||
|
||||
-- | 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 => DBIntegral a
|
||||
instance DBIntegral Int16
|
||||
|
@ -37,8 +37,8 @@ import qualified Data.Text.Lazy as Lazy ( Text )
|
||||
|
||||
-- time
|
||||
import Data.Time.Calendar ( Day )
|
||||
import Data.Time.Clock ( DiffTime, NominalDiffTime, UTCTime )
|
||||
import Data.Time.LocalTime ( TimeOfDay, LocalTime )
|
||||
import Data.Time.Clock ( UTCTime )
|
||||
import Data.Time.LocalTime ( CalendarDiffTime, LocalTime, TimeOfDay )
|
||||
|
||||
-- uuid
|
||||
import Data.UUID ( UUID )
|
||||
@ -60,8 +60,7 @@ instance DBOrd UTCTime
|
||||
instance DBOrd Day
|
||||
instance DBOrd LocalTime
|
||||
instance DBOrd TimeOfDay
|
||||
instance DBOrd DiffTime
|
||||
instance DBOrd NominalDiffTime
|
||||
instance DBOrd CalendarDiffTime
|
||||
instance DBOrd Text
|
||||
instance DBOrd Lazy.Text
|
||||
instance DBOrd (CI Text)
|
||||
@ -93,8 +92,7 @@ instance DBMax UTCTime
|
||||
instance DBMax Day
|
||||
instance DBMax LocalTime
|
||||
instance DBMax TimeOfDay
|
||||
instance DBMax DiffTime
|
||||
instance DBMax NominalDiffTime
|
||||
instance DBMax CalendarDiffTime
|
||||
instance DBMax Text
|
||||
instance DBMax Lazy.Text
|
||||
instance DBMax (CI Text)
|
||||
@ -124,8 +122,7 @@ instance DBMin UTCTime
|
||||
instance DBMin Day
|
||||
instance DBMin LocalTime
|
||||
instance DBMin TimeOfDay
|
||||
instance DBMin DiffTime
|
||||
instance DBMin NominalDiffTime
|
||||
instance DBMin CalendarDiffTime
|
||||
instance DBMin Text
|
||||
instance DBMin Lazy.Text
|
||||
instance DBMin (CI Text)
|
||||
|
@ -14,17 +14,6 @@ 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.
|
||||
--
|
||||
-- The declaration:
|
||||
--
|
||||
-- >>> :{
|
||||
-- data Color = Red | Green | Blue
|
||||
-- deriving (Read, Show)
|
||||
-- deriving PrimitiveType via ReadShow Color
|
||||
-- :}
|
||||
--
|
||||
-- will allow you to store @Color@ values in a single SQL column (stored as
|
||||
-- @text@).
|
||||
newtype ReadShow a = ReadShow { fromReadShow :: a }
|
||||
|
||||
|
||||
|
@ -39,11 +39,11 @@ import Data.Text ( Text )
|
||||
import qualified Data.Text.Lazy as Lazy ( Text )
|
||||
|
||||
-- time
|
||||
import Data.Time.Clock ( DiffTime, NominalDiffTime )
|
||||
import Data.Time.LocalTime ( CalendarDiffTime )
|
||||
|
||||
|
||||
-- | The class of '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.
|
||||
@ -59,11 +59,7 @@ instance Sql DBType a => DBSemigroup (NonEmpty a) where
|
||||
(<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
|
||||
|
||||
|
||||
instance DBSemigroup DiffTime where
|
||||
(<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:+))
|
||||
|
||||
|
||||
instance DBSemigroup NominalDiffTime where
|
||||
instance DBSemigroup CalendarDiffTime where
|
||||
(<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:+))
|
||||
|
||||
|
||||
|
@ -24,7 +24,7 @@ import Rel8.Type ( DBType )
|
||||
import Data.Scientific ( Scientific )
|
||||
|
||||
-- time
|
||||
import Data.Time.Clock ( DiffTime, NominalDiffTime )
|
||||
import Data.Time.LocalTime ( CalendarDiffTime )
|
||||
|
||||
|
||||
-- | The class of database types that support the @sum()@ aggregation function.
|
||||
@ -36,8 +36,7 @@ instance DBSum Int64
|
||||
instance DBSum Float
|
||||
instance DBSum Double
|
||||
instance DBSum Scientific
|
||||
instance DBSum DiffTime
|
||||
instance DBSum NominalDiffTime
|
||||
instance DBSum CalendarDiffTime
|
||||
|
||||
|
||||
instance {-# INCOHERENT #-} (HasNullability a, DBSum (Unnullify a)) =>
|
||||
|
Loading…
Reference in New Issue
Block a user