Support OverloadedRecordDot (#310)

* Support OverloadedRecordDot

* stylish

* Haddocks

* Add comments to README

.editorconfig

@@ -11,8 +11,8 @@ insert_final_newline = true
 
 [*.{hs,md,php}]
 indent_style = space
-indent_size = 2
+indent_size = 4
-tab_width = 2
+tab_width = 4
 end_of_line = lf
 charset = utf-8
 trim_trailing_whitespace = true

.github/PULL_REQUEST_TEMPLATE.md

@@ -0,0 +1,19 @@
+Before submitting your PR, check that you've:
+
+- [ ] Bumped the version number.
+- [ ] Documented new APIs with [Haddock markup](https://www.haskell.org/haddock/doc/html/index.html).
+- [ ] Added [`@since` declarations](http://haskell-haddock.readthedocs.io/en/latest/markup.html#since) to the Haddock.
+- [ ] Ran `stylish-haskell` and otherwise adhered to the [style guide](https://github.com/bitemyapp/esqueleto/blob/master/style-guide.yaml).
+
+After submitting your PR:
+
+- [ ] Update the Changelog.md file with a link to your PR.
+- [ ] Check that CI passes (or if it fails, for reasons unrelated to your change, like CI timeouts).
+
+<!---Thanks so much for contributing! :)
+
+_If these checkboxes don't apply to your PR, you can delete them_
+
+If you're unsure on what the new version number should be, feel free to ask.
+
+-->

.github/workflows/haskell.yml

@@ -0,0 +1,76 @@
+name: CI
+on:
+  push:
+    branches:
+      - master
+  pull_request:
+    types:
+      - opened
+      - synchronize
+jobs:
+  build:
+    runs-on: ubuntu-latest
+    services:
+      # mysql-service Label used to access the service container
+      mysql-service:
+        # Docker Hub image (also with version)
+        image: mysql:8.0
+        env:
+          ## Accessing to Github secrets, where you can store your configuration
+          MYSQL_USER: travis
+          MYSQL_PASSWORD: esqutest
+          MYSQL_ROOT_PASSWORD: esqutest
+          MYSQL_DATABASE: esqutest
+        ## map the "external" 33306 port with the "internal" 3306
+        ports:
+          - 33306:3306
+        # Set health checks to wait until mysql database has started (it takes some seconds to start)
+        options: >-
+          --health-cmd="mysqladmin ping"
+          --health-interval=10s
+          --health-timeout=5s
+          --health-retries=3
+    strategy:
+      matrix:
+        cabal: ["3.6"]
+        ghc: ["8.6.5", "8.8.4", "8.10.4", "9.0.2", "9.2.2"]
+    env:
+      CONFIG: "--enable-tests --enable-benchmarks "
+    steps:
+      - uses: actions/checkout@v2
+      - uses: haskell/actions/setup@v1
+        id: setup-haskell-cabal
+        with:
+          ghc-version: ${{ matrix.ghc }}
+          cabal-version: ${{ matrix.cabal }}
+      - uses: harmon758/postgresql-action@v1
+        with:
+           postgresql version: '12'  # See https://hub.docker.com/_/postgres for available versions  
+           postgresql user: esqutest
+           postgresql password: esqutest
+           postgresql db: esqutest
+      - name: Create MySQL
+        run: mysql -utravis -pesqutest -h127.0.0.1 --port=33306 esqutest -e "SELECT 1;"
+            # - name: Shutdown Ubuntu MySQL (SUDO)
+            #   run: sudo service mysql stop
+            # - uses: mirromutth/mysql-action@v1.1
+            #   with:
+            #     mysql version: '8.0' # Optional, default value is "latest". The version of the MySQL
+            #     mysql database: 'esqutest' # Optional, default value is "test". The specified database which will be create
+            #     mysql user: 'travis' # Required if "mysql root password" is empty, default is empty. The superuser for the specified database. Can use secrets, too
+            #     mysql password: 'esqutest' # Required if "mysql user" exists. The password for the "mysql user"
+      - run: cabal v2-update
+      - run: cabal v2-freeze $CONFIG
+      - uses: actions/cache@v2
+        with:
+          path: |
+            ${{ steps.setup-haskell-cabal.outputs.cabal-store }}
+            dist-newstyle
+          key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }}
+          restore-keys: |
+            ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }}
+            ${{ runner.os }}-${{ matrix.ghc }}-
+      - run: cabal v2-build --disable-optimization -j $CONFIG
+      - run: cabal v2-test --disable-optimization -j $CONFIG --test-options "--fail-on-focus"
+      - run: cabal v2-haddock -j $CONFIG
+      - run: cabal v2-sdist

.gitignore

@@ -1,5 +1,10 @@
 .stack-work
+stack.yaml.lock
+*.yaml.lock
 /dist*
 *~
 .cabal-sandbox/
 cabal.sandbox.config
+.hspec-failures
+*.sqlite*
+cabal.project.freeze

.stylish-haskell.yaml

@@ -0,0 +1,39 @@
+steps:
+  - imports:
+      align: none
+      list_align: with_module_name
+      pad_module_names: false
+      long_list_align: new_line_multiline
+      empty_list_align: inherit
+      list_padding: 7 # length "import "
+      separate_lists: false
+      space_surround: false
+  - language_pragmas:
+      style: vertical
+      align: false
+      remove_redundant: true
+  - simple_align:
+      cases: false
+      top_level_patterns: false
+      records: false
+  - trailing_whitespace: {}
+indent: 4
+columns: 80
+newline: native
+language_extensions:
+  - BlockArguments
+  - DataKinds
+  - DeriveGeneric
+  - DerivingStrategies
+  - DerivingVia
+  - ExplicitForAll
+  - FlexibleContexts
+  - MultiParamTypeClasses
+  - NamedFieldPuns
+  - OverloadedStrings
+  - QuantifiedConstraints
+  - RecordWildCards
+  - ScopedTypeVariables
+  - TemplateHaskell
+  - TypeApplications
+  - ViewPatterns

.travis.yml

@@ -1,21 +1,31 @@
 language: c
 
-sudo: false
-
 services:
-  - postgresql
   - mysql
 
 addons:
+  postgresql: "10"
   apt:
     packages:
       - libgmp-dev
-      - postgresql-client
+      - postgresql-10
+      - postgresql-client-10
       - postgresql-server-dev-all
 
 env:
- - GHCVER=7.10
+  global:
- - GHCVER=8.0
+    - PGPORT=5432
+  matrix:
+    - GHCVER=8.2
+    - GHCVER=8.4
+    - GHCVER=8.6
+    - GHCVER=8.8
+    - GHCVER=nightly
+
+jobs:
+  fast_finish: true
+  allow_failures:
+    - env: GHCVER=nightly
 
 install:
   - export STACK_YAML=stack-$GHCVER.yaml
@@ -23,15 +33,16 @@ install:
   - export PATH=$HOME/.local/bin:$PATH
   - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
   - stack --version
-  - createuser -s --no-password test
+  - psql -c "CREATE USER esqutest WITH PASSWORD 'esqutest';" -U postgres
-  - createdb -O test test
+  - createdb -O esqutest esqutest
+  - mysql -e 'CREATE DATABASE esqutest;'
+  - stack setup
 
 script:
-  - stack setup
+  - stack build --fast $(if [[ $GHCVER == "nightly" ]]; then echo "--resolver nightly"; fi)
-  - stack update
+  - stack test --fast $(if [[ $GHCVER == "nightly" ]]; then echo "--resolver nightly"; fi)
-  - stack build
+  - cd test/expected-compile-failures/
-  - stack test --flag esqueleto:postgresql
+  - bash test.sh
-  - stack test --flag esqueleto:-mysql
 
 cache:
   directories:

Makefile

@@ -1,10 +1,8 @@
-build: build-7.10
+build:
+	stack build
 
-build-7.10:
+build-tests:
-	STACK_YAML="stack-7.10.yaml" stack build
+	stack build --test --no-run-tests
-
-build-8.0:
-	STACK_YAML="stack-8.0.yaml" stack build
 
 ghci:
 	stack ghci
@@ -12,5 +10,38 @@ ghci:
 test:
 	stack test
 
+# Intended for use in local dev
+test-postgresql: reset-pgsql
+	stack test esqueleto:postgresql
+
+test-mysql:
+	stack test esqueleto:mysql
+
 test-ghci:
-	stack ghci esqueleto:test:test
+	stack ghci esqueleto:test:sqlite
+
+test-ghcid:
+	ghcid -c "stack ghci --ghci-options -fobject-code esqueleto --test" \
+		--warnings \
+		--restart "stack.yaml" \
+		--restart "esqueleto.cabal" \
+		--test main
+
+test-ghcid-build:
+	ghcid -c "stack ghci --ghci-options -fobject-code esqueleto --test" \
+		--warnings \
+		--restart "stack.yaml" \
+		--restart "esqueleto.cabal"
+
+
+
+init-pgsql:
+	sudo -u postgres -- createuser -s esqutest
+
+reset-pgsql:
+	-sudo -u postgres dropdb esqutest
+	-sudo -u postgres dropuser esqutest
+	echo "CREATE USER esqutest WITH PASSWORD 'esqutest';" | sudo -u postgres psql
+	sudo -u postgres createdb -O esqutest esqutest
+
+.PHONY: build build-7.10 build-8.0 ghci test test-ghci

README.md

@@ -1,4 +1,4 @@
-Esqueleto [![TravisCI](https://travis-ci.org/bitemyapp/esqueleto.svg)](https://travis-ci.org/bitemyapp/esqueleto)
+Esqueleto [![CI](https://github.com/bitemyapp/esqueleto/actions/workflows/haskell.yml/badge.svg?branch=master)](https://github.com/bitemyapp/esqueleto/actions/workflows/haskell.yml)
 ==========
 
 ![Skeleton](./esqueleto.png)
@@ -127,9 +127,106 @@ FROM Person
 WHERE Person.age >= 18
 ```
 
-Since `age` is an optional `Person` field, we use `just` to lift`val 18 :: SqlExpr (Value Int)` into `just (val 18) ::SqlExpr (Value (Maybe Int))`.
+Since `age` is an optional `Person` field, we use `just` to lift `val 18 :: SqlExpr (Value Int)` into `just (val 18) ::SqlExpr (Value (Maybe Int))`.
 
-## Joins
+### Alternative Field Projections
+
+The `(^.)` operator works on an `EntityField` value, which are generated by
+`persistent` as the table name + the field name. This can get a little bit
+verbose. As of `persistent-2.11`, you can use `OverloadedLabels` to make this a
+bit more concise:
+
+```haskell
+{-# LANGUAGE OverloadedLabels #-}
+
+select $ do
+    p <- from $ table @Person
+    pure
+        ( p ^. PersonName
+        , p ^. #name
+        )
+```
+
+The `OverloadedLabels` support uses the `fieldName` as given by the Persistent
+entity definition syntax - no type name prefix necessary. Additionally, these
+field accesses are *polymorphic* - the following query filters any table that
+has a `name` column:
+
+```haskell
+rowsByName
+    :: forall rec.
+    ( PersistEntity rec
+    , PersistEntityBackend rec ~ SqlBackend
+    , SymbolToField "name" rec Text
+    )
+    => SqlExpr (Value Text)
+    -> SqlQuery (SqlExpr (Entity rec))
+rowsByName name = do
+    rec <- from $ table @rec
+    where_ $ rec ^. #name ==. name
+    pure rec
+```
+
+GHC 9.2 introduces the `OverloadedRecordDot` language extension, and `esqueleto`
+supports this on `SqlExpr (Entity rec)` and `SqlExpr (Maybe (Entity rec))`. It
+looks like this:
+
+```haskell
+select $ do
+    (person, blogPost) <-
+        from $
+            table @Person
+            `leftJoin` table @BlogPost
+            `on` do
+                \(person :& blogPost) ->
+                    just person.id ==. blogPost.authorId
+    pure (person.name, blogPost.title)
+```
+
+## Experimental/New Joins
+
+There's a new way to write `JOIN`s in esqueleto! It has less potential for
+runtime errors and is much more powerful than the old syntax. To opt in to the
+new syntax, import:
+
+```haskell
+import Database.Esqueleto.Experimental
+```
+
+This will conflict with the definition of `from` and `on` in the
+`Database.Esqueleto` module, so you'll want to remove that import.
+
+This style will become the new "default" in esqueleto-4.0.0.0, so it's a good
+idea to port your code to using it soon.
+
+The module documentation in `Database.Esqueleto.Experimental` has many examples,
+and they won't be repeated here. Here's a quick sample:
+
+```haskell
+select $ do
+  (a :& b) <-
+    from $
+      Table @BlogPost
+      `InnerJoin`
+      Table @Person
+        `on` do \(bp :& a) ->
+          bp ^. BlogPostAuthorId ==. a ^. PersonId
+  pure (a, b)
+```
+
+Advantages:
+
+- `ON` clause is attached directly to the relevant join, so you never need to
+  worry about how they're ordered, nor will you ever run into bugs where the
+  `on` clause is on the wrong `JOIN`
+- The `ON` clause lambda will all the available tables in it. This forbids
+  runtime errors where an `ON` clause refers to a table that isn't in scope yet.
+- You can join on a table twice, and the aliases work out fine with the `ON`
+  clause.
+- You can use `UNION`, `EXCEPT`, `INTERSECTION` etc  with this new syntax!
+- You can reuse subqueries more easily.
+
+## Legacy Joins
 
 Implicit joins are represented by tuples.
 
@@ -157,7 +254,7 @@ However, you may want your results to include people who don't have any blog pos
 
 ```haskell
 select $
-from $ \(p `LeftOuterJoin`` mb) -> do
+from $ \(p `LeftOuterJoin` mb) -> do
 on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId)
 orderBy [asc (p ^. PersonName), asc (mb ?. BlogPostTitle)]
 return (p, mb)
@@ -192,11 +289,9 @@ which generates this SQL:
 SELECT P1.*, Follow.*, P2.*
 FROM Person AS P1
 INNER JOIN Follow ON P1.id = Follow.follower
-INNER JOIN P2 ON P2.id = Follow.followed
+INNER JOIN Person AS P2 ON P2.id = Follow.followed
 ```
 
-Note carefully that the order of the ON clauses is reversed! You're required to write your `on`s in reverse order because that helps composability (see the documentation of `on` for more details). 
-
 ## Update and Delete
 
 ```haskell
@@ -238,5 +333,214 @@ We re-export many symbols from `persistent` for convenience:
 There are many differences between SQL syntax and functions supported by different RDBMSs.  Since version 2.2.8, `esqueleto` includes modules containing functions that are specific to a given RDBMS.
 
 - PostgreSQL: `Database.Esqueleto.PostgreSQL`
+- MySQL: `Database.Esqueleto.MySQL`
+- SQLite: `Database.Esqueleto.SQLite`
 
 In order to use these functions, you need to explicitly import their corresponding modules.
+
+### Unsafe functions, operators and values
+
+Esqueleto doesn't support every possible function, and it can't - many functions aren't available on every RDBMS platform, and sometimes the same functionality is hidden behind different names. To overcome this problem, Esqueleto exports a number of unsafe functions to call any function, operator or value. These functions can be found in Database.Esqueleto.Internal.Sql module.
+
+Warning: the functions discussed in this section must always be used with an explicit type signature,and the user must be careful to provide a type signature that corresponds correctly with the underlying code. The functions have extremely general types, and if you allow type inference to figure everything out for you, it may not correspond with the underlying SQL types that you want. This interface is effectively the FFI to SQL database, so take care!
+
+The most common use of these functions is for calling RDBMS specific or custom functions,
+for that end we use `unsafeSqlFunction`. For example, if we wish to consult the postgres
+`now` function we could so as follow:
+
+```haskell
+postgresTime :: (MonadIO m, MonadLogger m) => SqlWriteT m UTCTime
+postgresTime =
+  result <- select (pure now)
+  case result of
+    [x] -> pure x
+    _ -> error "now() is guaranteed to return a single result"
+  where
+    now :: SqlExpr (Value UTCTime)
+    now = unsafeSqlFunction "now" ()
+```
+
+which generates this SQL:
+
+```sql
+SELECT now()
+```
+
+With the `now` function we could now use the current time of the postgres RDBMS on any query.
+Do notice that `now` does not use any arguments, so we use `()` that is an instance of
+`UnsafeSqlFunctionArgument` to represent no arguments, an empty list cast to a correct value
+will yield the same result as `()`.
+
+We can also use `unsafeSqlFunction` for more complex functions with customs values using
+`unsafeSqlValue` which turns any string into a sql value of whatever type we want, disclaimer:
+if you use it badly you will cause a runtime error. For example, say we want to try postgres'
+`date_part` function and get the day of a timestamp, we could use:
+
+```haskell
+postgresTimestampDay :: (MonadIO m, MonadLogger m) => SqlWriteT m Int
+postgresTimestampDay =
+  result <- select (return $ dayPart date)
+  case result of
+    [x] -> pure x
+    _ -> error "dayPart is guaranteed to return a single result"
+  where
+    dayPart :: SqlExpr (Value UTCTime) -> SqlExpr (Value Int)
+    dayPart s = unsafeSqlFunction "date_part" (unsafeSqlValue "\'day\'" :: SqlExpr (Value String) ,s)
+    date :: SqlExpr (Value UTCTime)
+    date = unsafeSqlValue "TIMESTAMP \'2001-02-16 20:38:40\'"
+```
+
+which generates this SQL:
+
+```sql
+SELECT date_part('day', TIMESTAMP '2001-02-16 20:38:40')
+```
+
+Using `unsafeSqlValue` we were required to also define the type of the value.
+
+Another useful unsafe function is `unsafeSqlCastAs`, which allows us to cast any type
+to another within a query. For example, say we want to use our previews `dayPart` function
+on the current system time, we could:
+
+```haskell
+postgresTimestampDay :: (MonadIO m, MonadLogger m) => SqlWriteT m Int
+postgresTimestampDay = do
+  currentTime <- liftIO getCurrentTime
+  result <- select (return $ dayPart (toTIMESTAMP $ val currentTime))
+  case result of
+    [x] -> pure x
+    _ -> error "dayPart is guaranteed to return a single result"
+  where
+    dayPart :: SqlExpr (Value UTCTime) -> SqlExpr (Value Int)
+    dayPart s = unsafeSqlFunction "date_part" (unsafeSqlValue "\'day\'" :: SqlExpr (Value String) ,s)
+    toTIMESTAMP :: SqlExpr (Value UTCTime) -> SqlExpr (Value UTCTime)
+    toTIMESTAMP = unsafeSqlCastAs "TIMESTAMP"
+```
+
+which generates this SQL:
+
+```sql
+SELECT date_part('day', CAST('2019-10-28 23:19:39.400898344Z' AS TIMESTAMP))
+```
+
+### SQL injection
+
+Esqueleto uses parameterization to prevent sql injections on values and arguments
+on all queries, for example, if we have:
+
+```haskell
+myEvilQuery :: (MonadIO m, MonadLogger m) => SqlWriteT m ()
+myEvilQuery =
+  select (return $ val ("hi\'; DROP TABLE foo; select \'bye\'" :: String)) >>= liftIO . print
+```
+
+which generates this SQL(when using postgres):
+
+```sql
+SELECT 'hi''; DROP TABLE foo; select ''bye'''
+```
+
+And the printed value is `hi\'; DROP TABLE foo; select \'bye\'` and no table is dropped. This is good
+and makes the use of strings values safe. Unfortunately this is not the case when using unsafe functions.
+Let's see an example of defining a new evil `now` function:
+
+```haskell
+myEvilQuery :: (MonadIO m, MonadLogger m) => SqlWriteT m ()
+myEvilQuery =
+  select (return nowWithInjection) >>= liftIO . print
+  where
+    nowWithInjection :: SqlExpr (Value UTCTime)
+    nowWithInjection = unsafeSqlFunction "0; DROP TABLE bar; select now" ([] :: [SqlExpr (Value Int)])
+```
+
+which generates this SQL:
+
+```sql
+SELECT 0; DROP TABLE bar; select now()
+```
+
+If we were to run the above code we would see the postgres time printed but the table `bar`
+will be erased with no indication whatsoever. Another example of this behavior is seen when using
+`unsafeSqlValue`:
+
+```haskell
+myEvilQuery :: (MonadIO m, MonadLogger m) => SqlWriteT m ()
+myEvilQuery =
+  select (return $ dayPart dateWithInjection) >>= liftIO . print
+  where
+    dayPart :: SqlExpr (Value UTCTime) -> SqlExpr (Value Int)
+    dayPart s = unsafeSqlFunction "date_part" (unsafeSqlValue "\'day\'" :: SqlExpr (Value String) ,s)
+    dateWithInjection :: SqlExpr (Value UTCTime)
+    dateWithInjection = unsafeSqlValue "TIMESTAMP \'2001-02-16 20:38:40\');DROP TABLE bar; select (16"
+```
+
+which generates this SQL:
+
+```sql
+SELECT date_part('day', TIMESTAMP '2001-02-16 20:38:40');DROP TABLE bar; select (16)
+```
+
+This will print 16 and also erase the `bar` table. The main take away of this examples is to
+never use any user or third party input inside an unsafe function without first parsing it or
+heavily sanitizing the input.
+
+### Tests
+
+To run the tests, do `stack test`. This tests all the backends, so you'll need
+to have MySQL and Postgresql installed.
+
+#### Postgres
+
+Using apt-get, you should be able to do:
+
+```
+sudo apt-get install postgresql postgresql-contrib
+sudo apt-get install libpq-dev
+```
+
+Using homebrew on OSx
+
+```
+brew install postgresql
+brew install libpq
+```
+
+Detailed instructions on the Postgres wiki [here](https://wiki.postgresql.org/wiki/Detailed_installation_guides)
+
+The connection details are located near the bottom of the [test/PostgreSQL/Test.hs](test/PostgreSQL/Test.hs) file:
+
+```
+withConn =
+  R.runResourceT . withPostgresqlConn "host=localhost port=5432 user=esqutest password=esqutest dbname=esqutest"
+```
+
+You can change these if you like but to just get them working set up as follows on linux:
+
+```
+$ sudo -u postgres createuser esqutest
+$ sudo -u postgres createdb esqutest
+$ sudo -u postgres psql
+postgres=# \password esqutest
+```
+
+And on osx
+
+```
+$ createuser esqutest
+$ createdb esqutest
+$ psql postgres
+postgres=# \password esqutest
+```
+
+#### MySQL
+
+To test MySQL, you'll need to have a MySQL server installation.
+Then, you'll need to create a database `esqutest` and a `'travis'@'localhost'`
+user which can access it:
+
+```
+mysql> CREATE DATABASE esqutest;
+mysql> CREATE USER 'travis'@'localhost';
+mysql> ALTER USER 'travis'@'localhost' IDENTIFIED BY 'esqutest';
+mysql> GRANT ALL ON esqutest.* TO 'travis'@'localhost';
+```

cabal.project

@@ -0,0 +1,5 @@
+-- Generated by stackage-to-hackage
+
+packages:
+    ./
+  , examples/

changelog.md

@@ -0,0 +1,331 @@
+3.5.4.0
+=======
+- @parsonsmatt
+    - [#310](https://github.com/bitemyapp/esqueleto/pull/310)
+        - Add instances of `HasField` for `SqlExpr (Entity rec)` and `SqlExpr
+          (Maybe (Entity rec))`. These instances allow you to use the
+          `OverloadedRecordDot` language extension in GHC 9.2 with SQL
+          representations of database entities.
+
+3.5.3.2
+=======
+- @parsonsmatt
+    - [#309](https://github.com/bitemyapp/esqueleto/pull/309)
+        - Bump `time` version bound
+
+3.5.3.1
+=======
+- @jappeace
+  - [#303](https://github.com/bitemyapp/esqueleto/pull/303)
+      - Added docs for delete function for new experimental API.
+
+3.5.3.0
+=======
+- @m4dc4p
+  - [#291](https://github.com/bitemyapp/esqueleto/pull/291)
+         - Added `ToAlias` and `ToAliasReference` instaces to the `:&` type, mirroring
+         the tuple instances for the same classes. See [Issue #290](https://github.com/bitemyapp/esqueleto/issues/290)
+         for discussion.
+- @NikitaRazmakhnin
+  - [#284](https://github.com/bitemyapp/esqueleto/pull/284)
+        - Add PostgreSQL-specific support of VALUES(..) literals
+
+
+3.5.2.2
+=======
+- @NikitaRazmakhnin
+  - [#278](https://github.com/bitemyapp/esqueleto/pull/278)
+        - Fix generating of bad sql using nexted expressions with `distinctOnOrderBy`.
+
+3.5.2.1
+=======
+- @cdparks
+  - [#273](https://github.com/bitemyapp/esqueleto/pull/273)
+        - Avoid generating an empty list as the left operand to `NOT IN`.
+
+3.5.2.0
+=======
+- @ivanbakel
+  - [#268](https://github.com/bitemyapp/esqueleto/pull/268)
+        - Added `SqlSelect` instance for `(:&)`, allowing it to be returned from
+          queries just like `(,)` tuples.
+
+3.5.1.0
+=======
+- @ibarrae
+  - [#265](https://github.com/bitemyapp/esqueleto/pull/265)
+        - Added `selectOne`
+
+3.5.0.0
+=======
+- @belevy
+  - [#228](https://github.com/bitemyapp/esqueleto/pull/228)
+        - Destroy all GADTs; Removes the From GADT and SqlExpr GADT
+        - From GADT is replaced with a From data type and FromRaw
+        - SqlExpr is now all defined in terms of ERaw
+        - Modified ERaw to contain a SqlExprMeta with any extra information
+          that may be needed
+        - Experimental top level is now strictly for documentation and all the
+          implementation details are in Experimental.* modules
+- @parsonsmatt
+    - [#259](https://github.com/bitemyapp/esqueleto/pull/259)
+        - Create the `Database.Esqueleto.Legacy` module. The
+          `Database.Esqueleto` module now emits a warning, directing users to
+          either import `Database.Esqueleto.Legacy` to keep the old behavior or
+          to import `Database.Esqueleto.Experimental` to opt in to the new
+          behavior.
+        - Deleted the deprecated modules
+          `Database.Esqueleto.Internal.{Language,Sql}`. Please use
+          `Database.Esqueleto.Internal.Internal` instead, or ideally post what
+          you need from the library so we can support you safely.
+        - Support GHC 9
+
+3.4.2.2
+=======
+- @parsonsmatt
+  - [#255](https://github.com/bitemyapp/esqueleto/pull/255)
+    - Fix a bug where a composite primary key in a `groupBy` clause would break.
+
+3.4.2.1
+=======
+- @parsonsmatt
+  - [#245](https://github.com/bitemyapp/esqueleto/pull/245)
+    - Support `persistent-2.13`
+
+3.4.2.0
+=======
+- @parsonsmatt
+  - [#243](https://github.com/bitemyapp/esqueleto/pull/243)
+    - Support `persistent-2.12`
+
+3.4.1.1
+=======
+- @MaxGabriel
+  - [#240](https://github.com/bitemyapp/esqueleto/pull/240/files)
+    - Improve recommend hlint to avoid doing `x = NULL` SQL queries
+
+3.4.1.0
+=======
+- @arthurxavierx
+  - [#238](https://github.com/bitemyapp/esqueleto/pull/238)
+    - Fix non-exhaustive patterns in `unsafeSqlAggregateFunction`
+- @Vlix
+  - [#232](https://github.com/bitemyapp/esqueleto/pull/232)
+    - Export the `ValidOnClauseValue` type family
+
+
+3.4.0.1
+=======
+- @arthurxavierx
+  - [#221](https://github.com/bitemyapp/esqueleto/pull/221)
+    - Deprecate `ToAliasT` and `ToAliasReferenceT`
+- @parsonsmatt
+  - [#226](https://github.com/bitemyapp/esqueleto/pull/226)
+    - Support `persistent-2.11`
+- @belevy
+  - [#225](https://github.com/bitemyapp/esqueleto/pull/225)
+    - Simplify `ToFromT` extracting the overlapping and type error instances
+    - Make `ToFromT` and associated type family of `ToFrom`
+
+3.4.0.0
+=======
+- @belevy, @charukiewicz
+  - [#215](https://github.com/bitemyapp/esqueleto/pull/215)
+    - Added support for common table expressions (`with`, `withRecursive`)
+    - Added support for lateral JOINs with updated example (Example #6)
+    - Deprecated `SelectQuery`, removing the neccessity to tag `SqlQuery` values
+    - Deprecated use of data constructors for SQL set operations (replaced with functions)
+    - Refactored module structure to fix haddock build (fixes build from `3.3.4.0`)
+
+3.3.4.1
+=======
+- @maxgabriel
+  - [#214](https://github.com/bitemyapp/esqueleto/pull/214)
+    - Add suggested hlint rules for proper `isNothing` usage
+
+
+3.3.4.0
+=======
+- @parsonsmatt
+  - [#205](https://github.com/bitemyapp/esqueleto/pull/205)
+    - More documentation on the `Experimental` module
+    - `Database.Esqueleto.Experimental` now reexports `Database.Esqueleto`, so
+      the new "approved" import syntax is less verbose. Before, you'd write:
+
+      ```haskell
+      import Database.Esqueleto hiding (from, on)
+      import Database.Esqueleto.Experimental
+      ```
+
+      Now you can merely write:
+
+      ```haskell
+      import Database.Esqueleto.Experimental
+      ```
+
+      Users will get 'redundant import' warnings if they followed the original
+      syntax, the solution is evident from the error message provided.
+
+3.3.3.3
+=======
+- @belevy
+  - [#191](https://github.com/bitemyapp/esqueleto/pull/191) - Bugfix rollup:
+    Fix issue with extra characters in generated SQL;
+    Fix ToAliasReference for already referenced values;
+    Fix Alias/Reference for Maybe Entity
+- @maxgabriel
+  - [#203](https://github.com/bitemyapp/esqueleto/pull/203) Document `isNothing`
+- @sestrella
+  - [#198](https://github.com/bitemyapp/esqueleto/pull/198) - Allow PostgreSQL aggregate functions to take a filter clause
+
+3.3.3.2
+========
+- @maxgabriel
+  - [#190](https://github.com/bitemyapp/esqueleto/pull/190) Further document and test `ToBaseId`
+
+3.3.3.1
+========
+- @belevy
+  - [#189](https://github.com/bitemyapp/esqueleto/pull/189) - Fix bug in function calls with
+    aliased values introduced by SubQuery joins.
+
+3.3.3.0
+========
+- @belevy
+  - [#172](https://github.com/bitemyapp/esqueleto/pull/172) - Introduce new
+    experimental module for joins, set operations (eg UNION), and safer queries
+    from outer joins.
+
+3.3.2
+========
+
+- @belevy
+  - [#177](https://github.com/bitemyapp/esqueleto/pull/177) Fix natural key handling in (^.)
+
+3.3.1.1
+========
+
+- @parsonsmatt
+  - [#170](https://github.com/bitemyapp/esqueleto/pull/170) Add documentation to `groupBy` to explain tuple nesting.
+
+3.3.1
+========
+
+- @charukiewicz, @belevy, @joemalin95
+  - [#167](https://github.com/bitemyapp/esqueleto/pull/167): Exposed functions that were added in `3.3.0`
+
+3.3.0
+========
+
+- @charukiewicz, @belevy, @joemalin95
+  - [#166](https://github.com/bitemyapp/esqueleto/pull/166): Add several common SQL string functions: `upper_`, `trim_`, `ltrim_`, `rtrim_`, `length_`, `left_`, `right_`
+
+3.2.3
+========
+
+- @hdgarrood
+  - [#163](https://github.com/bitemyapp/esqueleto/pull/163): Allow `unsafeSqlFunction` to take up to 10 arguments without needing to nest tuples.
+
+3.2.2
+========
+
+- @parsonsmatt
+  - [#161](https://github.com/bitemyapp/esqueleto/pull/161/): Fix an issue where
+    nested joins didn't get the right on clause.
+
+3.2.1
+========
+
+- @parsonsmatt
+  - [#159](https://github.com/bitemyapp/esqueleto/pull/159): Add an instance of `UnsafeSqlFunction ()` for 0-argument SQL
+  functions.
+
+3.2.0
+========
+
+- @parsonsmatt
+  - [#153](https://github.com/bitemyapp/esqueleto/pull/153): Deprecate
+    `sub_select` and introduce `subSelect`, `subSelectMaybe`, and
+    `subSelectUnsafe`.
+- @parsonsmatt
+  - [#156](https://github.com/bitemyapp/esqueleto/pull/156): Remove the
+    restriction that `on` clauses must appear in reverse order to the joining
+    tables.
+
+3.1.3
+========
+
+- @JoseD92
+  - [#155](https://github.com/bitemyapp/esqueleto/pull/149): Added `insertSelectWithConflict` postgres function.
+
+3.1.2
+========
+
+- @tippenein
+  - [#149](https://github.com/bitemyapp/esqueleto/pull/157): Added `associateJoin` query helpers.
+
+3.1.1
+=======
+
+- @JoseD92
+  - [#149](https://github.com/bitemyapp/esqueleto/pull/149): Added `upsert` support.
+
+- @parsonsmatt
+  - [#133](https://github.com/bitemyapp/esqueleto/pull/133): Added `renderQueryToText` and related functions.
+
+3.1.0
+=======
+
+- @Vlix
+  - [#128](https://github.com/bitemyapp/esqueleto/pull/128): Added `Database.Esqueleto.PostgreSQL.JSON` module with JSON operators and `JSONB` data type.
+- @ibarrae
+  - [#127](https://github.com/bitemyapp/esqueleto/pull/127): Added `between` and support for composite keys in `unsafeSqlBinOp`.
+
+3.0.0
+=======
+
+- @parsonsmatt
+  - [#122](https://github.com/bitemyapp/esqueleto/pull/122): Support `persistent-2.10.0`. This is a breaking change due to the removal of deprecated exports from the `persistent` library.
+  - [#113](https://github.com/bitemyapp/esqueleto/pull/113): Remove the `esqueleto` type class. To migrate here, use `SqlExpr`, `SqlQuery`, and `SqlBackend` instead of using the polymorphic `Esqueleto sqlExpr sqlQuery sqlBackend => ...` types.
+
+2.7.0
+=======
+
+- @parsonsmatt
+  - [#117](https://github.com/bitemyapp/esqueleto/pull/117): Removed `sqlQQ` and `executeQQ` functions from export, fixing doc build and building with `persistent` >= 2.9
+
+2.6.1
+=======
+
+- @ChrisCoffey
+  - [#114](https://github.com/bitemyapp/esqueleto/pull/114): Fix Haddock by
+    working around an upstream bug.
+
+2.6.0
+========
+- @bitemyapp
+  - Reorganized dependencies, decided to break compatibility for Conduit 1.3, Persistent 2.8, and `unliftio`.
+  - Moved tests for `random()` into database-specific test suites.
+  - Deprecated Language `random_`, split it into database-specific modules.
+- @parsonsmatt
+  - Added support for `PersistQueryRead`/`PersistQueryWrite`, enabling type-safe differentation of read and write capabilities.
+    - https://github.com/bitemyapp/esqueleto/pull/66
+- @sestrella
+  - Added support for `arrayAggDistinct` and `arrayRemove`.
+    - https://github.com/bitemyapp/esqueleto/pull/65
+    - https://github.com/bitemyapp/esqueleto/pull/66
+- @mheinzel
+  - Fixed JOIN syntax in the documentation https://github.com/bitemyapp/esqueleto/pull/60
+- @illmade
+  - Added instructions for running database specific tests
+    - https://github.com/bitemyapp/esqueleto/pull/64
+- @FintanH
+  - Removed CPP from the test suite, split the database-specific tests into their own respective modules.
+    - https://github.com/bitemyapp/esqueleto/pull/48
+  - Added support for PostgreSQL's `now()`
+    - https://github.com/bitemyapp/esqueleto/pull/46
+  - Added a comprehensive examples project to make practical application of Esqueleto easier.
+    - https://github.com/bitemyapp/esqueleto/pull/40
+- @EdwardBetts
+  - Fixed a spelling error
+    - https://github.com/bitemyapp/esqueleto/pull/52

esqueleto.cabal

@@ -1,122 +1,128 @@
-name:                esqueleto
+cabal-version: 1.12
-version:             2.5.2
+
-synopsis:            Type-safe EDSL for SQL queries on persistent backends.
+name:           esqueleto
-homepage:            https://github.com/bitemyapp/esqueleto
+version:        3.5.4.0
-license:             BSD3
+synopsis:       Type-safe EDSL for SQL queries on persistent backends.
-license-file:        LICENSE
+description:    @esqueleto@ is a bare bones, type-safe EDSL for SQL queries that works with unmodified @persistent@ SQL backends.  Its language closely resembles SQL, so you don't have to learn new concepts, just new syntax, and it's fairly easy to predict the generated SQL and optimize it for your backend. Most kinds of errors committed when writing SQL are caught as compile-time errors---although it is possible to write type-checked @esqueleto@ queries that fail at runtime.
-author:              Felipe Lessa
+                .
-maintainer:          cma@bitemyapp.com
+                @persistent@ is a library for type-safe data serialization.  It has many kinds of backends, such as SQL backends (@persistent-mysql@, @persistent-postgresql@, @persistent-sqlite@) and NoSQL backends (@persistent-mongoDB@). While @persistent@ is a nice library for storing and retrieving records, including with filters, it does not try to support some of the features that are specific to SQL backends.  In particular, @esqueleto@ is the recommended library for type-safe @JOIN@s on @persistent@ SQL backends.  (The alternative is using raw SQL, but that's error prone and does not offer any composability.)
-copyright:           (c) 2012-2016 Felipe Almeida Lessa
+                .
-category:            Database
+                Currently, @SELECT@s, @UPDATE@s, @INSERT@s and @DELETE@s are supported. Not all SQL features are available, but most of them can be easily added (especially functions), so please open an issue or send a pull request if you need anything that is not covered by @esqueleto@ on <https://github.com/bitemyapp/esqueleto>.
-build-type:          Simple
+                .
-cabal-version:       >=1.8
+                The name of this library means \"skeleton\" in Portuguese and contains all three SQL letters in the correct order =).  It was inspired by Scala's Squeryl but created from scratch.
-description:
+category:       Database
-  @esqueleto@ is a bare bones, type-safe EDSL for SQL queries
+homepage:       https://github.com/bitemyapp/esqueleto
-  that works with unmodified @persistent@ SQL backends.  Its
+author:         Felipe Lessa
-  language closely resembles SQL, so you don't have to learn
+maintainer:     cma@bitemyapp.com
-  new concepts, just new syntax, and it's fairly easy to
+copyright:      (c) 2012-2016 Felipe Almeida Lessa
-  predict the generated SQL and optimize it for your backend.
+license:        BSD3
-  Most kinds of errors committed when writing SQL are caught as
+license-file:   LICENSE
-  compile-time errors---although it is possible to write
+build-type:     Simple
-  type-checked @esqueleto@ queries that fail at runtime.
+extra-source-files:
-  .
+    README.md
-  @persistent@ is a library for type-safe data serialization.  It
+    changelog.md
-  has many kinds of backends, such as SQL backends
-  (@persistent-mysql@, @persistent-postgresql@,
-  @persistent-sqlite@) and NoSQL backends (@persistent-mongoDB@).
-  While @persistent@ is a nice library for storing and retrieving
-  records, including with filters, it does not try to support
-  some of the features that are specific to SQL backends.  In
-  particular, @esqueleto@ is the recommended library for
-  type-safe @JOIN@s on @persistent@ SQL backends.  (The
-  alternative is using raw SQL, but that's error prone and does
-  not offer any composability.)
-  .
-  Currently, @SELECT@s, @UPDATE@s, @INSERT@s and @DELETE@s are supported.
-  Not all SQL features are available, but most of them can be easily added
-  (especially functions), so please open an issue or send a pull request if
-  you need anything that is not covered by @esqueleto@ on
-  <https://github.com/bitemyapp/esqueleto>.
-  .
-  The name of this library means \"skeleton\" in Portuguese and
-  contains all three SQL letters in the correct order =).  It was
-  inspired by Scala's Squeryl but created from scratch.
 
 source-repository head
-  type:     git
+    type: git
-  location: git://github.com/bitemyapp/esqueleto.git
+    location: git://github.com/bitemyapp/esqueleto.git
-
-Flag postgresql
-  Description: test postgresql. default is to test sqlite.
-  Default: False
-
-Flag mysql
-  Description: test MySQL/MariaDB. default is to test sqlite.
-  Default: False
 
 library
-  exposed-modules:
+    exposed-modules:
-    Database.Esqueleto
+        Database.Esqueleto
-    Database.Esqueleto.PostgreSQL
+        Database.Esqueleto.Legacy
-    Database.Esqueleto.Internal.Language
+        Database.Esqueleto.Experimental
-    Database.Esqueleto.Internal.Sql
+        Database.Esqueleto.Internal.Internal
-  other-modules:
+        Database.Esqueleto.Internal.ExprParser
-    Database.Esqueleto.Internal.PersistentImport
+        Database.Esqueleto.MySQL
-  build-depends:
+        Database.Esqueleto.PostgreSQL
-      base                 >= 4.8     && < 5.0
+        Database.Esqueleto.PostgreSQL.JSON
-    , bytestring
+        Database.Esqueleto.SQLite
-    , text                 >= 0.11    && < 1.3
+        Database.Esqueleto.Experimental.From
-    , persistent           >= 2.5 && < 2.8
+        Database.Esqueleto.Experimental.From.CommonTableExpression
-    , transformers         >= 0.2
+        Database.Esqueleto.Experimental.From.Join
-    , unordered-containers >= 0.2
+        Database.Esqueleto.Experimental.From.SqlSetOperation
-    , tagged               >= 0.2
+        Database.Esqueleto.Experimental.ToAlias
-
+        Database.Esqueleto.Experimental.ToAliasReference
-    , monad-logger
+        Database.Esqueleto.Experimental.ToMaybe
-    , conduit              >= 1.1
+    other-modules:
-    , resourcet            >= 1.1
+        Database.Esqueleto.PostgreSQL.JSON.Instances
-    , blaze-html
+        Database.Esqueleto.Internal.PersistentImport
-  hs-source-dirs: src/
+        Paths_esqueleto
-  if impl(ghc >= 8.0)
+    hs-source-dirs:
-    ghc-options: -Wall -Wno-redundant-constraints
+        src/
-  else
-    ghc-options: -Wall
-
-test-suite test
-  type: exitcode-stdio-1.0
-  ghc-options:    -Wall
-  hs-source-dirs: test
-  main-is:        Test.hs
-  build-depends:
-      -- Library dependencies used on the tests.  No need to
-      -- specify versions since they'll use the same as above.
-      base, persistent, transformers, resourcet, text
-
-      -- Test-only dependencies
-    , conduit             >= 1.1
-    , containers
-    , HUnit
-    , QuickCheck
-    , hspec               >= 1.8
-    , persistent-sqlite   >= 2.1.3
-    , persistent-template >= 2.1
-    , monad-control
-    , monad-logger        >= 0.3
-
-      -- This library
-    , esqueleto
-
-  if flag(postgresql)
     build-depends:
-        postgresql-simple     >= 0.2
+        base >=4.8 && <5.0
-      , postgresql-libpq      >= 0.6
+      , aeson >=1.0
-      , persistent-postgresql >= 2.0
+      , attoparsec >= 0.13 && < 0.15
+      , blaze-html
+      , bytestring
+      , conduit >=1.3
+      , containers
+      , monad-logger
+      , persistent >=2.13 && <3
+      , resourcet >=1.2
+      , tagged >=0.2
+      , text >=0.11 && <1.3
+      , time >=1.5.0.1 && <=1.13
+      , transformers >=0.2
+      , unliftio
+      , unordered-containers >=0.2
+    ghc-options:
+        -Wall
+        -Wno-redundant-constraints
+        -Wincomplete-uni-patterns
+        -Wincomplete-record-updates
+        -Wpartial-fields
+        -Wmissing-home-modules
+        -Widentities
+        -Wcpp-undef
+        -Wcpp-undef
+    default-language: Haskell2010
 
-    cpp-options: -DWITH_POSTGRESQL
+test-suite specs
-
+    type: exitcode-stdio-1.0
-  if flag(mysql)
+    main-is: Spec.hs
+    other-modules:
+        Common.Test
+        Common.Test.Models
+        Common.Test.Import
+        Common.Test.Select
+        PostgreSQL.MigrateJSON
+        SQLite.Test
+        PostgreSQL.Test
+        MySQL.Test
+    default-extensions:
+        RankNTypes
+    hs-source-dirs:
+        test
+    ghc-options: -Wall -threaded
     build-depends:
-        mysql-simple          >= 0.2.2.3
+        base >=4.8 && <5.0
-      , mysql                 >= 0.1.1.3
+      , aeson
-      , persistent-mysql      >= 2.0
+      , attoparsec
-
+      , blaze-html
-    cpp-options: -DWITH_MYSQL
+      , bytestring
+      , conduit
+      , containers
+      , esqueleto
+      , exceptions
+      , hspec
+      , hspec-core
+      , monad-logger
+      , mtl
+      , mysql
+      , mysql-simple
+      , persistent
+      , persistent-mysql
+      , persistent-postgresql
+      , persistent-sqlite
+      , postgresql-simple
+      , QuickCheck
+      , resourcet
+      , tagged
+      , text
+      , time
+      , transformers
+      , unliftio
+      , unordered-containers
+    default-language: Haskell2010

examples/Blog.hs

@@ -0,0 +1,58 @@
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE StandaloneDeriving         #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE UndecidableInstances       #-}
+
+module Blog
+    ( runBlogT
+    ) where
+
+import           Control.Monad.Base          (MonadBase (..))
+import           Control.Monad.IO.Unlift     (MonadUnliftIO(..), wrappedWithRunInIO)
+import           Control.Monad.Logger        (MonadLoggerIO, MonadLogger, NoLoggingT (..))
+import           Control.Monad.Reader
+import           Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..),
+                                              MonadTransControl (..),
+                                              defaultLiftBaseWith,
+                                              defaultRestoreM)
+import           Database.Persist.Postgresql (ConnectionString)
+
+newtype BlogT m a = BlogT { unBlogT :: NoLoggingT (ReaderT ConnectionString m) a }
+  deriving ( Functor
+           , Applicative
+           , Monad
+           , MonadLogger
+           , MonadReader ConnectionString
+           , MonadIO
+           , MonadLoggerIO
+           )
+
+instance MonadUnliftIO m => MonadUnliftIO (BlogT m) where
+  withRunInIO = wrappedWithRunInIO BlogT unBlogT
+
+instance MonadTrans BlogT where
+  lift = BlogT . lift . lift
+
+
+deriving instance (MonadBase b m) => MonadBase b (BlogT m)
+
+
+instance MonadBaseControl b m => MonadBaseControl b (BlogT m) where
+  type StM (BlogT m) a = ComposeSt BlogT m a
+  liftBaseWith     = defaultLiftBaseWith
+  restoreM         = defaultRestoreM
+
+
+instance MonadTransControl BlogT where
+  type StT BlogT a = StT NoLoggingT (StT (ReaderT ConnectionString) a)
+  liftWith f = BlogT $ liftWith $ \run ->
+                                    liftWith $ \run' ->
+                                                f (run' . run . unBlogT)
+  restoreT = BlogT . restoreT . restoreT
+
+
+runBlogT :: ConnectionString -> BlogT m a -> m a
+runBlogT backend (BlogT m) =
+  runReaderT (runNoLoggingT m) backend

examples/LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2012, Felipe Lessa
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Felipe Lessa nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

examples/Main.hs

@@ -0,0 +1,237 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
+
+module Main
+    ( main
+    ) where
+
+import Blog
+import Control.Monad (void)
+import Control.Monad (forM_)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.IO.Unlift (MonadUnliftIO)
+import Control.Monad.Logger (MonadLogger, MonadLoggerIO)
+import Control.Monad.Reader (MonadReader(..), runReaderT)
+import Control.Monad.Trans.Control (MonadBaseControl)
+import Data.Monoid ((<>))
+import Database.Esqueleto
+import Database.Persist.Postgresql (ConnectionString, withPostgresqlConn)
+import Database.Persist.TH
+       ( AtLeastOneUniqueKey(..)
+       , OnlyOneUniqueKey(..)
+       , mkDeleteCascade
+       , mkMigrate
+       , mkPersist
+       , persistLowerCase
+       , share
+       , sqlSettings
+       )
+
+
+share [ mkPersist sqlSettings
+      , mkDeleteCascade sqlSettings
+      , mkMigrate "migrateAll"] [persistLowerCase|
+  Person
+    name String
+    age Int Maybe
+    deriving Eq Show
+  BlogPost
+    title String
+    authorId PersonId
+    deriving Eq Show
+  Follow
+    follower PersonId
+    followed PersonId
+    deriving Eq Show
+|]
+
+putPersons :: (MonadIO m, MonadLogger m)
+           => SqlPersistT m ()
+putPersons = do
+  -- | Select all values from the `person` table
+  people <- select $
+              from $ \person -> do
+              return person
+
+  -- | entityVal extracts the Person value, which we then extract
+  -- | the person name from the record and print it
+  liftIO $ mapM_ (putStrLn . ("Name: " ++) . personName . entityVal) people
+
+
+getJohns :: (MonadIO m, MonadLogger m)
+         => SqlReadT m [Entity Person]
+getJohns =
+  -- | Select all persons where their name is equal to "John"
+  select $
+  from $ \p -> do
+    where_ (p ^. PersonName ==. val "John")
+    return p
+
+
+getAdults :: (MonadIO m, MonadLogger m)
+          => SqlReadT m [Entity Person]
+getAdults =
+  -- | Select any Person where their age is >= 18 and NOT NULL
+  select $
+  from $ \p -> do
+    where_ (p ^. PersonAge >=. just (val 18))
+    return p
+
+
+getBlogPostsByAuthors :: (MonadIO m, MonadLogger m)
+                      => SqlReadT m [(Entity BlogPost, Entity Person)]
+getBlogPostsByAuthors =
+  -- | Select all persons and their blogposts, ordering by title
+  select $
+  from $ \(b, p) -> do
+    where_ (b ^. BlogPostAuthorId ==. p ^. PersonId)
+    orderBy [asc (b ^. BlogPostTitle)]
+    return (b, p)
+
+
+getAuthorMaybePosts :: (MonadIO m, MonadLogger m)
+                    => SqlReadT m [(Entity Person, Maybe (Entity BlogPost))]
+getAuthorMaybePosts =
+  -- | Select all persons doing a left outer join on blogposts
+  -- | Since a person may not have any blogposts the BlogPost Entity is wrapped
+  -- | in a Maybe
+  select $
+  from $ \(p `LeftOuterJoin` mb) -> do
+    on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId)
+    orderBy [asc (p ^. PersonName), asc (mb ?. BlogPostTitle)]
+    return (p, mb)
+
+
+followers :: (MonadIO m, MonadLogger m)
+          => SqlReadT m [(Entity Person, Entity Follow, Entity Person)]
+followers =
+  -- | Select mutual follow relationships
+  -- | Note carefully that the order of the ON clauses is reversed!
+  -- | You're required to write your ons in reverse order because that helps composability
+  -- | (see the documentation of on for more details).
+  select $
+  from $ \(p1 `InnerJoin` f `InnerJoin` p2) -> do
+    on (p2 ^. PersonId ==. f ^. FollowFollowed)
+    on (p1 ^. PersonId ==. f ^. FollowFollower)
+    return (p1, f, p2)
+
+
+updateJoao :: (MonadIO m, MonadLogger m)
+           => SqlWriteT m ()
+updateJoao =
+  -- Update the name of any Joao in our person table to João
+  update $ \p -> do
+    set p [ PersonName =. val "João" ]
+    where_ (p ^. PersonName ==. val "Joao")
+
+
+deleteYoungsters :: (MonadIO m, MonadLogger m)
+                 => SqlPersistT m ()
+deleteYoungsters = do
+  -- | Delete any persons under the age of 14
+
+  -- | In this case where `ON DELETE CASCADE` is not generated by migration
+  -- | we select all the entities we want to delete and then for each one
+  -- | one we extract the key and use Persistent's `deleteCascade`
+  youngsters <- select $
+    from $ \p -> do
+    where_ (p ^. PersonAge <. just (val 14))
+    pure p
+  forM_ youngsters (deleteCascade . entityKey)
+
+
+insertBlogPosts :: (MonadIO m, MonadLogger m)
+                => SqlWriteT m ()
+insertBlogPosts =
+  -- | Insert a new blogpost for every person
+  insertSelect $ from $ \p ->
+    return $ BlogPost <# (val "Group Blog Post") <&> (p ^. PersonId)
+
+
+runDB :: (MonadReader ConnectionString m,
+          MonadIO m,
+          MonadBaseControl IO m,
+          MonadUnliftIO m,
+          MonadLoggerIO m,
+          MonadLogger m)
+      => SqlPersistT m a -> m a
+runDB query = do
+  -- | Helper for running a query
+  conn <- ask
+  withPostgresqlConn conn $ \backend -> runReaderT query backend
+
+
+setupDb :: (MonadIO m, MonadLogger m)
+          => SqlPersistT m ()
+setupDb = do
+  -- | Run migrations and create the test database entries
+  runMigration migrateAll
+  createDb
+  where
+    createDb :: (MonadIO m, MonadLogger m)
+           => SqlPersistT m ()
+    createDb = do
+      john <- insert $ Person "John" (Just 24)
+      sean <- insert $ Person "Seán" (Just 70)
+      joao <- insert $ Person "Joao" (Just 13)
+      void $ insertMany [ BlogPost "How to play a bodhrán" sean
+                        , BlogPost "Haskell for the working class hero" john
+                        ]
+      void $ insert $ Follow john sean
+      void $ insert $ Follow sean john
+      void $ insert $ Follow joao sean
+
+
+cleanDb :: (MonadIO m, MonadLogger m)
+        => SqlPersistT m ()
+cleanDb = do
+  -- | Drop the tables so we can re-run the script again if needed
+  dropTable "follow"
+  dropTable "blog_post"
+  dropTable "person"
+  where
+    dropTable tableName = rawExecute ("DROP TABLE " <> tableName) []
+
+main :: IO ()
+main = do
+  -- Connection string for the postrgesql database
+  runBlogT connection . runDB $ do
+    setupDb
+    putPersons
+
+    johns <- getJohns
+    mapM_ say johns
+
+    adults <- getAdults
+    mapM_ say adults
+
+    authorBlogPosts <- getBlogPostsByAuthors
+    mapM_ say authorBlogPosts
+
+    authoMaybePosts <- getAuthorMaybePosts
+    mapM_ say authoMaybePosts
+
+    mutualFollowers <- followers
+    mapM_ say mutualFollowers
+
+    updateJoao
+    deleteYoungsters
+    insertBlogPosts
+    cleanDb
+  where
+    say :: (MonadIO m, Show a) => a -> m ()
+    say = liftIO . print
+    connection = "host=localhost port=5432 user=postgres dbname=esqueleto_blog_example password=***"

examples/README.md

@@ -0,0 +1,3 @@
+# Esqueleto Examples
+
+These examples can be build via `stack build`.

examples/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

examples/esqueleto-examples.cabal

@@ -0,0 +1,49 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.34.4.
+--
+-- see: https://github.com/sol/hpack
+--
+-- hash: d5fddaf37d0c2f27fb2446f5038899d766102efd74ccfe4c7bcd02c61837e6b6
+
+name:           esqueleto-examples
+version:        0.0.0.0
+category:       Database
+homepage:       https://github.com/bitemyapp/esqueleto#readme
+bug-reports:    https://github.com/bitemyapp/esqueleto/issues
+author:         Fintan Halpenny
+maintainer:     cma@bitemyapp.com
+copyright:      2019, Chris Allen
+license:        BSD3
+license-file:   LICENSE
+build-type:     Simple
+extra-source-files:
+    README.md
+
+source-repository head
+  type: git
+  location: https://github.com/bitemyapp/esqueleto
+
+flag werror
+  description: Treat warnings as errors
+  manual: True
+  default: False
+
+executable blog-example
+  main-is: Main.hs
+  other-modules:
+      Blog
+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      base
+    , esqueleto
+    , monad-control
+    , monad-logger
+    , mtl
+    , persistent >=2.12
+    , persistent-postgresql
+    , transformers-base
+    , unliftio-core
+  if flag(werror)
+    ghc-options: -Werror
+  default-language: Haskell2010

examples/package.yaml

@@ -0,0 +1,44 @@
+name: esqueleto-examples
+version: '0.0.0.0'
+category: Database
+author: Fintan Halpenny
+maintainer: cma@bitemyapp.com
+copyright: 2019, Chris Allen
+license: BSD3
+github: bitemyapp/esqueleto
+
+extra-source-files:
+- README.md
+
+dependencies:
+- base
+- esqueleto
+- persistent >= 2.12
+- persistent-postgresql
+- mtl
+- monad-logger
+- monad-control
+- transformers-base
+- unliftio-core
+
+ghc-options:
+- '-Wall'
+- '-threaded'
+- '-rtsopts'
+- '-with-rtsopts=-N'
+
+when:
+  - condition: flag(werror)
+    ghc-options: '-Werror'
+
+executables:
+  blog-example:
+    other-modules:
+      - Blog
+    main: Main.hs
+
+flags:
+  werror:
+    description: "Treat warnings as errors"
+    manual: true
+    default: false

src/Database/Esqueleto.hs

@@ -1,4 +1,8 @@
-{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
+
 -- | The @esqueleto@ EDSL (embedded domain specific language).
 -- This module replaces @Database.Persist@, so instead of
 -- importing that module you should just import this one:
@@ -27,7 +31,16 @@
 --
 -- Other than identifier name clashes, @esqueleto@ does not
 -- conflict with @persistent@ in any way.
-module Database.Esqueleto
+--
+-- Note that the facilities for @JOIN@ have been significantly improved in the
+-- "Database.Esqueleto.Experimental" module. The definition of 'from' and 'on'
+-- in this module will be replaced with those at the 4.0.0.0 version, so you are
+-- encouraged to migrate to the new method.
+--
+-- This module has an attached WARNING message indicating that the Experimental
+-- syntax will become the default. If you want to continue using the old syntax,
+-- please refer to "Database.Esqueleto.Legacy" as a drop-in replacement.
+module Database.Esqueleto {-# WARNING "This module will switch over to the Experimental syntax in an upcoming major version release. Please migrate to the Database.Esqueleto.Legacy module to continue using the old syntax, or translate to the new and improved syntax in Database.Esqueleto.Experimental." #-}
   ( -- * Setup
     -- $setup
 
@@ -38,28 +51,34 @@ module Database.Esqueleto
     -- $gettingstarted
 
     -- * @esqueleto@'s Language
-    Esqueleto( where_, on, groupBy, orderBy, rand, asc, desc, limit, offset
+    where_, on, groupBy, orderBy, rand, asc, desc, limit, offset
              , distinct, distinctOn, don, distinctOnOrderBy, having, locking
-             , sub_select, sub_selectDistinct, (^.), (?.)
+             , sub_select, (^.), (?.)
-             , val, isNothing, just, nothing, joinV
+             , val, isNothing, just, nothing, joinV, withNonNull
              , countRows, count, countDistinct
              , not_, (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.)
-             , (+.), (-.), (/.), (*.)
+             , between, (+.), (-.), (/.), (*.)
              , random_, round_, ceiling_, floor_
              , min_, max_, sum_, avg_, castNum, castNumM
              , coalesce, coalesceDefault
-             , lower_, like, ilike, (%), concat_, (++.), castString
+             , lower_, upper_, trim_, ltrim_, rtrim_, length_, left_, right_
-             , subList_select, subList_selectDistinct, valList, justList
+             , like, ilike, (%), concat_, (++.), castString
+             , subList_select, valList, justList
              , in_, notIn, exists, notExists
              , set, (=.), (+=.), (-=.), (*=.), (/=.)
-             , case_, toBaseId)
+             , case_, toBaseId
+  , subSelect
+  , subSelectMaybe
+  , subSelectCount
+  , subSelectForeign
+  , subSelectList
+  , subSelectUnsafe
   , ToBaseId(..)
   , when_
   , then_
   , else_
   , from
   , Value(..)
-  , unValue
   , ValueList(..)
   , OrderBy
   , DistinctOn
@@ -71,32 +90,38 @@ module Database.Esqueleto
   , LeftOuterJoin(..)
   , RightOuterJoin(..)
   , FullOuterJoin(..)
+  , JoinKind(..)
   , OnClauseWithoutMatchingJoinException(..)
-
     -- * SQL backend
   , SqlQuery
   , SqlExpr
   , SqlEntity
   , select
-  , selectDistinct
+  , selectOne
   , selectSource
-  , selectDistinctSource
   , delete
   , deleteCount
   , update
   , updateCount
   , insertSelect
   , insertSelectCount
-  , insertSelectDistinct
   , (<#)
   , (<&>)
-
+  -- ** Rendering Queries
+  , renderQueryToText
+  , renderQuerySelect
+  , renderQueryUpdate
+  , renderQueryDelete
+  , renderQueryInsertInto
+    -- * Internal.Language
+  , From
     -- * RDBMS-specific modules
     -- $rdbmsSpecificModules
 
     -- * Helpers
   , valkey
   , valJ
+  , associateJoin
 
     -- * Re-exports
     -- $reexports
@@ -104,13 +129,8 @@ module Database.Esqueleto
   , module Database.Esqueleto.Internal.PersistentImport
   ) where
 
-import Control.Monad.IO.Class (MonadIO)
+import Database.Esqueleto.Legacy
-import Control.Monad.Trans.Reader (ReaderT)
-import Data.Int (Int64)
-import Database.Esqueleto.Internal.Language
-import Database.Esqueleto.Internal.Sql
 import Database.Esqueleto.Internal.PersistentImport
-import qualified Database.Persist
 
 
 -- $setup
@@ -314,7 +334,7 @@ import qualified Database.Persist
 -- SELECT P1.*, Follow.*, P2.*
 -- FROM Person AS P1
 -- INNER JOIN Follow ON P1.id = Follow.follower
--- INNER JOIN P2 ON P2.id = Follow.followed
+-- INNER JOIN Person AS P2 ON P2.id = Follow.followed
 -- @
 --
 -- In @esqueleto@, we may write the same query above as:
@@ -322,16 +342,11 @@ import qualified Database.Persist
 -- @
 -- 'select' $
 -- 'from' $ \\(p1 `'InnerJoin`` f `'InnerJoin`` p2) -> do
--- 'on' (p2 '^.' PersonId '==.' f '^.' FollowFollowed)
 -- 'on' (p1 '^.' PersonId '==.' f '^.' FollowFollower)
+-- 'on' (p2 '^.' PersonId '==.' f '^.' FollowFollowed)
 -- return (p1, f, p2)
 -- @
 --
--- /Note carefully that the order of the ON clauses is/
--- /reversed!/ You're required to write your 'on's in reverse
--- order because that helps composability (see the documentation
--- of 'on' for more details).
---
 -- We also currently support @UPDATE@ and @DELETE@ statements.
 -- For example:
 --
@@ -398,41 +413,3 @@ import qualified Database.Persist
 --
 -- In order to use these functions, you need to explicitly import
 -- their corresponding modules, they're not re-exported here.
-
-
-----------------------------------------------------------------------
-
-
--- | @valkey i = 'val' . 'toSqlKey'@
--- (<https://github.com/prowdsponsor/esqueleto/issues/9>).
-valkey :: (Esqueleto query expr backend, ToBackendKey SqlBackend entity, PersistField (Key entity)) =>
-          Int64 -> expr (Value (Key entity))
-valkey = val . toSqlKey
-
-
--- | @valJ@ is like @val@ but for something that is already a @Value@. The use
--- case it was written for was, given a @Value@ lift the @Key@ for that @Value@
--- into the query expression in a type safe way. However, the implementation is
--- more generic than that so we call it @valJ@.
---
--- Its important to note that the input entity and the output entity are
--- constrained to be the same by the type signature on the function
--- (<https://github.com/prowdsponsor/esqueleto/pull/69>).
---
--- /Since: 1.4.2/
-valJ :: (Esqueleto query expr backend, PersistField (Key entity)) =>
-        Value (Key entity) -> expr (Value (Key entity))
-valJ = val . unValue
-
-
-----------------------------------------------------------------------
-
-
--- | Synonym for 'Database.Persist.Store.delete' that does not
--- clash with @esqueleto@'s 'delete'.
-deleteKey :: ( PersistStore backend
-             , BaseBackend backend ~ PersistEntityBackend val
-             , MonadIO m
-             , PersistEntity val )
-          => Key val -> ReaderT backend m ()
-deleteKey = Database.Persist.delete

src/Database/Esqueleto/Experimental.hs

@@ -0,0 +1,563 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+-- | This module contains a new way (introduced in 3.3.3.0) of using @FROM@ in
+-- Haskell. The old method was a bit finicky and could permit runtime errors,
+-- and this new way is both significantly safer and much more powerful.
+--
+-- This syntax will become the default syntax exported from the library in
+-- version @3.6.0.0@. To use the old syntax, see "Database.Esqueleto.Legacy".
+module Database.Esqueleto.Experimental
+    ( -- * Setup
+      -- $setup
+
+      -- * Introduction
+      -- $introduction
+
+      -- * A New Syntax
+      -- $new-syntax
+
+      -- * Documentation
+
+    -- ** Basic Queries
+      from
+    , table
+    , Table(..)
+    , SubQuery(..)
+    , selectQuery
+
+    -- ** Joins
+    , (:&)(..)
+    , on
+    , innerJoin
+    , innerJoinLateral
+    , leftJoin
+    , leftJoinLateral
+    , rightJoin
+    , fullOuterJoin
+    , crossJoin
+    , crossJoinLateral
+
+      -- ** Set Operations
+      -- $sql-set-operations
+    , union_
+    , Union(..)
+    , unionAll_
+    , UnionAll(..)
+    , except_
+    , Except(..)
+    , intersect_
+    , Intersect(..)
+    , pattern SelectQuery
+
+      -- ** Common Table Expressions
+    , with
+    , withRecursive
+
+      -- ** Internals
+    , From(..)
+    , ToMaybe(..)
+    , ToAlias(..)
+    , ToAliasT
+    , ToAliasReference(..)
+    , ToAliasReferenceT
+    , ToSqlSetOperation(..)
+
+    -- * The Normal Stuff
+    , where_
+    , groupBy
+    , orderBy
+    , rand
+    , asc
+    , desc
+    , limit
+    , offset
+
+    , distinct
+    , distinctOn
+    , don
+    , distinctOnOrderBy
+    , having
+    , locking
+
+    , sub_select
+    , (^.)
+    , (?.)
+
+    , val
+    , isNothing
+    , just
+    , nothing
+    , joinV
+    , withNonNull
+
+    , countRows
+    , count
+    , countDistinct
+
+    , not_
+    , (==.)
+    , (>=.)
+    , (>.)
+    , (<=.)
+    , (<.)
+    , (!=.)
+    , (&&.)
+    , (||.)
+
+    , between
+    , (+.)
+    , (-.)
+    , (/.)
+    , (*.)
+
+    , random_
+    , round_
+    , ceiling_
+    , floor_
+
+    , min_
+    , max_
+    , sum_
+    , avg_
+    , castNum
+    , castNumM
+
+    , coalesce
+    , coalesceDefault
+
+    , lower_
+    , upper_
+    , trim_
+    , ltrim_
+    , rtrim_
+    , length_
+    , left_
+    , right_
+
+    , like
+    , ilike
+    , (%)
+    , concat_
+    , (++.)
+    , castString
+
+    , subList_select
+    , valList
+    , justList
+
+    , in_
+    , notIn
+    , exists
+    , notExists
+
+    , set
+    , (=.)
+    , (+=.)
+    , (-=.)
+    , (*=.)
+    , (/=.)
+
+    , case_
+    , toBaseId
+    , subSelect
+    , subSelectMaybe
+    , subSelectCount
+    , subSelectForeign
+    , subSelectList
+    , subSelectUnsafe
+    , ToBaseId(..)
+    , when_
+    , then_
+    , else_
+    , Value(..)
+    , ValueList(..)
+    , OrderBy
+    , DistinctOn
+    , LockingKind(..)
+    , SqlString
+
+      -- ** Joins
+    , InnerJoin(..)
+    , CrossJoin(..)
+    , LeftOuterJoin(..)
+    , RightOuterJoin(..)
+    , FullOuterJoin(..)
+    , JoinKind(..)
+    , OnClauseWithoutMatchingJoinException(..)
+
+      -- ** SQL backend
+    , SqlQuery
+    , SqlExpr
+    , SqlEntity
+    , select
+    , selectOne
+    , selectSource
+    , delete
+    , deleteCount
+    , update
+    , updateCount
+    , insertSelect
+    , insertSelectCount
+    , (<#)
+    , (<&>)
+
+    -- ** Rendering Queries
+    , renderQueryToText
+    , renderQuerySelect
+    , renderQueryUpdate
+    , renderQueryDelete
+    , renderQueryInsertInto
+
+    -- ** Helpers
+    , valkey
+    , valJ
+    , associateJoin
+
+      -- ** Re-exports
+      -- $reexports
+    , deleteKey
+    , module Database.Esqueleto.Internal.PersistentImport
+    ) where
+
+import Database.Esqueleto.Internal.Internal hiding (From, from, on)
+import Database.Esqueleto.Internal.PersistentImport
+
+import Database.Esqueleto.Experimental.From
+import Database.Esqueleto.Experimental.From.CommonTableExpression
+import Database.Esqueleto.Experimental.From.Join
+import Database.Esqueleto.Experimental.From.SqlSetOperation
+import Database.Esqueleto.Experimental.ToAlias
+import Database.Esqueleto.Experimental.ToAliasReference
+import Database.Esqueleto.Experimental.ToMaybe
+
+-- $setup
+--
+-- If you're already using "Database.Esqueleto", then you can get
+-- started using this module just by changing your imports slightly,
+-- as well as enabling the [TypeApplications](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#extension-TypeApplications) extension.
+--
+-- @
+-- {-\# LANGUAGE TypeApplications \#-}
+--
+-- ...
+--
+-- import Database.Esqueleto.Experimental
+-- @
+--
+-- Note: Prior to @esqueleto-3.3.4.0@, the @Database.Esqueleto.Experimental@
+-- module did not reexport @Data.Esqueleto@.
+
+----------------------------------------------------------------------
+
+-- $introduction
+--
+-- This module is fully backwards-compatible extension to the @esqueleto@
+-- EDSL that expands subquery functionality and enables
+-- [SQL set operations](https://en.wikipedia.org/wiki/Set_operations_(SQL\))
+-- to be written directly in Haskell. Specifically, this enables:
+--
+--   * Subqueries in 'JOIN' statements
+--   * 'UNION'
+--   * 'UNION' 'ALL'
+--   * 'INTERSECT'
+--   * 'EXCEPT'
+--
+-- As a consequence of this, several classes of runtime errors are now
+-- caught at compile time. This includes missing 'on' clauses and improper
+-- handling of @Maybe@ values in outer joins.
+--
+-- This module can be used in conjunction with the main "Database.Esqueleto"
+-- module, but doing so requires qualified imports to avoid ambiguous
+-- definitions of 'on' and 'from', which are defined in both modules.
+--
+-- Below we will give an overview of how to use this module and the
+-- features it enables.
+
+----------------------------------------------------------------------
+
+-- $new-syntax
+--
+-- This module introduces a new syntax that serves to enable the aforementioned
+-- features. This new syntax also changes how joins written in the @esqueleto@
+-- EDSL to more closely resemble the underlying SQL.
+--
+-- For our examples, we'll use a schema similar to the one in the Getting Started
+-- section of "Database.Esqueleto":
+--
+-- @
+-- share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persist|
+--   Person
+--     name String
+--     age Int Maybe
+--     deriving Eq Show
+--   BlogPost
+--     title String
+--     authorId PersonId
+--     deriving Eq Show
+--   Follow
+--     follower PersonId
+--     followed PersonId
+--     deriving Eq Show
+-- |]
+-- @
+--
+-- === Example 1: Simple select
+--
+-- Let's select all people who are named \"John\".
+--
+-- ==== "Database.Esqueleto":
+--
+-- @
+-- select $
+-- from $ \\people -> do
+-- where_ (people ^. PersonName ==. val \"John\")
+-- pure people
+-- @
+--
+-- ==== "Database.Esqueleto.Experimental":
+--
+-- @
+-- select $ do
+-- people <- from $ table \@Person
+-- where_ (people ^. PersonName ==. val \"John\")
+-- pure people
+-- @
+--
+--
+-- === Example 2: Select with join
+--
+-- Let's select all people and their blog posts who are over
+-- the age of 18.
+--
+-- ==== "Database.Esqueleto":
+--
+-- @
+-- select $
+-- from $ \\(people \`LeftOuterJoin\` blogPosts) -> do
+-- on (people ^. PersonId ==. blogPosts ?. BlogPostAuthorId)
+-- where_ (people ^. PersonAge >. val 18)
+-- pure (people, blogPosts)
+-- @
+--
+-- ==== "Database.Esqueleto.Experimental":
+--
+-- Here we use the ':&' operator to pattern match against the joined tables.
+--
+-- @
+-- select $ do
+-- (people :& blogPosts) <-
+--     from $ table \@Person
+--     \`leftJoin\` table \@BlogPost
+--     \`on\` (\\(people :& blogPosts) ->
+--             people ^. PersonId ==. blogPosts ?. BlogPostAuthorId)
+-- where_ (people ^. PersonAge >. val 18)
+-- pure (people, blogPosts)
+-- @
+--
+-- === Example 3: Select with multi-table join
+--
+-- Let's select all people who follow a person named \"John\", including
+-- the name of each follower.
+--
+-- ==== "Database.Esqueleto":
+--
+-- @
+-- select $
+-- from $ \\(
+--  people1
+--  \`InnerJoin\` followers
+--  \`InnerJoin\` people2
+-- ) -> do
+-- on (people1 ^. PersonId ==. followers ^. FollowFollowed)
+-- on (followers ^. FollowFollower ==. people2 ^. PersonId)
+-- where_ (people1 ^. PersonName ==. val \"John\")
+-- pure (followers, people2)
+-- @
+--
+-- ==== "Database.Esqueleto.Experimental":
+--
+-- In this version, with each successive 'on' clause, only the tables
+-- we have already joined into are in scope, so we must pattern match
+-- accordingly. In this case, in the second 'innerJoin', we do not use
+-- the first `Person` reference, so we use @_@ as a placeholder to
+-- ignore it. This prevents a possible runtime error where a table
+-- is referenced before it appears in the sequence of 'JOIN's.
+--
+-- @
+-- select $ do
+-- (people1 :& followers :& people2) <-
+--     from $ table \@Person
+--     \`innerJoin` table \@Follow
+--     \`on\` (\\(people1 :& followers) ->
+--             people1 ^. PersonId ==. followers ^. FollowFollowed)
+--     \`innerJoin` table \@Person
+--     \`on\` (\\(_ :& followers :& people2) ->
+--             followers ^. FollowFollower ==. people2 ^. PersonId)
+-- where_ (people1 ^. PersonName ==. val \"John\")
+-- pure (followers, people2)
+-- @
+--
+-- === Example 4: Counting results of a subquery
+--
+-- Let's count the number of people who have posted at least 10 posts
+--
+-- ==== "Database.Esqueleto":
+--
+-- @
+-- select $ pure $ subSelectCount $
+-- from $ \\(
+--   people
+--   \`InnerJoin\` blogPosts
+-- ) -> do
+-- on (people ^. PersonId ==. blogPosts ^. BlogPostAuthorId)
+-- groupBy (people ^. PersonId)
+-- having ((count $ blogPosts ^. BlogPostId) >. val 10)
+-- pure people
+-- @
+--
+-- ==== "Database.Esqueleto.Experimental":
+--
+-- @
+-- select $ do
+-- peopleWithPosts <-
+--   from $ do
+--     (people :& blogPosts) <-
+--       from $ table \@Person
+--       \`innerJoin\` table \@BlogPost
+--       \`on\` (\\(p :& bP) ->
+--               p ^. PersonId ==. bP ^. BlogPostAuthorId)
+--     groupBy (people ^. PersonId)
+--     having ((count $ blogPosts ^. BlogPostId) >. val 10)
+--     pure people
+-- pure $ count (peopleWithPosts ^. PersonId)
+-- @
+--
+-- We now have the ability to refactor this
+--
+-- === Example 5: Sorting the results of a UNION with limits
+--
+-- Out of all of the posts created by a person and the people they follow,
+-- generate a list of the first 25 posts, sorted alphabetically.
+--
+-- ==== "Database.Esqueleto":
+--
+-- Since 'UNION' is not supported, this requires using `Database.Esqueleto.rawSql`. (Not shown)
+--
+-- ==== "Database.Esqueleto.Experimental":
+--
+-- Since this module supports all set operations (see `SqlSetOperation`), we can use
+-- `Union` to write this query.
+--
+-- @
+-- select $ do
+-- (authors, blogPosts) <- from $
+--   (do
+--     (author :& blogPost) <-
+--       from $ table \@Person
+--       \`innerJoin\` table \@BlogPost
+--       \`on\` (\\(a :& bP) ->
+--               a ^. PersonId ==. bP ^. BlogPostAuthorId)
+--     where_ (author ^. PersonId ==. val currentPersonId)
+--     pure (author, blogPost)
+--   )
+--   \`union_\`
+--   (do
+--     (follow :& blogPost :& author) <-
+--       from $ table \@Follow
+--       \`innerJoin\` table \@BlogPost
+--       \`on\` (\\(f :& bP) ->
+--               f ^. FollowFollowed ==. bP ^. BlogPostAuthorId)
+--       \`innerJoin\` table \@Person
+--       \`on\` (\\(_ :& bP :& a) ->
+--               bP ^. BlogPostAuthorId ==. a ^. PersonId)
+--     where_ (follow ^. FollowFollower ==. val currentPersonId)
+--     pure (author, blogPost)
+--   )
+-- orderBy [ asc (blogPosts ^. BlogPostTitle) ]
+-- limit 25
+-- pure (authors, blogPosts)
+-- @
+--
+-- === Example 6: LATERAL JOIN
+--
+-- As of version @3.4.0.0@, lateral subquery joins are supported.
+--
+--
+-- @
+-- select $ do
+-- (salesPerson :& maxSaleAmount :& maxSaleCustomerName) <-
+--   from $ table \@SalesPerson
+--   \`crossJoinLateral\` (\\salesPerson -> do
+--         sales <- from $ table \@Sale
+--         where_ $ sales ^. SaleSalesPersonId ==. salesPerson ^. SalesPersonId
+--         pure $ max_ (sales ^. SaleAmount)
+--         )
+--   \`crossJoinLateral\` (\\(salesPerson :& maxSaleAmount) -> do
+--         sales <- from $ table \@Sale
+--         where_ $ sales ^. SaleSalesPersonId ==. salesPerson ^. SalesPersonId
+--              &&. sales ^. SaleAmount ==. maxSaleAmount
+--         pure $ sales ^. SaleCustomerName)
+--         )
+-- pure (salesPerson ^. SalesPersonName, maxSaleAmount, maxSaleCustomerName)
+-- @
+--
+-- This is the equivalent to the following SQL (example taken from the
+-- [MySQL Lateral Derived Table](https://dev.mysql.com/doc/refman/8.0/en/lateral-derived-tables.html)
+-- documentation):
+--
+-- @
+-- SELECT
+--   salesperson.name,
+--   max_sale.amount,
+--   max_sale_customer.customer_name
+-- FROM
+--   salesperson,
+--   -- calculate maximum size, cache it in transient derived table max_sale
+--   LATERAL
+--   (SELECT MAX(amount) AS amount
+--     FROM all_sales
+--     WHERE all_sales.salesperson_id = salesperson.id)
+--   AS max_sale,
+--   LATERAL
+--   (SELECT customer_name
+--     FROM all_sales
+--     WHERE all_sales.salesperson_id = salesperson.id
+--     AND all_sales.amount =
+--         -- the cached maximum size
+--         max_sale.amount)
+--   AS max_sale_customer;
+-- @
+
+-- $sql-set-operations
+--
+-- Data type that represents SQL set operations. This includes
+-- 'UNION', 'UNION' 'ALL', 'EXCEPT', and 'INTERSECT'. These types form
+-- a binary tree, with @SqlQuery@ values on the leaves.
+--
+-- Each function corresponding to the aforementioned set operations
+-- can be used as an infix in a @from@ to help with readability
+-- and lead to code that closely resembles the underlying SQL. For example,
+--
+-- @
+-- select $ from $
+--   (do
+--      a <- from $ table @A
+--      pure $ a ^. ASomeCol
+--   )
+--   \`union_\`
+--   (do
+--      b <- from $ table @B
+--      pure $ b ^. BSomeCol
+--   )
+-- @
+--
+-- is translated into
+--
+-- @
+-- SELECT * FROM (
+--   (SELECT a.some_col FROM a)
+--   UNION
+--   (SELECT b.some_col FROM b)
+-- )
+-- @
+--

src/Database/Esqueleto/Experimental/From.hs

@@ -0,0 +1,145 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Database.Esqueleto.Experimental.From
+    where
+
+import qualified Control.Monad.Trans.Writer as W
+import Data.Coerce (coerce)
+import Data.Proxy
+import qualified Data.Text.Lazy.Builder as TLB
+import Database.Esqueleto.Experimental.ToAlias
+import Database.Esqueleto.Experimental.ToAliasReference
+import Database.Esqueleto.Internal.Internal hiding (From(..), from, on)
+import Database.Esqueleto.Internal.PersistentImport
+
+import Database.Persist.Names (EntityNameDB(..))
+
+-- | 'FROM' clause, used to bring entities into scope.
+--
+-- Internally, this function uses the `From` datatype.
+-- Unlike the old `Database.Esqueleto.from`, this does not
+-- take a function as a parameter, but rather a value that
+-- represents a 'JOIN' tree constructed out of instances of `From`.
+-- This implementation eliminates certain
+-- types of runtime errors by preventing the construction of
+-- invalid SQL (e.g. illegal nested-@from@).
+from :: ToFrom a a' => a -> SqlQuery a'
+from f = do
+    (a, clause) <- unFrom (toFrom f)
+    Q $ W.tell mempty{sdFromClause=[FromRaw $ clause]}
+    pure a
+
+type RawFn = NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue])
+
+-- | Data type defining the "From" language. This should not
+-- constructed directly in application code.
+--
+-- A @From@ is a SqlQuery which returns a reference to the result of calling from
+-- and a function that produces a portion of a FROM clause. This gets passed to
+-- the FromRaw FromClause constructor directly when converting
+-- from a @From@ to a @SqlQuery@ using @from@
+--
+-- @since 3.5.0.0
+newtype From a = From
+    { unFrom :: SqlQuery (a, RawFn)}
+
+
+-- | A helper class primarily designed to allow using @SqlQuery@ directly in
+-- a From expression. This is also useful for embedding a @SqlSetOperation@,
+-- as well as supporting backwards compatibility for the
+-- data constructor join tree used prior to /3.5.0.0/
+--
+-- @since 3.5.0.0
+class ToFrom a r | a -> r where
+    toFrom :: a -> From r
+instance ToFrom (From a) a where
+    toFrom = id
+
+{-# DEPRECATED Table "@since 3.5.0.0 - use 'table' instead" #-}
+data Table a = Table
+
+instance PersistEntity ent => ToFrom (Table ent) (SqlExpr (Entity ent)) where
+    toFrom _ = table
+
+-- | Bring a PersistEntity into scope from a table
+--
+-- @
+-- select $ from $ table \@People
+-- @
+--
+-- @since 3.5.0.0
+table :: forall ent. PersistEntity ent => From (SqlExpr (Entity ent))
+table = From $ do
+    let ed = entityDef (Proxy @ent)
+    ident <- newIdentFor (coerce $ getEntityDBName ed)
+    let entity = unsafeSqlEntity ident
+    pure $ ( entity, const $ base ident ed )
+      where
+        base ident@(I identText) def info =
+            let db = coerce $ getEntityDBName def
+            in ( (fromDBName info (coerce db)) <>
+                     if  db == identText
+                     then mempty
+                     else " AS " <> useIdent info ident
+               , mempty
+               )
+
+
+{-# DEPRECATED SubQuery "/Since: 3.4.0.0/ - It is no longer necessary to tag 'SqlQuery' values with @SubQuery@" #-}
+newtype SubQuery a = SubQuery a
+instance (SqlSelect a r, ToAlias a, ToAliasReference a) => ToFrom (SubQuery (SqlQuery a)) a where
+    toFrom (SubQuery q) = selectQuery q
+instance (SqlSelect a r, ToAlias a, ToAliasReference a) => ToFrom (SqlQuery a) a where
+    toFrom = selectQuery
+
+-- | Select from a subquery, often used in conjuction with joins but can be
+-- used without any joins. Because @SqlQuery@ has a @ToFrom@ instance you probably
+-- dont need to use this function directly.
+--
+-- @
+-- select $
+--      p <- from $
+--              selectQuery do
+--              p <- from $ table \@Person
+--              limit 5
+--              orderBy [ asc p ^. PersonAge ]
+--      ...
+-- @
+--
+-- @since 3.5.0.0
+selectQuery :: (SqlSelect a r, ToAlias a, ToAliasReference a) => SqlQuery a -> From a
+selectQuery subquery = From $ do
+    -- We want to update the IdentState without writing the query to side data
+    (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ subquery
+    aliasedValue <- toAlias ret
+    -- Make a fake query with the aliased results, this allows us to ensure that the query is only run once
+    let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData)
+    -- Add the FromQuery that renders the subquery to our side data
+    subqueryAlias <- newIdentFor (DBName "q")
+    -- Pass the aliased results of the subquery to the outer query
+    -- create aliased references from the outer query results (e.g value from subquery will be `subquery`.`value`),
+    -- this is probably overkill as the aliases should already be unique but seems to be good practice.
+    ref <- toAliasReference subqueryAlias aliasedValue
+
+    pure (ref, \_ info ->
+            let (queryText,queryVals) = toRawSql SELECT info aliasedQuery
+            in
+            ( (parens queryText) <> " AS " <> useIdent info subqueryAlias
+            , queryVals
+            )
+         )

src/Database/Esqueleto/Experimental/From/CommonTableExpression.hs

@@ -0,0 +1,111 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Database.Esqueleto.Experimental.From.CommonTableExpression
+    where
+
+import qualified Control.Monad.Trans.Writer as W
+import qualified Data.Text.Lazy.Builder as TLB
+import Database.Esqueleto.Experimental.From
+import Database.Esqueleto.Experimental.From.SqlSetOperation
+import Database.Esqueleto.Experimental.ToAlias
+import Database.Esqueleto.Experimental.ToAliasReference
+import Database.Esqueleto.Internal.Internal hiding (From(..), from, on)
+
+-- | @WITH@ clause used to introduce a [Common Table Expression (CTE)](https://en.wikipedia.org/wiki/Hierarchical_and_recursive_queries_in_SQL#Common_table_expression).
+-- CTEs are supported in most modern SQL engines and can be useful
+-- in performance tuning. In Esqueleto, CTEs should be used as a
+-- subquery memoization tactic. When writing plain SQL, CTEs
+-- are sometimes used to organize the SQL code, in Esqueleto, this
+-- is better achieved through function that return 'SqlQuery' values.
+--
+-- @
+-- select $ do
+-- cte <- with subQuery
+-- cteResult <- from cte
+-- where_ $ cteResult ...
+-- pure cteResult
+-- @
+--
+-- __WARNING__: In some SQL engines using a CTE can diminish performance.
+-- In these engines the CTE is treated as an optimization fence. You should
+-- always verify that using a CTE will in fact improve your performance
+-- over a regular subquery.
+--
+-- /Since: 3.4.0.0/
+with :: ( ToAlias a
+        , ToAliasReference a
+        , SqlSelect a r
+        ) => SqlQuery a -> SqlQuery (From a)
+with query = do
+    (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ query
+    aliasedValue <- toAlias ret
+    let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData)
+    ident <- newIdentFor (DBName "cte")
+    let clause = CommonTableExpressionClause NormalCommonTableExpression ident (\info -> toRawSql SELECT info aliasedQuery)
+    Q $ W.tell mempty{sdCteClause = [clause]}
+    ref <- toAliasReference ident aliasedValue
+    pure $ From $ pure (ref, (\_ info -> (useIdent info ident, mempty)))
+
+-- | @WITH@ @RECURSIVE@ allows one to make a recursive subquery, which can
+-- reference itself. Like @WITH@, this is supported in most modern SQL engines.
+-- Useful for hierarchical, self-referential data, like a tree of data.
+--
+-- @
+-- select $ do
+-- cte <- withRecursive
+--          (do
+--              person <- from $ table \@Person
+--              where_ $ person ^. PersonId ==. val personId
+--              pure person
+--          )
+--          unionAll_
+--          (\\self -> do
+--              (p :& f :& p2 :& pSelf) <- from self
+--                       \`innerJoin\` $ table \@Follow
+--                       \`on\` (\\(p :& f) ->
+--                               p ^. PersonId ==. f ^. FollowFollower)
+--                       \`innerJoin\` $ table \@Person
+--                       \`on\` (\\(p :& f :& p2) ->
+--                               f ^. FollowFollowed ==. p2 ^. PersonId)
+--                       \`leftJoin\` self
+--                       \`on\` (\\(_ :& _ :& p2 :& pSelf) ->
+--                               just (p2 ^. PersonId) ==. pSelf ?. PersonId)
+--              where_ $ isNothing (pSelf ?. PersonId)
+--              groupBy (p2 ^. PersonId)
+--              pure p2
+--          )
+-- from cte
+-- @
+--
+-- /Since: 3.4.0.0/
+withRecursive :: ( ToAlias a
+                 , ToAliasReference a
+                 , SqlSelect a r
+                 )
+              => SqlQuery a
+              -> UnionKind
+              -> (From a -> SqlQuery a)
+              -> SqlQuery (From a)
+withRecursive baseCase unionKind recursiveCase = do
+    (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ baseCase
+    aliasedValue <- toAlias ret
+    let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData)
+    ident <- newIdentFor (DBName "cte")
+    ref <- toAliasReference ident aliasedValue
+    let refFrom = From (pure (ref, (\_ info -> (useIdent info ident, mempty))))
+    let recursiveQuery = recursiveCase refFrom
+    let clause = CommonTableExpressionClause RecursiveCommonTableExpression ident
+                 (\info -> (toRawSql SELECT info aliasedQuery)
+                        <> ("\n" <> (unUnionKind unionKind)  <> "\n", mempty)
+                        <> (toRawSql SELECT info recursiveQuery)
+                 )
+    Q $ W.tell mempty{sdCteClause = [clause]}
+    pure refFrom
+
+newtype UnionKind = UnionKind { unUnionKind :: TLB.Builder }
+instance Union_ UnionKind where
+    union_ = UnionKind "UNION"
+instance UnionAll_ UnionKind where
+    unionAll_ = UnionKind "UNION ALL"

src/Database/Esqueleto/Experimental/From/Join.hs

@@ -0,0 +1,425 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Database.Esqueleto.Experimental.From.Join
+    where
+
+import Data.Bifunctor (first)
+import Data.Kind (Constraint)
+import Data.Proxy
+import qualified Data.Text.Lazy.Builder as TLB
+import Database.Esqueleto.Experimental.From
+import Database.Esqueleto.Experimental.ToAlias
+import Database.Esqueleto.Experimental.ToAliasReference
+import Database.Esqueleto.Experimental.ToMaybe
+import Database.Esqueleto.Internal.Internal hiding
+       (From(..), from, fromJoin, on)
+import GHC.TypeLits
+
+-- | A left-precedence pair. Pronounced \"and\". Used to represent expressions
+-- that have been joined together.
+--
+-- The precedence behavior can be demonstrated by:
+--
+-- @
+-- a :& b :& c == ((a :& b) :& c)
+-- @
+--
+-- See the examples at the beginning of this module to see how this
+-- operator is used in 'JOIN' operations.
+data (:&) a b = a :& b
+infixl 2 :&
+
+instance (ToMaybe a, ToMaybe b) => ToMaybe (a :& b) where
+    type ToMaybeT (a :& b) = (ToMaybeT a :& ToMaybeT b)
+    toMaybe (a :& b) = (toMaybe a :& toMaybe b)
+
+class ValidOnClause a
+instance {-# OVERLAPPABLE #-} ToFrom a a' => ValidOnClause a
+instance ValidOnClause (a -> SqlQuery b)
+
+-- | You may return joined values from a 'select' query - this is
+-- identical to the tuple instance, but is provided for convenience.
+--
+-- @since 3.5.2.0
+instance (SqlSelect a ra, SqlSelect b rb) => SqlSelect (a :& b) (ra :& rb) where
+    sqlSelectCols esc (a :& b) = sqlSelectCols esc (a, b)
+    sqlSelectColCount = sqlSelectColCount . toTuple
+      where
+        toTuple :: Proxy (a :& b) -> Proxy (a, b)
+        toTuple = const Proxy
+    sqlSelectProcessRow = fmap (uncurry (:&)) . sqlSelectProcessRow
+
+-- | Identical to the tuple instance and provided for convenience.
+--
+-- @since 3.5.3.0
+instance (ToAlias a, ToAlias b) => ToAlias (a :& b) where
+    toAlias (a :& b) = (:&) <$> toAlias a <*> toAlias b
+
+-- | Identical to the tuple instance and provided for convenience.
+--
+-- @since 3.5.3.0
+instance (ToAliasReference a, ToAliasReference b) => ToAliasReference (a :& b) where
+    toAliasReference ident (a :& b) = (:&) <$> (toAliasReference ident a) <*> (toAliasReference ident b)
+
+-- | An @ON@ clause that describes how two tables are related. This should be
+-- used as an infix operator after a 'JOIN'. For example,
+--
+-- @
+-- select $
+-- from $ table \@Person
+-- \`innerJoin\` table \@BlogPost
+-- \`on\` (\\(p :& bP) ->
+--         p ^. PersonId ==. bP ^. BlogPostAuthorId)
+-- @
+on :: ValidOnClause a => a -> (b -> SqlExpr (Value Bool)) -> (a, b -> SqlExpr (Value Bool))
+on = (,)
+infix 9 `on`
+
+type family ErrorOnLateral a :: Constraint where
+  ErrorOnLateral (a -> SqlQuery b) = TypeError ('Text "LATERAL can only be used for INNER, LEFT, and CROSS join kinds.")
+  ErrorOnLateral _ = ()
+
+fromJoin :: TLB.Builder -> RawFn -> RawFn -> Maybe (SqlExpr (Value Bool)) -> RawFn
+fromJoin joinKind lhs rhs monClause =
+    \paren info ->
+        first (parensM paren) $
+        mconcat [ lhs Never info
+                , (joinKind, mempty)
+                , rhs Parens info
+                , maybe mempty (makeOnClause info) monClause
+                ]
+    where
+        makeOnClause info (ERaw _ f)        = first (" ON " <>) (f Never info)
+
+type family HasOnClause actual expected :: Constraint where
+    HasOnClause (a, b -> SqlExpr (Value Bool)) c = () -- Let the compiler handle the type mismatch
+    HasOnClause a expected =
+        TypeError ( 'Text "Missing ON clause for join with"
+                    ':$$: 'ShowType a
+                    ':$$: 'Text ""
+                    ':$$: 'Text "Expected: "
+                    ':$$: 'ShowType a
+                    ':$$: 'Text "`on` " ':<>: 'ShowType (expected -> SqlExpr (Value Bool))
+                    ':$$: 'Text ""
+                  )
+
+
+-- | INNER JOIN
+--
+-- Used as an infix operator \`innerJoin\`
+--
+-- @
+-- select $
+-- from $ table \@Person
+-- \`innerJoin\` table \@BlogPost
+-- \`on\` (\\(p :& bp) ->
+--         p ^. PersonId ==. bp ^. BlogPostAuthorId)
+-- @
+--
+-- @since 3.5.0.0
+innerJoin :: ( ToFrom a a'
+             , ToFrom b b'
+             , HasOnClause rhs (a' :& b')
+             , rhs ~ (b, (a' :& b') -> SqlExpr (Value Bool))
+             ) => a -> rhs -> From (a' :& b')
+innerJoin lhs (rhs, on') = From $ do
+     (leftVal, leftFrom) <- unFrom (toFrom lhs)
+     (rightVal, rightFrom) <- unFrom (toFrom rhs)
+     let ret = leftVal :& rightVal
+     pure $ (ret, fromJoin " INNER JOIN " leftFrom rightFrom (Just $ on' ret))
+
+
+-- | INNER JOIN LATERAL
+--
+-- A Lateral subquery join allows the joined query to reference entities from the
+-- left hand side of the join. Discards rows that don't match the on clause
+--
+-- Used as an infix operator \`innerJoinLateral\`
+--
+-- See example 6
+--
+-- @since 3.5.0.0
+innerJoinLateral :: ( ToFrom a a'
+                    , HasOnClause rhs (a' :& b)
+                    , SqlSelect b r
+                    , ToAlias b
+                    , ToAliasReference b
+                    , rhs ~ (a' -> SqlQuery b, (a' :& b) -> SqlExpr (Value Bool))
+                    )
+                 => a -> rhs -> From (a' :& b)
+innerJoinLateral lhs (rhsFn, on') = From $ do
+     (leftVal, leftFrom) <- unFrom (toFrom lhs)
+     (rightVal, rightFrom) <- unFrom (selectQuery (rhsFn leftVal))
+     let ret = leftVal :& rightVal
+     pure $ (ret, fromJoin " INNER JOIN LATERAL " leftFrom rightFrom (Just $ on' ret))
+
+-- | CROSS JOIN
+--
+-- Used as an infix \`crossJoin\`
+--
+-- @
+-- select $ do
+-- from $ table \@Person
+-- \`crossJoin\` table \@BlogPost
+-- @
+--
+-- @since 3.5.0.0
+crossJoin :: ( ToFrom a a'
+             , ToFrom b b'
+             ) => a -> b -> From (a' :& b')
+crossJoin lhs rhs = From $ do
+     (leftVal, leftFrom) <- unFrom (toFrom lhs)
+     (rightVal, rightFrom) <- unFrom (toFrom rhs)
+     let ret = leftVal :& rightVal
+     pure $ (ret, fromJoin " CROSS JOIN " leftFrom rightFrom Nothing)
+
+-- | CROSS JOIN LATERAL
+--
+-- A Lateral subquery join allows the joined query to reference entities from the
+-- left hand side of the join.
+--
+-- Used as an infix operator \`crossJoinLateral\`
+--
+-- See example 6
+--
+-- @since 3.5.0.0
+crossJoinLateral :: ( ToFrom a a'
+                    , SqlSelect b r
+                    , ToAlias b
+                    , ToAliasReference b
+                    )
+                 => a -> (a' -> SqlQuery b) -> From (a' :& b)
+crossJoinLateral lhs rhsFn = From $ do
+     (leftVal, leftFrom) <- unFrom (toFrom lhs)
+     (rightVal, rightFrom) <- unFrom (selectQuery (rhsFn leftVal))
+     let ret = leftVal :& rightVal
+     pure $ (ret, fromJoin " CROSS JOIN LATERAL " leftFrom rightFrom Nothing)
+
+-- | LEFT OUTER JOIN
+--
+-- Join where the right side may not exist.
+-- If the on clause fails then the right side will be NULL'ed
+-- Because of this the right side needs to be handled as a Maybe
+--
+-- Used as an infix operator \`leftJoin\`
+--
+-- @
+-- select $
+-- from $ table \@Person
+-- \`leftJoin\` table \@BlogPost
+-- \`on\` (\\(p :& bp) ->
+--         p ^. PersonId ==. bp ?. BlogPostAuthorId)
+-- @
+--
+-- @since 3.5.0.0
+leftJoin :: ( ToFrom a a'
+            , ToFrom b b'
+            , ToMaybe b'
+            , HasOnClause rhs (a' :& ToMaybeT b')
+            , rhs ~ (b, (a' :& ToMaybeT b') -> SqlExpr (Value Bool))
+            ) => a -> rhs -> From (a' :& ToMaybeT b')
+leftJoin lhs (rhs, on') = From $ do
+     (leftVal, leftFrom) <- unFrom (toFrom lhs)
+     (rightVal, rightFrom) <- unFrom (toFrom rhs)
+     let ret = leftVal :& toMaybe rightVal
+     pure $ (ret, fromJoin " LEFT OUTER JOIN " leftFrom rightFrom (Just $ on' ret))
+
+-- | LEFT OUTER JOIN LATERAL
+--
+-- Lateral join where the right side may not exist.
+-- In the case that the query returns nothing or the on clause fails the right
+-- side of the join will be NULL'ed
+-- Because of this the right side needs to be handled as a Maybe
+--
+-- Used as an infix operator \`leftJoinLateral\`
+--
+-- See example 6 for how to use LATERAL
+--
+-- @since 3.5.0.0
+leftJoinLateral :: ( ToFrom a a'
+                   , SqlSelect b r
+                   , HasOnClause rhs (a' :& ToMaybeT b)
+                   , ToAlias b
+                   , ToAliasReference b
+                   , ToMaybe b
+                   , rhs ~ (a' -> SqlQuery b, (a' :& ToMaybeT b) -> SqlExpr (Value Bool))
+                   )
+                 => a -> rhs -> From (a' :& ToMaybeT b)
+leftJoinLateral lhs (rhsFn, on') = From $ do
+     (leftVal, leftFrom) <- unFrom (toFrom lhs)
+     (rightVal, rightFrom) <- unFrom (selectQuery (rhsFn leftVal))
+     let ret = leftVal :& toMaybe rightVal
+     pure $ (ret, fromJoin " LEFT OUTER JOIN LATERAL " leftFrom rightFrom (Just $ on' ret))
+
+-- | RIGHT OUTER JOIN
+--
+-- Join where the left side may not exist.
+-- If the on clause fails then the left side will be NULL'ed
+-- Because of this the left side needs to be handled as a Maybe
+--
+-- Used as an infix operator \`rightJoin\`
+--
+-- @
+-- select $
+-- from $ table \@Person
+-- \`rightJoin\` table \@BlogPost
+-- \`on\` (\\(p :& bp) ->
+--         p ?. PersonId ==. bp ^. BlogPostAuthorId)
+-- @
+--
+-- @since 3.5.0.0
+rightJoin :: ( ToFrom a a'
+             , ToFrom b b'
+             , ToMaybe a'
+             , HasOnClause rhs (ToMaybeT a' :& b')
+             , rhs ~ (b, (ToMaybeT a' :& b') -> SqlExpr (Value Bool))
+             ) => a -> rhs -> From (ToMaybeT a' :& b')
+rightJoin lhs (rhs, on') = From $ do
+     (leftVal, leftFrom) <- unFrom (toFrom lhs)
+     (rightVal, rightFrom) <- unFrom (toFrom rhs)
+     let ret = toMaybe leftVal :& rightVal
+     pure $ (ret, fromJoin " RIGHT OUTER JOIN " leftFrom rightFrom (Just $ on' ret))
+
+-- | FULL OUTER JOIN
+--
+-- Join where both sides of the join may not exist.
+-- Because of this the result needs to be handled as a Maybe
+--
+-- Used as an infix operator \`fullOuterJoin\`
+--
+-- @
+-- select $
+-- from $ table \@Person
+-- \`fullOuterJoin\` table \@BlogPost
+-- \`on\` (\\(p :& bp) ->
+--         p ?. PersonId ==. bp ?. BlogPostAuthorId)
+-- @
+--
+-- @since 3.5.0.0
+fullOuterJoin :: ( ToFrom a a'
+                 , ToFrom b b'
+                 , ToMaybe a'
+                 , ToMaybe b'
+                 , HasOnClause rhs (ToMaybeT a' :& ToMaybeT b')
+                 , rhs ~ (b, (ToMaybeT a' :& ToMaybeT b') -> SqlExpr (Value Bool))
+                 ) => a -> rhs -> From (ToMaybeT a' :& ToMaybeT b')
+fullOuterJoin lhs (rhs, on') = From $ do
+     (leftVal, leftFrom) <- unFrom (toFrom lhs)
+     (rightVal, rightFrom) <- unFrom (toFrom rhs)
+     let ret = toMaybe leftVal :& toMaybe rightVal
+     pure $ (ret, fromJoin " FULL OUTER JOIN " leftFrom rightFrom (Just $ on' ret))
+
+infixl 2 `innerJoin`,
+         `innerJoinLateral`,
+         `leftJoin`,
+         `leftJoinLateral`,
+         `crossJoin`,
+         `crossJoinLateral`,
+         `rightJoin`,
+         `fullOuterJoin`
+
+
+------ Compatibility for old syntax
+
+data Lateral
+data NotLateral
+
+type family IsLateral a where
+    IsLateral (a -> SqlQuery b, c) = Lateral
+    IsLateral (a -> SqlQuery b) = Lateral
+    IsLateral a = NotLateral
+
+class DoInnerJoin lateral lhs rhs res | lateral rhs lhs -> res where
+    doInnerJoin :: Proxy lateral -> lhs -> rhs -> From res
+
+instance ( ToFrom a a'
+         , ToFrom b b'
+         , HasOnClause rhs (a' :& b')
+         , rhs ~ (b, (a' :& b') -> SqlExpr (Value Bool))
+         ) => DoInnerJoin NotLateral a rhs (a' :& b') where
+    doInnerJoin _ = innerJoin
+
+instance ( ToFrom a a'
+         , SqlSelect b r
+         , ToAlias b
+         , ToAliasReference b
+         , d ~ (a' :& b)
+         ) => DoInnerJoin Lateral a (a' -> SqlQuery b, d -> SqlExpr (Value Bool)) d where
+    doInnerJoin _ = innerJoinLateral
+
+instance ( DoInnerJoin lateral lhs rhs r, lateral ~ IsLateral rhs )
+           => ToFrom (InnerJoin lhs rhs) r where
+     toFrom (InnerJoin a b) = doInnerJoin (Proxy @lateral) a b
+
+class DoLeftJoin lateral lhs rhs res | lateral rhs lhs -> res where
+    doLeftJoin :: Proxy lateral -> lhs -> rhs -> From res
+
+instance ( ToFrom a a'
+         , ToFrom b b'
+         , ToMaybe b'
+         , ToMaybeT b' ~ mb
+         , HasOnClause rhs (a' :& mb)
+         , rhs ~ (b, (a' :& mb) -> SqlExpr (Value Bool))
+         ) => DoLeftJoin NotLateral a rhs (a' :& mb) where
+    doLeftJoin _ = leftJoin
+
+instance ( ToFrom a a'
+         , ToMaybe b
+         , d ~ (a' :& ToMaybeT b)
+         , SqlSelect b r
+         , ToAlias b
+         , ToAliasReference b
+         ) => DoLeftJoin Lateral a (a' -> SqlQuery b, d -> SqlExpr (Value Bool)) d where
+    doLeftJoin _ = leftJoinLateral
+
+instance ( DoLeftJoin lateral lhs rhs r, lateral ~ IsLateral rhs )
+           => ToFrom (LeftOuterJoin lhs rhs) r where
+     toFrom (LeftOuterJoin a b) = doLeftJoin (Proxy @lateral) a b
+
+class DoCrossJoin lateral lhs rhs res | lateral lhs rhs -> res where
+    doCrossJoin :: Proxy lateral -> lhs -> rhs -> From res
+
+instance (ToFrom a a', ToFrom b b') => DoCrossJoin NotLateral a b (a' :& b') where
+    doCrossJoin _ = crossJoin
+instance (ToFrom a a', SqlSelect b r, ToAlias b, ToAliasReference b)
+  => DoCrossJoin Lateral a (a' -> SqlQuery b) (a' :& b) where
+    doCrossJoin _ = crossJoinLateral
+
+instance (DoCrossJoin lateral lhs rhs r, IsLateral rhs ~ lateral)
+  => ToFrom (CrossJoin lhs rhs) r where
+    toFrom (CrossJoin a b) = doCrossJoin (Proxy @lateral) a b
+
+instance ( ToFrom a a'
+         , ToFrom b b'
+         , ToMaybe a'
+         , ToMaybeT a' ~ ma
+         , HasOnClause rhs (ma :& b')
+         , ErrorOnLateral b
+         , rhs ~ (b, (ma :& b') -> SqlExpr (Value Bool))
+         ) => ToFrom (RightOuterJoin a rhs) (ma :& b') where
+    toFrom (RightOuterJoin a b) = rightJoin a b
+
+instance ( ToFrom a a'
+         , ToFrom b b'
+         , ToMaybe a'
+         , ToMaybeT a' ~ ma
+         , ToMaybe b'
+         , ToMaybeT b' ~ mb
+         , HasOnClause rhs (ma :& mb)
+         , ErrorOnLateral b
+         , rhs ~ (b, (ma :& mb) -> SqlExpr (Value Bool))
+         ) => ToFrom (FullOuterJoin a rhs) (ma :& mb) where
+    toFrom (FullOuterJoin a b) = fullOuterJoin a b
+

src/Database/Esqueleto/Experimental/From/SqlSetOperation.hs

@@ -0,0 +1,130 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Database.Esqueleto.Experimental.From.SqlSetOperation
+        where
+
+import Control.Arrow (first)
+import Control.Monad.Trans.Class (lift)
+import qualified Control.Monad.Trans.State as S
+import qualified Control.Monad.Trans.Writer as W
+import qualified Data.Text.Lazy.Builder as TLB
+import Database.Esqueleto.Experimental.From
+import Database.Esqueleto.Experimental.ToAlias
+import Database.Esqueleto.Experimental.ToAliasReference
+import Database.Esqueleto.Internal.Internal hiding (From(..), from, on)
+import Database.Esqueleto.Internal.PersistentImport (PersistValue)
+
+-- | Data type used to implement the SqlSetOperation language
+-- this type is implemented in the same way as a @From@
+--
+-- Semantically a @SqlSetOperation@ is always a @From@ but not vice versa
+--
+-- @since 3.5.0.0
+newtype SqlSetOperation a = SqlSetOperation
+    { unSqlSetOperation :: NeedParens -> SqlQuery (a, IdentInfo -> (TLB.Builder, [PersistValue]))}
+
+instance ToAliasReference a => ToFrom (SqlSetOperation a) a where
+    toFrom setOperation = From $ do
+        ident <- newIdentFor (DBName "u")
+        (a, fromClause) <- unSqlSetOperation setOperation Never
+        ref <- toAliasReference ident a
+        pure (ref, \_ info -> (first parens $ fromClause info) <> (" AS " <> useIdent info ident, mempty))
+
+-- | Type class to support direct use of @SqlQuery@ in a set operation tree
+--
+-- @since 3.5.0.0
+class ToSqlSetOperation a r | a -> r where
+    toSqlSetOperation :: a -> SqlSetOperation r
+instance ToSqlSetOperation (SqlSetOperation a) a where
+    toSqlSetOperation = id
+instance (SqlSelect a r, ToAlias a, ToAliasReference a) => ToSqlSetOperation (SqlQuery a) a where
+    toSqlSetOperation subquery =
+        SqlSetOperation $ \p -> do
+            (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ subquery
+            state <- Q $ lift S.get
+            aliasedValue <- toAlias ret
+            Q $ lift $ S.put state
+            let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData)
+            let p' =
+                  case p of
+                    Parens -> Parens
+                    Never ->
+                      if (sdLimitClause sideData) /= mempty
+                          || length (sdOrderByClause sideData) > 0 then
+                        Parens
+                      else
+                        Never
+            pure (aliasedValue, \info -> first (parensM p') $ toRawSql SELECT info aliasedQuery)
+
+-- | Helper function for defining set operations
+-- @since 3.5.0.0
+mkSetOperation :: (ToSqlSetOperation a a', ToSqlSetOperation b a')
+               => TLB.Builder -> a -> b -> SqlSetOperation a'
+mkSetOperation operation lhs rhs = SqlSetOperation $ \p -> do
+    (leftValue, leftClause) <- unSqlSetOperation (toSqlSetOperation lhs) p
+    (_, rightClause) <- unSqlSetOperation (toSqlSetOperation rhs) p
+    pure (leftValue, \info -> leftClause info <> (operation, mempty) <> rightClause info)
+
+{-# DEPRECATED Union "/Since: 3.4.0.0/ - Use the 'union_' function instead of the 'Union' data constructor" #-}
+data Union a b = a `Union` b
+instance ToSqlSetOperation a a' => ToSqlSetOperation (Union a a) a' where
+    toSqlSetOperation (Union a b) = union_ a b
+
+-- | Overloaded @union_@ function to support use in both 'SqlSetOperation'
+-- and 'withRecursive'
+--
+-- @since 3.5.0.0
+class Union_ a where
+    -- | @UNION@ SQL set operation. Can be used as an infix function between 'SqlQuery' values.
+    union_ :: a
+
+instance (ToSqlSetOperation a c, ToSqlSetOperation b c, res ~ SqlSetOperation c)
+  => Union_ (a -> b -> res) where
+    union_ = mkSetOperation " UNION "
+
+-- | Overloaded @unionAll_@ function to support use in both 'SqlSetOperation'
+-- and 'withRecursive'
+--
+-- @since 3.5.0.0
+class UnionAll_ a where
+    -- | @UNION@ @ALL@ SQL set operation. Can be used as an infix function between 'SqlQuery' values.
+    unionAll_ :: a
+instance (ToSqlSetOperation a c, ToSqlSetOperation b c, res ~ SqlSetOperation c)
+  => UnionAll_ (a -> b -> res) where
+    unionAll_ = mkSetOperation " UNION ALL "
+
+{-# DEPRECATED UnionAll "/Since: 3.4.0.0/ - Use the 'unionAll_' function instead of the 'UnionAll' data constructor" #-}
+data UnionAll a b = a `UnionAll` b
+instance ToSqlSetOperation a a' => ToSqlSetOperation (UnionAll a a) a' where
+    toSqlSetOperation (UnionAll a b) = unionAll_ a b
+
+{-# DEPRECATED Except "/Since: 3.4.0.0/ - Use the 'except_' function instead of the 'Except' data constructor" #-}
+data Except a b = a `Except` b
+instance ToSqlSetOperation a a' => ToSqlSetOperation (Except a a) a' where
+    toSqlSetOperation (Except a b) = except_ a b
+
+-- | @EXCEPT@ SQL set operation. Can be used as an infix function between 'SqlQuery' values.
+except_ :: (ToSqlSetOperation a a', ToSqlSetOperation b a') => a -> b -> SqlSetOperation a'
+except_ = mkSetOperation " EXCEPT "
+
+{-# DEPRECATED Intersect "/Since: 3.4.0.0/ - Use the 'intersect_' function instead of the 'Intersect' data constructor" #-}
+data Intersect a b = a `Intersect` b
+instance ToSqlSetOperation a a' => ToSqlSetOperation (Intersect a a) a' where
+    toSqlSetOperation (Intersect a b) = intersect_ a b
+
+-- | @INTERSECT@ SQL set operation. Can be used as an infix function between 'SqlQuery' values.
+intersect_ :: (ToSqlSetOperation a a', ToSqlSetOperation b a') => a -> b -> SqlSetOperation a'
+intersect_ = mkSetOperation " INTERSECT "
+
+{-# DEPRECATED SelectQuery "/Since: 3.4.0.0/ - It is no longer necessary to tag 'SqlQuery' values with @SelectQuery@" #-}
+pattern SelectQuery a = a
+

src/Database/Esqueleto/Experimental/ToAlias.hs

@@ -0,0 +1,92 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Database.Esqueleto.Experimental.ToAlias
+    where
+
+import Database.Esqueleto.Internal.Internal hiding (From, from, on)
+import Database.Esqueleto.Internal.PersistentImport
+
+{-# DEPRECATED ToAliasT "This type alias doesn't do anything. Please delete it. Will be removed in the next release." #-}
+type ToAliasT a = a
+
+-- Tedious tuple magic
+class ToAlias a where
+    toAlias :: a -> SqlQuery a
+
+instance ToAlias (SqlExpr (Value a)) where
+    toAlias e@(ERaw m f)
+      | Just _ <- sqlExprMetaAlias m = pure e
+      | otherwise = do
+            ident <- newIdentFor (DBName "v")
+            pure $ ERaw noMeta{sqlExprMetaAlias = Just ident} f
+
+instance ToAlias (SqlExpr (Entity a)) where
+    toAlias e@(ERaw m f)
+      | Just _ <- sqlExprMetaAlias m = pure e
+      | otherwise = do
+           ident <- newIdentFor (DBName "v")
+           pure $ ERaw m{sqlExprMetaIsReference = False, sqlExprMetaAlias = Just ident} f
+
+instance ToAlias (SqlExpr (Maybe (Entity a))) where
+    -- FIXME: Code duplication because the compiler doesnt like half final encoding
+    toAlias e@(ERaw m f)
+      | Just _ <- sqlExprMetaAlias m = pure e
+      | otherwise = do
+           ident <- newIdentFor (DBName "v")
+           pure $ ERaw m{sqlExprMetaIsReference = False, sqlExprMetaAlias = Just ident} f
+
+instance (ToAlias a, ToAlias b) => ToAlias (a,b) where
+    toAlias (a,b) = (,) <$> toAlias a <*> toAlias b
+
+instance ( ToAlias a
+         , ToAlias b
+         , ToAlias c
+         ) => ToAlias (a,b,c) where
+    toAlias x = to3 <$> (toAlias $ from3 x)
+
+instance ( ToAlias a
+         , ToAlias b
+         , ToAlias c
+         , ToAlias d
+         ) => ToAlias (a,b,c,d) where
+    toAlias x = to4 <$> (toAlias $ from4 x)
+
+instance ( ToAlias a
+         , ToAlias b
+         , ToAlias c
+         , ToAlias d
+         , ToAlias e
+         ) => ToAlias (a,b,c,d,e) where
+    toAlias x = to5 <$> (toAlias $ from5 x)
+
+instance ( ToAlias a
+         , ToAlias b
+         , ToAlias c
+         , ToAlias d
+         , ToAlias e
+         , ToAlias f
+         ) => ToAlias (a,b,c,d,e,f) where
+    toAlias x = to6 <$> (toAlias $ from6 x)
+
+instance ( ToAlias a
+         , ToAlias b
+         , ToAlias c
+         , ToAlias d
+         , ToAlias e
+         , ToAlias f
+         , ToAlias g
+         ) => ToAlias (a,b,c,d,e,f,g) where
+    toAlias x = to7 <$> (toAlias $ from7 x)
+
+instance ( ToAlias a
+         , ToAlias b
+         , ToAlias c
+         , ToAlias d
+         , ToAlias e
+         , ToAlias f
+         , ToAlias g
+         , ToAlias h
+         ) => ToAlias (a,b,c,d,e,f,g,h) where
+    toAlias x = to8 <$> (toAlias $ from8 x)

src/Database/Esqueleto/Experimental/ToAliasReference.hs

@@ -0,0 +1,90 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Database.Esqueleto.Experimental.ToAliasReference
+    where
+
+import Data.Coerce
+import Database.Esqueleto.Internal.Internal hiding (From, from, on)
+import Database.Esqueleto.Internal.PersistentImport
+
+{-# DEPRECATED ToAliasReferenceT "This type alias doesn't do anything. Please delete it. Will be removed in the next release." #-}
+type ToAliasReferenceT a = a
+
+-- more tedious tuple magic
+class ToAliasReference a where
+    toAliasReference :: Ident -> a -> SqlQuery a
+
+instance ToAliasReference (SqlExpr (Value a)) where
+    toAliasReference aliasSource (ERaw m _)
+      | Just alias <- sqlExprMetaAlias m = pure $ ERaw m{sqlExprMetaIsReference = True} $ \_ info ->
+          (useIdent info aliasSource <> "." <> useIdent info alias, [])
+    toAliasReference _ e = pure e
+
+instance ToAliasReference (SqlExpr (Entity a)) where
+    toAliasReference aliasSource (ERaw m _)
+      | Just _ <- sqlExprMetaAlias m =
+          pure $ ERaw m{sqlExprMetaIsReference = True} $ \_ info ->
+            (useIdent info aliasSource, [])
+    toAliasReference _ e = pure e
+
+instance ToAliasReference (SqlExpr (Maybe (Entity a))) where
+    toAliasReference aliasSource e =
+        coerce <$> toAliasReference aliasSource (coerce e :: SqlExpr (Entity a))
+
+
+instance (ToAliasReference a, ToAliasReference b) => ToAliasReference (a, b) where
+    toAliasReference ident (a,b) = (,) <$> (toAliasReference ident a) <*> (toAliasReference ident b)
+
+instance ( ToAliasReference a
+         , ToAliasReference b
+         , ToAliasReference c
+         ) => ToAliasReference (a,b,c) where
+    toAliasReference ident x = fmap to3 $ toAliasReference ident $ from3 x
+
+instance ( ToAliasReference a
+         , ToAliasReference b
+         , ToAliasReference c
+         , ToAliasReference d
+         ) => ToAliasReference (a,b,c,d) where
+    toAliasReference ident x = fmap to4 $ toAliasReference ident $ from4 x
+
+instance ( ToAliasReference a
+         , ToAliasReference b
+         , ToAliasReference c
+         , ToAliasReference d
+         , ToAliasReference e
+         ) => ToAliasReference (a,b,c,d,e) where
+    toAliasReference ident x = fmap to5 $ toAliasReference ident $ from5 x
+
+instance ( ToAliasReference a
+         , ToAliasReference b
+         , ToAliasReference c
+         , ToAliasReference d
+         , ToAliasReference e
+         , ToAliasReference f
+         ) => ToAliasReference (a,b,c,d,e,f) where
+    toAliasReference ident x = to6 <$> (toAliasReference ident $ from6 x)
+
+instance ( ToAliasReference a
+         , ToAliasReference b
+         , ToAliasReference c
+         , ToAliasReference d
+         , ToAliasReference e
+         , ToAliasReference f
+         , ToAliasReference g
+         ) => ToAliasReference (a,b,c,d,e,f,g) where
+    toAliasReference ident x = to7 <$> (toAliasReference ident $ from7 x)
+
+instance ( ToAliasReference a
+         , ToAliasReference b
+         , ToAliasReference c
+         , ToAliasReference d
+         , ToAliasReference e
+         , ToAliasReference f
+         , ToAliasReference g
+         , ToAliasReference h
+         ) => ToAliasReference (a,b,c,d,e,f,g,h) where
+    toAliasReference ident x = to8 <$> (toAliasReference ident $ from8 x)
+

src/Database/Esqueleto/Experimental/ToMaybe.hs

@@ -0,0 +1,79 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Database.Esqueleto.Experimental.ToMaybe
+    where
+
+import Database.Esqueleto.Internal.Internal hiding (From(..), from, on)
+import Database.Esqueleto.Internal.PersistentImport (Entity(..))
+
+type family Nullable a where
+    Nullable (Maybe a) = a
+    Nullable a =  a
+
+class ToMaybe a where
+    type ToMaybeT a
+    toMaybe :: a -> ToMaybeT a
+
+instance ToMaybe (SqlExpr (Maybe a)) where
+    type ToMaybeT (SqlExpr (Maybe a)) = SqlExpr (Maybe a)
+    toMaybe = id
+
+instance ToMaybe (SqlExpr (Entity a)) where
+    type ToMaybeT (SqlExpr (Entity a)) = SqlExpr (Maybe (Entity a))
+    toMaybe (ERaw f m) = (ERaw f m)
+
+instance ToMaybe (SqlExpr (Value a)) where
+    type ToMaybeT (SqlExpr (Value a)) = SqlExpr (Value (Maybe (Nullable a)))
+    toMaybe = veryUnsafeCoerceSqlExprValue
+
+
+instance (ToMaybe a, ToMaybe b) => ToMaybe (a,b) where
+    type ToMaybeT (a, b) = (ToMaybeT a, ToMaybeT b)
+    toMaybe (a, b) = (toMaybe a, toMaybe b)
+
+instance ( ToMaybe a , ToMaybe b , ToMaybe c) => ToMaybe (a,b,c) where
+    type ToMaybeT (a, b, c) = (ToMaybeT a, ToMaybeT b, ToMaybeT c)
+    toMaybe = to3 . toMaybe . from3
+
+instance ( ToMaybe a , ToMaybe b , ToMaybe c , ToMaybe d) => ToMaybe (a,b,c,d) where
+    type ToMaybeT (a, b, c, d) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d)
+    toMaybe = to4 . toMaybe . from4
+
+instance ( ToMaybe a , ToMaybe b , ToMaybe c , ToMaybe d , ToMaybe e) => ToMaybe (a,b,c,d,e) where
+    type ToMaybeT (a, b, c, d, e) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d, ToMaybeT e)
+    toMaybe = to5 . toMaybe . from5
+
+instance ( ToMaybe a
+         , ToMaybe b
+         , ToMaybe c
+         , ToMaybe d
+         , ToMaybe e
+         , ToMaybe f
+         ) => ToMaybe (a,b,c,d,e,f) where
+    type ToMaybeT (a, b, c, d, e, f) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d, ToMaybeT e, ToMaybeT f)
+    toMaybe = to6 . toMaybe . from6
+
+instance ( ToMaybe a
+         , ToMaybe b
+         , ToMaybe c
+         , ToMaybe d
+         , ToMaybe e
+         , ToMaybe f
+         , ToMaybe g
+         ) => ToMaybe (a,b,c,d,e,f,g) where
+    type ToMaybeT (a, b, c, d, e, f, g) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d, ToMaybeT e, ToMaybeT f, ToMaybeT g)
+    toMaybe = to7 . toMaybe . from7
+
+instance ( ToMaybe a
+         , ToMaybe b
+         , ToMaybe c
+         , ToMaybe d
+         , ToMaybe e
+         , ToMaybe f
+         , ToMaybe g
+         , ToMaybe h
+         ) => ToMaybe (a,b,c,d,e,f,g,h) where
+     type ToMaybeT (a, b, c, d, e, f, g, h) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d, ToMaybeT e, ToMaybeT f, ToMaybeT g, ToMaybeT h)
+     toMaybe = to8 . toMaybe . from8
+

src/Database/Esqueleto/Internal/ExprParser.hs

@@ -0,0 +1,83 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+-- | This is an internal module. This module may have breaking changes without
+-- a corresponding major version bump. If you use this module, please open an
+-- issue with your use-case so we can safely support it.
+module Database.Esqueleto.Internal.ExprParser where
+
+import Prelude hiding (takeWhile)
+
+import Control.Applicative ((<|>))
+import Control.Monad (void)
+import Data.Attoparsec.Text
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Text (Text)
+import qualified Data.Text as Text
+import Database.Persist.Sql
+import Database.Persist.SqlBackend
+
+-- | A type representing the access of a table value. In Esqueleto, we get
+-- a guarantee that the access will look something like:
+--
+-- @
+-- escape-char [character] escape-char . escape-char [character] escape-char
+--             ^^^^^^^^^^^                           ^^^^^^^^^^^
+--             table name                            column name
+-- @
+data TableAccess = TableAccess
+    { tableAccessTable  :: Text
+    , tableAccessColumn :: Text
+    }
+    deriving (Eq, Ord, Show)
+
+-- | Parse a @SqlExpr (Value Bool)@'s textual representation into a list of
+-- 'TableAccess'
+parseOnExpr :: SqlBackend -> Text -> Either String (Set TableAccess)
+parseOnExpr sqlBackend text = do
+    c <- mkEscapeChar sqlBackend
+    parseOnly (onExpr c) text
+
+-- | This function uses the 'connEscapeName' function in the 'SqlBackend' with an
+-- empty identifier to pull out an escape character. This implementation works
+-- with postgresql, mysql, and sqlite backends.
+mkEscapeChar :: SqlBackend -> Either String Char
+mkEscapeChar sqlBackend =
+    case Text.uncons (getEscapedRawName "" sqlBackend) of
+        Nothing ->
+            Left "Failed to get an escape character from the SQL backend."
+        Just (c, _) ->
+            Right c
+
+type ExprParser a = Char -> Parser a
+
+onExpr :: ExprParser (Set TableAccess)
+onExpr e = Set.fromList <$> many' tableAccesses
+  where
+    tableAccesses = do
+        skipToEscape e <?> "Skipping to an escape char"
+        parseTableAccess e <?> "Parsing a table access"
+
+skipToEscape :: ExprParser ()
+skipToEscape escapeChar = void (takeWhile (/= escapeChar))
+
+parseEscapedIdentifier :: ExprParser [Char]
+parseEscapedIdentifier escapeChar = do
+    _ <- char escapeChar
+    str <- parseEscapedChars escapeChar
+    _ <- char escapeChar
+    pure str
+
+parseTableAccess :: ExprParser TableAccess
+parseTableAccess ec = do
+    tableAccessTable <- Text.pack <$> parseEscapedIdentifier ec
+    _ <- char '.'
+    tableAccessColumn <- Text.pack <$> parseEscapedIdentifier ec
+    pure TableAccess {..}
+
+parseEscapedChars :: ExprParser [Char]
+parseEscapedChars escapeChar = go
+  where
+    twoEscapes = char escapeChar *> char escapeChar
+    go = many' (notChar escapeChar <|> twoEscapes)

src/Database/Esqueleto/Internal/PersistentImport.hs

@@ -1,13 +1,177 @@
 -- | Re-export "Database.Persist.Sql" without any clashes with
 -- @esqueleto@.
 module Database.Esqueleto.Internal.PersistentImport
-  ( module Database.Persist.Sql
+-- NOTE: switch back to a module export once https://gitlab.haskell.org/ghc/ghc/merge_requests/276
-  ) where
+-- has been merged. See https://github.com/bitemyapp/esqueleto/issues/110 for more details
+    ( toJsonText
+    , entityIdFromJSON
+    , entityIdToJSON
+    , entityValues
+    , fromPersistValueJSON
+    , keyValueEntityFromJSON
+    , keyValueEntityToJSON
+    , toPersistValueJSON
+    , selectKeys
+    , belongsTo
+    , belongsToJust
+    , getEntity
+    , getJust
+    , getJustEntity
+    , insertEntity
+    , insertRecord
+    , liftPersist
+    , checkUnique
+    , getByValue
+    , insertBy
+    , insertUniqueEntity
+    , onlyUnique
+    , replaceUnique
+    , transactionSave
+    , transactionUndo
+    , defaultAttribute
+    , mkColumns
+    , getMigration
+    , migrate
+    , parseMigration
+    , parseMigration'
+    , printMigration
+    , runMigration
+    , runMigrationSilent
+    , runMigrationUnsafe
+    , showMigration
+    , decorateSQLWithLimitOffset
+    , fieldDBName
+    , fromSqlKey
+    , getFieldName
+    , getTableName
+    , tableDBName
+    , toSqlKey
+    , withRawQuery
+    , getStmtConn
+    , rawExecute
+    , rawExecuteCount
+    , rawQuery
+    , rawQueryRes
+    , rawSql
+    , close'
+    , createSqlPool
+    , liftSqlPersistMPool
+    , runSqlConn
+    , runSqlPersistM
+    , runSqlPersistMPool
+    , runSqlPool
+    , withSqlConn
+    , withSqlPool
+    , readToUnknown
+    , readToWrite
+    , writeToUnknown
+    , getEntityKeyFields
+    , entityPrimary
+    , keyAndEntityFields
+    , PersistStore
+    , PersistUnique
+    , DeleteCascade(..)
+    , PersistConfig(..)
+    , BackendSpecificUpdate
+    , Entity(..)
+    , PersistEntity(..)
+    , PersistField(..)
+    , SomePersistField(..)
+    , PersistQueryRead(..)
+    , PersistQueryWrite(..)
+    , BackendCompatible(..)
+    , BackendKey(..)
+    , HasPersistBackend(..)
+    , IsPersistBackend
+    , PersistCore(..)
+    , PersistRecordBackend
+    , PersistStoreRead(..)
+    , PersistStoreWrite(..)
+    , ToBackendKey(..)
+    , PersistUniqueRead(..)
+    , PersistUniqueWrite(..)
+    , PersistFieldSql(..)
+    , RawSql(..)
+    , CautiousMigration
+    , Column(..)
+    , ConnectionPool
+    , Migration
+    , PersistentSqlException(..)
+    , Single(..)
+    , Sql
+    , SqlPersistM
+    , SqlPersistT
+    , InsertSqlResult(..)
+    , IsSqlBackend
+    , LogFunc
+    , SqlBackend
+    , SqlBackendCanRead
+    , SqlBackendCanWrite
+    , SqlReadBackend(..)
+    , SqlReadT
+    , SqlWriteBackend(..)
+    , SqlWriteT
+    , Statement(..)
+    , Attr
+    , Checkmark(..)
+    , CompositeDef(..)
+    , EmbedEntityDef(..)
+    , EmbedFieldDef(..)
+    , EntityDef
+    , EntityIdDef(..)
+    , ExtraLine
+    , FieldDef(..)
+    , FieldType(..)
+    , ForeignDef(..)
+    , ForeignFieldDef
+    , IsNullable(..)
+    , PersistException(..)
+    , PersistFilter(..)
+    , PersistUpdate(..)
+    , PersistValue(..)
+    , ReferenceDef(..)
+    , SqlType(..)
+    , UniqueDef(..)
+    , UpdateException(..)
+    , WhyNullable(..)
+    , getEntityFields
+    , getEntityId
+    , getEntityDBName
+    , getEntityUniques
+    ) where
 
 import Database.Persist.Sql hiding
-  ( BackendSpecificFilter, Filter(..), PersistQuery, SelectOpt(..)
+       ( BackendSpecificFilter
-  , Update(..), delete, deleteWhereCount, updateWhereCount, selectList
+       , Filter(..)
-  , selectKeysList, deleteCascadeWhere, (=.), (+=.), (-=.), (*=.), (/=.)
+       , PersistQuery
-  , (==.), (!=.), (<.), (>.), (<=.), (>=.), (<-.), (/<-.), (||.)
+       , SelectOpt(..)
-  , listToJSON, mapToJSON, getPersistMap, limitOffsetOrder, selectSource
+       , Update(..)
-  , update , count )
+       , count
+       , delete
+       , deleteCascadeWhere
+       , deleteWhereCount
+       , exists
+       , getPersistMap
+       , limitOffsetOrder
+       , listToJSON
+       , mapToJSON
+       , selectKeysList
+       , selectList
+       , selectSource
+       , update
+       , updateWhereCount
+       , (!=.)
+       , (*=.)
+       , (+=.)
+       , (-=.)
+       , (/<-.)
+       , (/=.)
+       , (<-.)
+       , (<.)
+       , (<=.)
+       , (=.)
+       , (==.)
+       , (>.)
+       , (>=.)
+       , (||.)
+       )

src/Database/Esqueleto/Legacy.hs

@@ -0,0 +1,416 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
+
+-- | WARNING
+--
+-- This module is introduced in version @3.5.0.0@ to provide a smooth migration
+-- experience from this legacy syntax to the new and improved syntax. If you've
+-- imported this module, it means you've decided to use the old syntax for
+-- a little bit longer, rather than migrate to the new stuff. That's fine!
+--
+-- But you should know that this module, and all of the legacy syntax, will be
+-- completely removed from the library in version @4.0.0.0@.
+--
+-- The @esqueleto@ EDSL (embedded domain specific language).
+-- This module replaces @Database.Persist@, so instead of
+-- importing that module you should just import this one:
+--
+-- @
+-- -- For a module using just esqueleto.
+-- import Database.Esqueleto
+-- @
+--
+-- If you need to use @persistent@'s default support for queries
+-- as well, either import it qualified:
+--
+-- @
+-- -- For a module that mostly uses esqueleto.
+-- import Database.Esqueleto
+-- import qualified Database.Persist as P
+-- @
+--
+-- or import @esqueleto@ itself qualified:
+--
+-- @
+-- -- For a module that uses esqueleto just on some queries.
+-- import Database.Persist
+-- import qualified Database.Esqueleto as E
+-- @
+--
+-- Other than identifier name clashes, @esqueleto@ does not
+-- conflict with @persistent@ in any way.
+module Database.Esqueleto.Legacy
+  ( -- * Setup
+    -- $setup
+
+    -- * Introduction
+    -- $introduction
+
+    -- * Getting started
+    -- $gettingstarted
+
+    -- * @esqueleto@'s Language
+    where_, on, groupBy, orderBy, rand, asc, desc, limit, offset
+             , distinct, distinctOn, don, distinctOnOrderBy, having, locking
+             , sub_select, (^.), (?.)
+             , val, isNothing, just, nothing, joinV, withNonNull
+             , countRows, count, countDistinct
+             , not_, (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.)
+             , between, (+.), (-.), (/.), (*.)
+             , random_, round_, ceiling_, floor_
+             , min_, max_, sum_, avg_, castNum, castNumM
+             , coalesce, coalesceDefault
+             , lower_, upper_, trim_, ltrim_, rtrim_, length_, left_, right_
+             , like, ilike, (%), concat_, (++.), castString
+             , subList_select, valList, justList
+             , in_, notIn, exists, notExists
+             , set, (=.), (+=.), (-=.), (*=.), (/=.)
+             , case_, toBaseId
+  , subSelect
+  , subSelectMaybe
+  , subSelectCount
+  , subSelectForeign
+  , subSelectList
+  , subSelectUnsafe
+  , ToBaseId(..)
+  , when_
+  , then_
+  , else_
+  , from
+  , Value(..)
+  , ValueList(..)
+  , OrderBy
+  , DistinctOn
+  , LockingKind(..)
+  , SqlString
+    -- ** Joins
+  , InnerJoin(..)
+  , CrossJoin(..)
+  , LeftOuterJoin(..)
+  , RightOuterJoin(..)
+  , FullOuterJoin(..)
+  , JoinKind(..)
+  , OnClauseWithoutMatchingJoinException(..)
+    -- * SQL backend
+  , SqlQuery
+  , SqlExpr
+  , SqlEntity
+  , select
+  , selectOne
+  , selectSource
+  , delete
+  , deleteCount
+  , update
+  , updateCount
+  , insertSelect
+  , insertSelectCount
+  , (<#)
+  , (<&>)
+  -- ** Rendering Queries
+  , renderQueryToText
+  , renderQuerySelect
+  , renderQueryUpdate
+  , renderQueryDelete
+  , renderQueryInsertInto
+    -- * Internal.Language
+  , From
+    -- * RDBMS-specific modules
+    -- $rdbmsSpecificModules
+
+    -- * Helpers
+  , valkey
+  , valJ
+  , associateJoin
+
+    -- * Re-exports
+    -- $reexports
+  , deleteKey
+  , module Database.Esqueleto.Internal.PersistentImport
+  ) where
+
+import Database.Esqueleto.Internal.Internal
+import Database.Esqueleto.Internal.PersistentImport
+
+
+-- $setup
+--
+-- If you're already using @persistent@, then you're ready to use
+-- @esqueleto@, no further setup is needed.  If you're just
+-- starting a new project and would like to use @esqueleto@, take
+-- a look at @persistent@'s book first
+-- (<http://www.yesodweb.com/book/persistent>) to learn how to
+-- define your schema.
+
+
+----------------------------------------------------------------------
+
+
+-- $introduction
+--
+-- The main goals of @esqueleto@ are to:
+--
+--   * Be easily translatable to SQL.  When you take a look at a
+--   @esqueleto@ query, you should be able to know exactly how
+--   the SQL query will end up.  (As opposed to being a
+--   relational algebra EDSL such as HaskellDB, which is
+--   non-trivial to translate into SQL.)
+--
+--   * Support the most widely used SQL features.  We'd like you to be
+--   able to use @esqueleto@ for all of your queries, no
+--   exceptions.  Send a pull request or open an issue on our
+--   project page (<https://github.com/prowdsponsor/esqueleto>) if
+--   there's anything missing that you'd like to see.
+--
+--   * Be as type-safe as possible.  We strive to provide as many
+--   type checks as possible.  If you get bitten by some invalid
+--   code that type-checks, please open an issue on our project
+--   page so we can take a look.
+--
+-- However, it is /not/ a goal to be able to write portable SQL.
+-- We do not try to hide the differences between DBMSs from you,
+-- and @esqueleto@ code that works for one database may not work
+-- on another.  This is a compromise we have to make in order to
+-- give you as much control over the raw SQL as possible without
+-- losing too much convenience.  This also means that you may
+-- type-check a query that doesn't work on your DBMS.
+
+
+----------------------------------------------------------------------
+
+
+-- $gettingstarted
+--
+-- We like clean, easy-to-read EDSLs.  However, in order to
+-- achieve this goal we've used a lot of type hackery, leading to
+-- some hard-to-read type signatures.  On this section, we'll try
+-- to build some intuition about the syntax.
+--
+-- For the following examples, we'll use this example schema:
+--
+-- @
+-- share [mkPersist sqlSettings, mkMigrate \"migrateAll\"] [persist|
+--   Person
+--     name String
+--     age Int Maybe
+--     deriving Eq Show
+--   BlogPost
+--     title String
+--     authorId PersonId
+--     deriving Eq Show
+--   Follow
+--     follower PersonId
+--     followed PersonId
+--     deriving Eq Show
+-- |]
+-- @
+--
+-- Most of @esqueleto@ was created with @SELECT@ statements in
+-- mind, not only because they're the most common but also
+-- because they're the most complex kind of statement.  The most
+-- simple kind of @SELECT@ would be:
+--
+-- @
+-- SELECT *
+-- FROM Person
+-- @
+--
+-- In @esqueleto@, we may write the same query above as:
+--
+-- @
+-- do people <- 'select' $
+--              'from' $ \\person -> do
+--              return person
+--    liftIO $ mapM_ (putStrLn . personName . entityVal) people
+-- @
+--
+-- The expression above has type @SqlPersist m ()@, while
+-- @people@ has type @[Entity Person]@.  The query above will be
+-- translated into exactly the same query we wrote manually, but
+-- instead of @SELECT *@ it will list all entity fields (using
+-- @*@ is not robust).  Note that @esqueleto@ knows that we want
+-- an @Entity Person@ just because of the @personName@ that we're
+-- printing later.
+--
+-- However, most of the time we need to filter our queries using
+-- @WHERE@.  For example:
+--
+-- @
+-- SELECT *
+-- FROM Person
+-- WHERE Person.name = \"John\"
+-- @
+--
+-- In @esqueleto@, we may write the same query above as:
+--
+-- @
+-- 'select' $
+-- 'from' $ \\p -> do
+-- 'where_' (p '^.' PersonName '==.' 'val' \"John\")
+-- return p
+-- @
+--
+-- Although @esqueleto@'s code is a bit more noisy, it's has
+-- almost the same structure (save from the @return@).  The
+-- @('^.')@ operator is used to project a field from an entity.
+-- The field name is the same one generated by @persistent@'s
+-- Template Haskell functions.  We use 'val' to lift a constant
+-- Haskell value into the SQL query.
+--
+-- Another example would be:
+--
+-- @
+-- SELECT *
+-- FROM Person
+-- WHERE Person.age >= 18
+-- @
+--
+-- In @esqueleto@, we may write the same query above as:
+--
+-- @
+-- 'select' $
+-- 'from' $ \\p -> do
+-- 'where_' (p '^.' PersonAge '>=.' 'just' ('val' 18))
+-- return p
+-- @
+--
+-- Since @age@ is an optional @Person@ field, we use 'just' to lift
+-- @'val' 18 :: SqlExpr (Value Int)@ into @just ('val' 18) ::
+-- SqlExpr (Value (Maybe Int))@.
+--
+-- Implicit joins are represented by tuples.  For example, to get
+-- the list of all blog posts and their authors, we could write:
+--
+-- @
+-- SELECT BlogPost.*, Person.*
+-- FROM BlogPost, Person
+-- WHERE BlogPost.authorId = Person.id
+-- ORDER BY BlogPost.title ASC
+-- @
+--
+-- In @esqueleto@, we may write the same query above as:
+--
+-- @
+-- 'select' $
+-- 'from' $ \\(b, p) -> do
+-- 'where_' (b '^.' BlogPostAuthorId '==.' p '^.' PersonId)
+-- 'orderBy' ['asc' (b '^.' BlogPostTitle)]
+-- return (b, p)
+-- @
+--
+-- However, you may want your results to include people who don't
+-- have any blog posts as well using a @LEFT OUTER JOIN@:
+--
+-- @
+-- SELECT Person.*, BlogPost.*
+-- FROM Person LEFT OUTER JOIN BlogPost
+-- ON Person.id = BlogPost.authorId
+-- ORDER BY Person.name ASC, BlogPost.title ASC
+-- @
+--
+-- In @esqueleto@, we may write the same query above as:
+--
+-- @
+-- 'select' $
+-- 'from' $ \\(p `'LeftOuterJoin`` mb) -> do
+-- 'on' ('just' (p '^.' PersonId) '==.' mb '?.' BlogPostAuthorId)
+-- 'orderBy' ['asc' (p '^.' PersonName), 'asc' (mb '?.' BlogPostTitle)]
+-- return (p, mb)
+-- @
+--
+-- On a @LEFT OUTER JOIN@ the entity on the right hand side may
+-- not exist (i.e. there may be a @Person@ without any
+-- @BlogPost@s), so while @p :: SqlExpr (Entity Person)@, we have
+-- @mb :: SqlExpr (Maybe (Entity BlogPost))@.  The whole
+-- expression above has type @SqlPersist m [(Entity Person, Maybe
+-- (Entity BlogPost))]@.  Instead of using @(^.)@, we used
+-- @('?.')@ to project a field from a @Maybe (Entity a)@.
+--
+-- We are by no means limited to joins of two tables, nor by
+-- joins of different tables.  For example, we may want a list
+-- of the @Follow@ entity:
+--
+-- @
+-- SELECT P1.*, Follow.*, P2.*
+-- FROM Person AS P1
+-- INNER JOIN Follow ON P1.id = Follow.follower
+-- INNER JOIN Person AS P2 ON P2.id = Follow.followed
+-- @
+--
+-- In @esqueleto@, we may write the same query above as:
+--
+-- @
+-- 'select' $
+-- 'from' $ \\(p1 `'InnerJoin`` f `'InnerJoin`` p2) -> do
+-- 'on' (p1 '^.' PersonId '==.' f '^.' FollowFollower)
+-- 'on' (p2 '^.' PersonId '==.' f '^.' FollowFollowed)
+-- return (p1, f, p2)
+-- @
+--
+-- We also currently support @UPDATE@ and @DELETE@ statements.
+-- For example:
+--
+-- @
+-- do 'update' $ \\p -> do
+--      'set' p [ PersonName '=.' 'val' \"João\" ]
+--      'where_' (p '^.' PersonName '==.' 'val' \"Joao\")
+--    'delete' $
+--      'from' $ \\p -> do
+--      'where_' (p '^.' PersonAge '<.' 'just' ('val' 14))
+-- @
+--
+-- The results of queries can also be used for insertions.
+-- In @SQL@, we might write the following, inserting a new blog
+-- post for every user:
+--
+-- @
+-- INSERT INTO BlogPost
+-- SELECT ('Group Blog Post', id)
+-- FROM Person
+-- @
+--
+-- In @esqueleto@, we may write the same query above as:
+--
+-- @
+--  'insertSelect' $ 'from' $ \\p->
+--  return $ BlogPost '<#' \"Group Blog Post\" '<&>' (p '^.' PersonId)
+-- @
+--
+-- Individual insertions can be performed through Persistent's
+-- 'insert' function, reexported for convenience.
+
+
+----------------------------------------------------------------------
+
+
+-- $reexports
+--
+-- We re-export many symbols from @persistent@ for convenince:
+--
+--  * \"Store functions\" from "Database.Persist".
+--
+--  * Everything from "Database.Persist.Class" except for
+--    @PersistQuery@ and @delete@ (use 'deleteKey' instead).
+--
+--  * Everything from "Database.Persist.Types" except for
+--    @Update@, @SelectOpt@, @BackendSpecificFilter@ and @Filter@.
+--
+--  * Everything from "Database.Persist.Sql" except for
+--    @deleteWhereCount@ and @updateWhereCount@.
+
+
+----------------------------------------------------------------------
+
+
+-- $rdbmsSpecificModules
+--
+-- There are many differences between SQL syntax and functions
+-- supported by different RDBMSs.  Since version 2.2.8,
+-- @esqueleto@ includes modules containing functions that are
+-- specific to a given RDBMS.
+--
+--  * PostgreSQL: "Database.Esqueleto.PostgreSQL".
+--
+-- In order to use these functions, you need to explicitly import
+-- their corresponding modules, they're not re-exported here.

src/Database/Esqueleto/MySQL.hs

@@ -0,0 +1,18 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | This module contain MySQL-specific functions.
+--
+-- @since 2.2.8
+module Database.Esqueleto.MySQL
+    ( random_
+    ) where
+
+import Database.Esqueleto.Internal.Internal hiding (random_)
+import Database.Esqueleto.Internal.PersistentImport
+
+-- | (@random()@) Split out into database specific modules
+-- because MySQL uses `rand()`.
+--
+-- /Since: 2.6.0/
+random_ :: (PersistField a, Num a) => SqlExpr (Value a)
+random_ = unsafeSqlValue "RAND()"

src/Database/Esqueleto/PostgreSQL.hs

@@ -1,40 +1,438 @@
-{-# LANGUAGE OverloadedStrings
+{-# LANGUAGE CPP #-}
- #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
 -- | This module contain PostgreSQL-specific functions.
 --
--- /Since: 2.2.8/
+-- @since: 2.2.8
 module Database.Esqueleto.PostgreSQL
-  ( arrayAgg
+    ( AggMode(..)
-  , stringAgg
+    , arrayAggDistinct
-  , chr
+    , arrayAgg
-  ) where
+    , arrayAggWith
+    , arrayRemove
+    , arrayRemoveNull
+    , stringAgg
+    , stringAggWith
+    , maybeArray
+    , chr
+    , now_
+    , random_
+    , upsert
+    , upsertBy
+    , insertSelectWithConflict
+    , insertSelectWithConflictCount
+    , filterWhere
+    , values
+    -- * Internal
+    , unsafeSqlAggregateFunction
+    ) where
 
-import Database.Esqueleto.Internal.Language
+#if __GLASGOW_HASKELL__ < 804
-import Database.Esqueleto.Internal.Sql
+import Data.Semigroup
+#endif
+import Control.Arrow (first)
+import Control.Exception (throw)
+import Control.Monad (void)
+import Control.Monad.IO.Class (MonadIO(..))
+import qualified Control.Monad.Trans.Reader as R
+import Data.Int (Int64)
+import qualified Data.List.NonEmpty as NE
+import Data.Maybe
+import Data.Proxy (Proxy(..))
+import qualified Data.Text.Internal.Builder as TLB
+import qualified Data.Text.Lazy as TL
+import Data.Time.Clock (UTCTime)
+import qualified Database.Esqueleto.Experimental as Ex
+import qualified Database.Esqueleto.Experimental.From as Ex
+import Database.Esqueleto.Internal.Internal hiding (random_)
+import Database.Esqueleto.Internal.PersistentImport hiding (upsert, upsertBy)
+import Database.Persist.Class (OnlyOneUniqueKey)
+import Database.Persist (ConstraintNameDB(..), EntityNameDB(..))
+import Database.Persist.SqlBackend
 
-
+-- | (@random()@) Split out into database specific modules
--- | (@array_agg@) Concatenate input values, including @NULL@s,
+-- because MySQL uses `rand()`.
--- into an array.
 --
--- /Since: 2.2.8/
+-- @since 2.6.0
-arrayAgg :: SqlExpr (Value a) -> SqlExpr (Value [a])
+random_ :: (PersistField a, Num a) => SqlExpr (Value a)
-arrayAgg = unsafeSqlFunction "array_agg"
+random_ = unsafeSqlValue "RANDOM()"
+
+-- | Empty array literal. (@val []@) does unfortunately not work
+emptyArray :: SqlExpr (Value [a])
+emptyArray = unsafeSqlValue "'{}'"
+
+-- | Coalesce an array with an empty default value
+maybeArray ::
+     (PersistField a, PersistField [a])
+  => SqlExpr (Value (Maybe [a]))
+  -> SqlExpr (Value [a])
+maybeArray x = coalesceDefault [x] (emptyArray)
+
+-- | Aggregate mode
+data AggMode
+    = AggModeAll -- ^ ALL
+    | AggModeDistinct -- ^ DISTINCT
+    deriving (Show)
+
+-- | (Internal) Create a custom aggregate functions with aggregate mode
+--
+-- /Do/ /not/ use this function directly, instead define a new function and give
+-- it a type (see `unsafeSqlBinOp`)
+unsafeSqlAggregateFunction
+    :: UnsafeSqlFunctionArgument a
+    => TLB.Builder
+    -> AggMode
+    -> a
+    -> [OrderByClause]
+    -> SqlExpr (Value b)
+unsafeSqlAggregateFunction name mode args orderByClauses = ERaw noMeta $ \_ info ->
+    let (orderTLB, orderVals) = makeOrderByNoNewline info orderByClauses
+        -- Don't add a space if we don't have order by clauses
+        orderTLBSpace =
+            case orderByClauses of
+                []    -> ""
+                (_:_) -> " "
+        (argsTLB, argsVals) =
+            uncommas' $ map (\(ERaw _ f) -> f Never info) $ toArgList args
+        aggMode =
+            case mode of
+                AggModeAll      -> ""
+                -- ALL is the default, so we don't need to
+                -- specify it
+                AggModeDistinct -> "DISTINCT "
+    in ( name <> parens (aggMode <> argsTLB <> orderTLBSpace <> orderTLB)
+       , argsVals <> orderVals
+       )
+
+--- | (@array_agg@) Concatenate input values, including @NULL@s,
+--- into an array.
+arrayAggWith
+    :: AggMode
+    -> SqlExpr (Value a)
+    -> [OrderByClause]
+    -> SqlExpr (Value (Maybe [a]))
+arrayAggWith = unsafeSqlAggregateFunction "array_agg"
+
+--- | (@array_agg@) Concatenate input values, including @NULL@s,
+--- into an array.
+arrayAgg :: (PersistField a) => SqlExpr (Value a) -> SqlExpr (Value (Maybe [a]))
+arrayAgg x = arrayAggWith AggModeAll x []
+
+-- | (@array_agg@) Concatenate distinct input values, including @NULL@s, into
+-- an array.
+--
+-- @since 2.5.3
+arrayAggDistinct
+    :: (PersistField a, PersistField [a])
+    => SqlExpr (Value a)
+    -> SqlExpr (Value (Maybe [a]))
+arrayAggDistinct x = arrayAggWith AggModeDistinct x []
+
+-- | (@array_remove@) Remove all elements equal to the given value from the
+-- array.
+--
+-- @since 2.5.3
+arrayRemove :: SqlExpr (Value [a]) -> SqlExpr (Value a) -> SqlExpr (Value [a])
+arrayRemove arr elem' = unsafeSqlFunction "array_remove" (arr, elem')
+
+-- | Remove @NULL@ values from an array
+arrayRemoveNull :: SqlExpr (Value [Maybe a]) -> SqlExpr (Value [a])
+-- This can't be a call to arrayRemove because it changes the value type
+arrayRemoveNull x = unsafeSqlFunction "array_remove" (x, unsafeSqlValue "NULL")
+
+
+-- | (@string_agg@) Concatenate input values separated by a
+-- delimiter.
+stringAggWith ::
+     SqlString s
+  => AggMode -- ^ Aggregate mode (ALL or DISTINCT)
+  -> SqlExpr (Value s) -- ^ Input values.
+  -> SqlExpr (Value s) -- ^ Delimiter.
+  -> [OrderByClause] -- ^ ORDER BY clauses
+  -> SqlExpr (Value (Maybe s)) -- ^ Concatenation.
+stringAggWith mode expr delim os =
+  unsafeSqlAggregateFunction "string_agg" mode (expr, delim) os
 
 -- | (@string_agg@) Concatenate input values separated by a
 -- delimiter.
 --
--- /Since: 2.2.8/
+-- @since 2.2.8
-stringAgg
+stringAgg ::
-  :: SqlString s
+     SqlString s
   => SqlExpr (Value s) -- ^ Input values.
   -> SqlExpr (Value s) -- ^ Delimiter.
-  -> SqlExpr (Value s) -- ^ Concatenation.
+  -> SqlExpr (Value (Maybe s)) -- ^ Concatenation.
-stringAgg expr delim = unsafeSqlFunction "string_agg" (expr, delim)
+stringAgg expr delim = stringAggWith AggModeAll expr delim []
-
 
 -- | (@chr@) Translate the given integer to a character. (Note the result will
 -- depend on the character set of your database.)
 --
--- /Since: 2.2.11/
+-- @since 2.2.11
 chr :: SqlString s => SqlExpr (Value Int) -> SqlExpr (Value s)
 chr = unsafeSqlFunction "chr"
+
+now_ :: SqlExpr (Value UTCTime)
+now_ = unsafeSqlFunction "NOW" ()
+
+upsert
+    ::
+    ( MonadIO m
+    , PersistEntity record
+    , OnlyOneUniqueKey record
+    , PersistRecordBackend record SqlBackend
+    , IsPersistBackend (PersistEntityBackend record)
+    )
+    => record
+    -- ^ new record to insert
+    -> [SqlExpr (Entity record) -> SqlExpr Update]
+    -- ^ updates to perform if the record already exists
+    -> R.ReaderT SqlBackend m (Entity record)
+    -- ^ the record in the database after the operation
+upsert record updates = do
+    uniqueKey <- onlyUnique record
+    upsertBy uniqueKey record updates
+
+upsertBy
+    ::
+    (MonadIO m
+    , PersistEntity record
+    , IsPersistBackend (PersistEntityBackend record)
+    )
+    => Unique record
+    -- ^ uniqueness constraint to find by
+    -> record
+    -- ^ new record to insert
+    -> [SqlExpr (Entity record) -> SqlExpr Update]
+    -- ^ updates to perform if the record already exists
+    -> R.ReaderT SqlBackend m (Entity record)
+    -- ^ the record in the database after the operation
+upsertBy uniqueKey record updates = do
+    sqlB <- R.ask
+    case getConnUpsertSql sqlB of
+        Nothing ->
+            -- Postgres backend should have connUpsertSql, if this error is
+            -- thrown, check changes on persistent
+            throw (UnexpectedCaseErr OperationNotSupported)
+        Just upsertSql ->
+            handler sqlB upsertSql
+  where
+    addVals l = map toPersistValue (toPersistFields record) ++ l ++ persistUniqueToValues uniqueKey
+    entDef = entityDef (Just record)
+    updatesText conn = first builderToText $ renderUpdates conn updates
+#if MIN_VERSION_persistent(2,11,0)
+    uniqueFields = persistUniqueToFieldNames uniqueKey
+    handler sqlB upsertSql = do
+        let (updateText, updateVals) =
+                updatesText sqlB
+            queryText =
+                upsertSql entDef uniqueFields updateText
+            queryVals =
+                addVals updateVals
+        xs <- rawSql queryText queryVals
+        pure (head xs)
+#else
+    uDef = toUniqueDef uniqueKey
+    handler conn f = fmap head $ uncurry rawSql $
+        (***) (f entDef (uDef :| [])) addVals $ updatesText conn
+#endif
+
+-- | Inserts into a table the results of a query similar to 'insertSelect' but allows
+-- to update values that violate a constraint during insertions.
+--
+-- Example of usage:
+--
+-- @
+-- share [ mkPersist sqlSettings
+--       , mkDeleteCascade sqlSettings
+--       , mkMigrate "migrate"
+--       ] [persistLowerCase|
+--   Bar
+--     num Int
+--     deriving Eq Show
+--   Foo
+--     num Int
+--     UniqueFoo num
+--     deriving Eq Show
+-- |]
+--
+-- insertSelectWithConflict
+--   UniqueFoo -- (UniqueFoo undefined) or (UniqueFoo anyNumber) would also work
+--   (from $ \b ->
+--     return $ Foo <# (b ^. BarNum)
+--   )
+--   (\current excluded ->
+--     [FooNum =. (current ^. FooNum) +. (excluded ^. FooNum)]
+--   )
+-- @
+--
+-- Inserts to table Foo all Bar.num values and in case of conflict SomeFooUnique,
+-- the conflicting value is updated to the current plus the excluded.
+--
+-- @since 3.1.3
+insertSelectWithConflict
+    :: forall a m val
+     . (FinalResult a, KnowResult a ~ Unique val, MonadIO m, PersistEntity val)
+    => a
+    -- ^ Unique constructor or a unique, this is used just to get the name of
+    -- the postgres constraint, the value(s) is(are) never used, so if you have
+    -- a unique "MyUnique 0", "MyUnique undefined" would work as well.
+    -> SqlQuery (SqlExpr (Insertion val))
+    -- ^ Insert query.
+    -> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Entity val) -> SqlExpr Update])
+    -- ^ A list of updates to be applied in case of the constraint being
+    -- violated. The expression takes the current and excluded value to produce
+    -- the updates.
+    -> SqlWriteT m ()
+insertSelectWithConflict unique query a =
+    void $ insertSelectWithConflictCount unique query a
+
+-- | Same as 'insertSelectWithConflict' but returns the number of rows affected.
+--
+-- @since 3.1.3
+insertSelectWithConflictCount
+    :: forall a val m
+     . (FinalResult a, KnowResult a ~ Unique val, MonadIO m, PersistEntity val)
+    => a
+    -> SqlQuery (SqlExpr (Insertion val))
+    -> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Entity val) -> SqlExpr Update])
+    -> SqlWriteT m Int64
+insertSelectWithConflictCount unique query conflictQuery = do
+    conn <- R.ask
+    uncurry rawExecuteCount $
+        combine
+            (toRawSql INSERT_INTO (conn, initialIdentState) query)
+            (conflict conn)
+  where
+    proxy :: Proxy val
+    proxy = Proxy
+    updates = conflictQuery entCurrent entExcluded
+    combine (tlb1,vals1) (tlb2,vals2) = (builderToText (tlb1 `mappend` tlb2), vals1 ++ vals2)
+    entExcluded = unsafeSqlEntity (I "excluded")
+    tableName = unEntityNameDB . getEntityDBName . entityDef
+    entCurrent = unsafeSqlEntity (I (tableName proxy))
+    uniqueDef = toUniqueDef unique
+    constraint = TLB.fromText . unConstraintNameDB . uniqueDBName $ uniqueDef
+    renderedUpdates :: (BackendCompatible SqlBackend backend) => backend -> (TLB.Builder, [PersistValue])
+    renderedUpdates conn = renderUpdates conn updates
+    conflict conn = (mconcat ([
+        TLB.fromText "ON CONFLICT ON CONSTRAINT \"",
+        constraint,
+        TLB.fromText "\" DO "
+      ] ++ if null updates then [TLB.fromText "NOTHING"] else [
+        TLB.fromText "UPDATE SET ",
+        updatesTLB
+      ]),values)
+      where
+        (updatesTLB,values) = renderedUpdates conn
+
+-- | Allow aggregate functions to take a filter clause.
+--
+-- Example of usage:
+--
+-- @
+-- share [mkPersist sqlSettings] [persistLowerCase|
+--   User
+--     name Text
+--     deriving Eq Show
+--   Task
+--     userId UserId
+--     completed Bool
+--     deriving Eq Show
+-- |]
+--
+-- select $ from $ \(users `InnerJoin` tasks) -> do
+--   on $ users ^. UserId ==. tasks ^. TaskUserId
+--   groupBy $ users ^. UserId
+--   return
+--    ( users ^. UserId
+--    , count (tasks ^. TaskId) `filterWhere` (tasks ^. TaskCompleted ==. val True)
+--    , count (tasks ^. TaskId) `filterWhere` (tasks ^. TaskCompleted ==. val False)
+--    )
+-- @
+--
+-- @since 3.3.3.3
+filterWhere
+    :: SqlExpr (Value a)
+    -- ^ Aggregate function
+    -> SqlExpr (Value Bool)
+    -- ^ Filter clause
+    -> SqlExpr (Value a)
+filterWhere aggExpr clauseExpr = ERaw noMeta $ \_ info ->
+    let (aggBuilder, aggValues) = case aggExpr of
+            ERaw _ aggF     -> aggF Never info
+        (clauseBuilder, clauseValues) = case clauseExpr of
+            ERaw _ clauseF  -> clauseF Never info
+    in ( aggBuilder <> " FILTER (WHERE " <> clauseBuilder <> ")"
+       , aggValues <> clauseValues
+       )
+
+
+-- | Allows to use `VALUES (..)` in-memory set of values
+-- in RHS of `from` expressions. Useful for JOIN's on
+-- known values which also can be additionally preprocessed
+-- somehow on db side with usage of inner PostgreSQL capabilities.
+--
+--
+-- Example of usage:
+--
+-- @
+-- share [mkPersist sqlSettings] [persistLowerCase|
+--   User
+--     name Text
+--     age Int
+--     deriving Eq Show
+--
+-- select $ do
+--  bound :& user <- from $
+--      values (   (val (10 :: Int), val ("ten" :: Text))
+--            :| [ (val 20, val "twenty")
+--               , (val 30, val "thirty") ]
+--            )
+--      `InnerJoin` table User
+--      `on` (\((bound, _boundName) :& user) -> user^.UserAge >=. bound)
+--  groupBy bound
+--  pure (bound, count @Int $ user^.UserName)
+-- @
+--
+-- @since 3.5.2.3
+values :: (ToSomeValues a, Ex.ToAliasReference a, Ex.ToAlias a) => NE.NonEmpty a -> Ex.From a
+values exprs = Ex.From $ do
+    ident <- newIdentFor $ DBName "vq"
+    alias <- Ex.toAlias $ NE.head exprs
+    ref   <- Ex.toAliasReference ident alias
+    let aliasIdents = mapMaybe (\someVal -> case someVal of
+            SomeValue (ERaw aliasMeta _) -> sqlExprMetaAlias aliasMeta
+            ) $ toSomeValues ref
+    pure (ref, const $ mkExpr ident aliasIdents)
+  where
+    someValueToSql :: IdentInfo -> SomeValue -> (TLB.Builder, [PersistValue])
+    someValueToSql info (SomeValue expr) = materializeExpr info expr
+
+    mkValuesRowSql :: IdentInfo -> [SomeValue] -> (TLB.Builder, [PersistValue])
+    mkValuesRowSql info vs =
+        let materialized = someValueToSql info <$> vs
+            valsSql = TLB.toLazyText . fst <$> materialized
+            params = concatMap snd materialized
+        in (TLB.fromLazyText $ "(" <> TL.intercalate "," valsSql <> ")", params)
+
+    -- (VALUES (v11, v12,..), (v21, v22,..)) as "vq"("v1", "v2",..)
+    mkExpr :: Ident -> [Ident] -> IdentInfo -> (TLB.Builder, [PersistValue])
+    mkExpr valsIdent colIdents info =
+        let materialized = mkValuesRowSql info . toSomeValues <$> NE.toList exprs
+            (valsSql, params) =
+                ( TL.intercalate "," $ map (TLB.toLazyText . fst) materialized
+                , concatMap snd materialized
+                )
+            colsAliases = TL.intercalate "," (map (TLB.toLazyText . useIdent info) colIdents)
+        in
+            ( "(VALUES " <> TLB.fromLazyText valsSql <> ") AS "
+            <> useIdent info valsIdent
+            <> "(" <> TLB.fromLazyText colsAliases <> ")"
+            , params
+            )

src/Database/Esqueleto/PostgreSQL/JSON.hs

@@ -0,0 +1,582 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+{-|
+  This module contains PostgreSQL-specific JSON functions.
+
+  A couple of things to keep in mind about this module:
+
+      * The @Type@ column in the PostgreSQL documentation tables
+      are the types of the right operand, the left is always @jsonb@.
+      * Since these operators can all take @NULL@ values as their input,
+      and most can also output @NULL@ values (even when the inputs are
+      guaranteed to not be NULL), all 'JSONB' values are wrapped in
+      'Maybe'. This also makes it easier to chain them. (cf. 'JSONBExpr')
+      Just use the 'just' function to lift any non-'Maybe' JSONB values
+      in case it doesn't type check.
+      * As long as the previous operator's resulting value is
+      a 'JSONBExpr', any other JSON operator can be used to transform
+      the JSON further. (e.g. @[1,2,3] -> 1 \@> 2@)
+
+  /The PostgreSQL version the functions work with are included/
+  /in their description./
+
+  @since 3.1.0
+-}
+module Database.Esqueleto.PostgreSQL.JSON
+    ( -- * JSONB Newtype
+      --
+      -- | With 'JSONB', you can use your Haskell types in your
+      -- database table models as long as your type has 'FromJSON'
+      -- and 'ToJSON' instances.
+      --
+      -- @
+      -- import Database.Persist.TH
+      --
+      -- share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
+      --   Example
+      --     json (JSONB MyType)
+      -- |]
+      -- @
+      --
+      -- CAUTION: Remember that changing the 'FromJSON' instance
+      -- of your type might result in old data becoming unparsable!
+      -- You can use (@JSONB Data.Aeson.Value@) for unstructured/variable JSON.
+      JSONB(..)
+    , JSONBExpr
+    , jsonbVal
+    -- * JSONAccessor
+    , JSONAccessor(..)
+    -- * Arrow operators
+    --
+    -- | /Better documentation included with individual functions/
+    --
+    -- The arrow operators are selection functions to select values
+    -- from JSON arrays or objects.
+    --
+    -- === PostgreSQL Documentation
+    --
+    -- /Requires PostgreSQL version >= 9.3/
+    --
+    -- @
+    --      | Type   | Description                                |  Example                                         | Example Result
+    -- -----+--------+--------------------------------------------+--------------------------------------------------+----------------
+    --  ->  | int    | Get JSON array element (indexed from zero, | '[{"a":"foo"},{"b":"bar"},{"c":"baz"}]'::json->2 | {"c":"baz"}
+    --      |        | negative integers count from the end)      |                                                  |
+    --  ->  | text   | Get JSON object field by key               | '{"a": {"b":"foo"}}'::json->'a'                  | {"b":"foo"}
+    --  ->> | int    | Get JSON array element as text             | '[1,2,3]'::json->>2                              | 3
+    --  ->> | text   | Get JSON object field as text              | '{"a":1,"b":2}'::json->>'b'                      | 2
+    --  \#>  | text[] | Get JSON object at specified path          | '{"a": {"b":{"c": "foo"}}}'::json#>'{a,b}'       | {"c": "foo"}
+    --  \#>> | text[] | Get JSON object at specified path as text  | '{"a":[1,2,3],"b":[4,5,6]}'::json#>>'{a,2}'      | 3
+    -- @
+    , (->.)
+    , (->>.)
+    , (#>.)
+    , (#>>.)
+    -- * Filter operators
+    --
+    -- | /Better documentation included with individual functions/
+    --
+    -- These functions test certain properties of JSON values
+    -- and return booleans, so are mainly used in WHERE clauses.
+    --
+    -- === PostgreSQL Documentation
+    --
+    -- /Requires PostgreSQL version >= 9.4/
+    --
+    -- @
+    --     | Type   | Description                                                     |  Example
+    -- ----+--------+-----------------------------------------------------------------+---------------------------------------------------
+    --  \@> | jsonb  | Does the left JSON value contain within it the right value?     | '{"a":1, "b":2}'::jsonb \@> '{"b":2}'::jsonb
+    --  <\@ | jsonb  | Is the left JSON value contained within the right value?        | '{"b":2}'::jsonb <\@ '{"a":1, "b":2}'::jsonb
+    --  ?  | text   | Does the string exist as a top-level key within the JSON value? | '{"a":1, "b":2}'::jsonb ? 'b'
+    --  ?| | text[] | Do any of these array strings exist as top-level keys?          | '{"a":1, "b":2, "c":3}'::jsonb ?| array['b', 'c']
+    --  ?& | text[] | Do all of these array strings exist as top-level keys?          | '["a", "b"]'::jsonb ?& array['a', 'b']
+    -- @
+    , (@>.)
+    , (<@.)
+    , (?.)
+    , (?|.)
+    , (?&.)
+    -- * Deletion and concatenation operators
+    --
+    -- | /Better documentation included with individual functions/
+    --
+    -- These operators change the shape of the JSON value and
+    -- also have the highest risk of throwing an exception.
+    -- Please read the descriptions carefully before using these functions.
+    --
+    -- === PostgreSQL Documentation
+    --
+    -- /Requires PostgreSQL version >= 9.5/
+    --
+    -- @
+    --     | Type    | Description                                                            |  Example
+    -- ----+---------+------------------------------------------------------------------------+-------------------------------------------------
+    --  || | jsonb   | Concatenate two jsonb values into a new jsonb value                    | '["a", "b"]'::jsonb || '["c", "d"]'::jsonb
+    --  -  | text    | Delete key/value pair or string element from left operand.             | '{"a": "b"}'::jsonb - 'a'
+    --     |         | Key/value pairs are matched based on their key value.                  |
+    --  -  | integer | Delete the array element with specified index (Negative integers count | '["a", "b"]'::jsonb - 1
+    --     |         | from the end). Throws an error if top level container is not an array. |
+    --  \#- | text[]  | Delete the field or element with specified path                        | '["a", {"b":1}]'::jsonb \#- '{1,b}'
+    --     |         | (for JSON arrays, negative integers count from the end)                |
+    -- @
+    --
+    -- /Requires PostgreSQL version >= 10/
+    --
+    -- @
+    --     | Type    | Description                                                            |  Example
+    -- ----+---------+------------------------------------------------------------------------+-------------------------------------------------
+    --  -  | text[]  | Delete multiple key/value pairs or string elements from left operand.  | '{"a": "b", "c": "d"}'::jsonb - '{a,c}'::text[]
+    --     |         | Key/value pairs are matched based on their key value.                  |
+    -- @
+    , (-.)
+    , (--.)
+    , (#-.)
+    , (||.)
+    ) where
+
+import Data.Text (Text)
+import Database.Esqueleto.Internal.Internal hiding ((-.), (?.), (||.))
+import Database.Esqueleto.Internal.PersistentImport
+import Database.Esqueleto.PostgreSQL.JSON.Instances
+
+infixl 6 ->., ->>., #>., #>>.
+infixl 6 @>., <@., ?., ?|., ?&.
+infixl 6 ||., -., --., #-.
+
+-- | /Requires PostgreSQL version >= 9.3/
+--
+-- This function extracts the jsonb value from a JSON array or object,
+-- depending on whether you use an @int@ or a @text@. (cf. 'JSONAccessor')
+--
+-- As long as the left operand is @jsonb@, this function will not
+-- throw an exception, but will return @NULL@ when an @int@ is used on
+-- anything other than a JSON array, or a @text@ is used on anything
+-- other than a JSON object.
+--
+-- === __PostgreSQL Documentation__
+--
+-- @
+--     | Type | Description                                |  Example                                         | Example Result
+-- ----+------+--------------------------------------------+--------------------------------------------------+----------------
+--  -> | int  | Get JSON array element (indexed from zero) | '[{"a":"foo"},{"b":"bar"},{"c":"baz"}]'::json->2 | {"c":"baz"}
+--  -> | text | Get JSON object field by key               | '{"a": {"b":"foo"}}'::json->'a'                  | {"b":"foo"}
+-- @
+--
+-- @since 3.1.0
+(->.) :: JSONBExpr a -> JSONAccessor -> JSONBExpr b
+(->.) value (JSONKey txt) = unsafeSqlBinOp " -> " value $ val txt
+(->.) value (JSONIndex i) = unsafeSqlBinOp " -> " value $ val i
+
+-- | /Requires PostgreSQL version >= 9.3/
+--
+-- Identical to '->.', but the resulting DB type is a @text@,
+-- so it could be chained with anything that uses @text@.
+--
+-- __CAUTION: if the "scalar" JSON value @null@ is the result__
+-- __of this function, PostgreSQL will interpret it as a__
+-- __PostgreSQL @NULL@ value, and will therefore be 'Nothing'__
+-- __instead of (Just "null")__
+--
+-- === __PostgreSQL Documentation__
+--
+-- @
+--      | Type | Description                    |  Example                    | Example Result
+-- -----+------+--------------------------------+-----------------------------+----------------
+--  ->> | int  | Get JSON array element as text | '[1,2,3]'::json->>2         | 3
+--  ->> | text | Get JSON object field as text  | '{"a":1,"b":2}'::json->>'b' | 2
+-- @
+--
+-- @since 3.1.0
+(->>.) :: JSONBExpr a -> JSONAccessor -> SqlExpr (Value (Maybe Text))
+(->>.) value (JSONKey txt) = unsafeSqlBinOp " ->> " value $ val txt
+(->>.) value (JSONIndex i) = unsafeSqlBinOp " ->> " value $ val i
+
+-- | /Requires PostgreSQL version >= 9.3/
+--
+-- This operator can be used to select a JSON value from deep inside another one.
+-- It only works on objects and arrays and will result in @NULL@ ('Nothing') when
+-- encountering any other JSON type.
+--
+-- The 'Text's used in the right operand list will always select an object field, but
+-- can also select an index from a JSON array if that text is parsable as an integer.
+--
+-- Consider the following:
+--
+-- @
+-- x ^. TestBody #>. ["0","1"]
+-- @
+--
+-- The following JSON values in the @test@ table's @body@ column will be affected:
+--
+-- @
+--  Values in column                     | Resulting value
+-- --------------------------------------+----------------------------
+-- {"0":{"1":"Got it!"}}                 | "Got it!"
+-- {"0":[null,["Got it!","Even here!"]]} | ["Got it!", "Even here!"]
+-- [{"1":"Got it again!"}]               | "Got it again!"
+-- [[null,{\"Wow\":"so deep!"}]]           | {\"Wow\": "so deep!"}
+-- false                                 | NULL
+-- "nope"                                | NULL
+-- 3.14                                  | NULL
+-- @
+--
+-- === __PostgreSQL Documentation__
+--
+-- @
+--      | Type   | Description                       |  Example                                   | Example Result
+-- -----+--------+-----------------------------------+--------------------------------------------+----------------
+--  \#>  | text[] | Get JSON object at specified path | '{"a": {"b":{"c": "foo"}}}'::json#>'{a,b}' | {"c": "foo"}
+-- @
+--
+-- @since 3.1.0
+(#>.) :: JSONBExpr a -> [Text] -> JSONBExpr b
+(#>.) value = unsafeSqlBinOp " #> " value . mkTextArray
+
+
+-- | /Requires PostgreSQL version >= 9.3/
+--
+-- This function is to '#>.' as '->>.' is to '->.'
+--
+-- __CAUTION: if the "scalar" JSON value @null@ is the result__
+-- __of this function, PostgreSQL will interpret it as a__
+-- __PostgreSQL @NULL@ value, and will therefore be 'Nothing'__
+-- __instead of (Just "null")__
+--
+-- === __PostgreSQL Documentation__
+--
+-- @
+--      | Type   | Description                               |  Example                                    | Example Result
+-- -----+--------+-------------------------------------------+---------------------------------------------+----------------
+--  \#>> | text[] | Get JSON object at specified path as text | '{"a":[1,2,3],"b":[4,5,6]}'::json#>>'{a,2}' | 3
+-- @
+--
+-- @since 3.1.0
+(#>>.) :: JSONBExpr a -> [Text] -> SqlExpr (Value (Maybe Text))
+(#>>.)  value = unsafeSqlBinOp " #>> " value . mkTextArray
+
+-- | /Requires PostgreSQL version >= 9.4/
+--
+-- This operator checks for the JSON value on the right to be a subset
+-- of the JSON value on the left.
+--
+-- Examples of the usage of this operator can be found in
+-- the Database.Persist.Postgresql.JSON module.
+--
+-- (here: <https://hackage.haskell.org/package/persistent-postgresql-2.10.0/docs/Database-Persist-Postgresql-JSON.html>)
+--
+-- === __PostgreSQL Documentation__
+--
+-- @
+--     | Type  | Description                                                 |  Example
+-- ----+-------+-------------------------------------------------------------+---------------------------------------------
+--  \@> | jsonb | Does the left JSON value contain within it the right value? | '{"a":1, "b":2}'::jsonb \@> '{"b":2}'::jsonb
+-- @
+--
+-- @since 3.1.0
+(@>.) :: JSONBExpr a -> JSONBExpr b -> SqlExpr (Value Bool)
+(@>.) = unsafeSqlBinOp " @> "
+
+-- | /Requires PostgreSQL version >= 9.4/
+--
+-- This operator works the same as '@>.', just with the arguments flipped.
+-- So it checks for the JSON value on the left to be a subset of JSON value on the right.
+--
+-- Examples of the usage of this operator can be found in
+-- the Database.Persist.Postgresql.JSON module.
+--
+-- (here: <https://hackage.haskell.org/package/persistent-postgresql-2.10.0/docs/Database-Persist-Postgresql-JSON.html>)
+--
+-- === __PostgreSQL Documentation__
+--
+-- @
+--     | Type  | Description                                              |  Example
+-- ----+-------+----------------------------------------------------------+---------------------------------------------
+--  <\@ | jsonb | Is the left JSON value contained within the right value? | '{"b":2}'::jsonb <\@ '{"a":1, "b":2}'::jsonb
+-- @
+--
+-- @since 3.1.0
+(<@.) :: JSONBExpr a -> JSONBExpr b -> SqlExpr (Value Bool)
+(<@.) = unsafeSqlBinOp " <@ "
+
+-- | /Requires PostgreSQL version >= 9.4/
+--
+-- This operator checks if the given text is a top-level member of the
+-- JSON value on the left. This means a top-level field in an object, a
+-- top-level string in an array or just a string value.
+--
+-- Examples of the usage of this operator can be found in
+-- the Database.Persist.Postgresql.JSON module.
+--
+-- (here: <https://hackage.haskell.org/package/persistent-postgresql-2.10.0/docs/Database-Persist-Postgresql-JSON.html>)
+--
+-- === __PostgreSQL Documentation__
+--
+-- @
+--    | Type | Description                                                     |  Example
+-- ---+------+-----------------------------------------------------------------+-------------------------------
+--  ? | text | Does the string exist as a top-level key within the JSON value? | '{"a":1, "b":2}'::jsonb ? 'b'
+-- @
+--
+-- @since 3.1.0
+(?.) :: JSONBExpr a -> Text -> SqlExpr (Value Bool)
+(?.) value = unsafeSqlBinOp " ?? " value . val
+
+-- | /Requires PostgreSQL version >= 9.4/
+--
+-- This operator checks if __ANY__ of the given texts is a top-level member
+-- of the JSON value on the left. This means any top-level field in an object,
+-- any top-level string in an array or just a string value.
+--
+-- Examples of the usage of this operator can be found in
+-- the Database.Persist.Postgresql.JSON module.
+--
+-- (here: <https://hackage.haskell.org/package/persistent-postgresql-2.10.0/docs/Database-Persist-Postgresql-JSON.html>)
+--
+-- === __PostgreSQL Documentation__
+--
+-- @
+--     | Type   | Description                                            |  Example
+-- ----+--------+--------------------------------------------------------+---------------------------------------------------
+--  ?| | text[] | Do any of these array strings exist as top-level keys? | '{"a":1, "b":2, "c":3}'::jsonb ?| array['b', 'c']
+-- @
+--
+-- @since 3.1.0
+(?|.) :: JSONBExpr a -> [Text] -> SqlExpr (Value Bool)
+(?|.) value = unsafeSqlBinOp " ??| " value . mkTextArray
+
+-- | /Requires PostgreSQL version >= 9.4/
+--
+-- This operator checks if __ALL__ of the given texts are top-level members
+-- of the JSON value on the left. This means a top-level field in an object,
+-- a top-level string in an array or just a string value.
+--
+-- Examples of the usage of this operator can be found in
+-- the Database.Persist.Postgresql.JSON module.
+--
+-- (here: <https://hackage.haskell.org/package/persistent-postgresql-2.10.0/docs/Database-Persist-Postgresql-JSON.html>)
+--
+-- === __PostgreSQL Documentation__
+--
+-- @
+--     | Type   | Description                                            |  Example
+-- ----+--------+--------------------------------------------------------+----------------------------------------
+--  ?& | text[] | Do all of these array strings exist as top-level keys? | '["a", "b"]'::jsonb ?& array['a', 'b']
+-- @
+--
+-- @since 3.1.0
+(?&.) :: JSONBExpr a -> [Text] -> SqlExpr (Value Bool)
+(?&.) value = unsafeSqlBinOp " ??& " value . mkTextArray
+
+-- | /Requires PostgreSQL version >= 9.5/
+--
+-- This operator concatenates two JSON values. The behaviour is
+-- self-evident when used on two arrays, but the behaviour on different
+-- combinations of JSON values might behave unexpectedly.
+--
+-- __CAUTION: THIS FUNCTION THROWS AN EXCEPTION WHEN CONCATENATING__
+-- __A JSON OBJECT WITH A JSON SCALAR VALUE!__
+--
+-- === __Arrays__
+--
+-- This operator is a standard concatenation function when used on arrays:
+--
+-- @
+-- [1,2]   || [2,3]   == [1,2,2,3]
+-- []      || [1,2,3] == [1,2,3]
+-- [1,2,3] || []      == [1,2,3]
+-- @
+--
+-- === __Objects__
+-- When concatenating JSON objects with other JSON objects, the fields
+-- from the JSON object on the right are added to the JSON object on the
+-- left. When concatenating a JSON object with a JSON array, the object
+-- will be inserted into the array; either on the left or right, depending
+-- on the position relative to the operator.
+--
+-- When concatening an object with a scalar value, an exception is thrown.
+--
+-- @
+-- {"a": 3.14}                    || {"b": true}         == {"a": 3.14, "b": true}
+-- {"a": "b"}                     || {"a": null}         == {"a": null}
+-- {"a": {"b": true, "c": false}} || {"a": {"b": false}} == {"a": {"b": false}}
+-- {"a": 3.14}                    || [1,null]            == [{"a": 3.14},1,null]
+-- [1,null]                       || {"a": 3.14}         == [1,null,{"a": 3.14}]
+-- 1                              || {"a": 3.14}         == ERROR: invalid concatenation of jsonb objects
+-- {"a": 3.14}                    || false               == ERROR: invalid concatenation of jsonb objects
+-- @
+--
+-- === __Scalar values__
+--
+-- Scalar values can be thought of as being singleton arrays when
+-- used with this operator. This rule does not apply when concatenating
+-- with JSON objects.
+--
+-- @
+-- 1          || null       == [1,null]
+-- true       || "a"        == [true,"a"]
+-- [1,2]      || false      == [1,2,false]
+-- null       || [1,"a"]    == [null,1,"a"]
+-- {"a":3.14} || true       == ERROR: invalid concatenation of jsonb objects
+-- 3.14       || {"a":3.14} == ERROR: invalid concatenation of jsonb objects
+-- {"a":3.14} || [true]     == [{"a":3.14},true]
+-- [false]    || {"a":3.14} == [false,{"a":3.14}]
+-- @
+--
+-- === __PostgreSQL Documentation__
+--
+-- @
+--     | Type  | Description                                         |  Example
+-- ----+-------+-----------------------------------------------------+--------------------------------------------
+--  || | jsonb | Concatenate two jsonb values into a new jsonb value | '["a", "b"]'::jsonb || '["c", "d"]'::jsonb
+-- @
+--
+-- /Note: The @||@ operator concatenates the elements at the top level of/
+-- /each of its operands. It does not operate recursively./
+--
+-- /For example, if both operands are objects with a common key field name,/
+-- /the value of the field in the result will just be the value from the right/
+-- /hand operand./
+--
+-- @since 3.1.0
+(||.) :: JSONBExpr a -> JSONBExpr b -> JSONBExpr c
+(||.) = unsafeSqlBinOp " || "
+
+-- | /Requires PostgreSQL version >= 9.5/
+--
+-- This operator can remove a key from an object or a string element from an array
+-- when using text, and remove certain elements by index from an array when using
+-- integers.
+--
+-- Negative integers delete counting from the end of the array.
+-- (e.g. @-1@ being the last element, @-2@ being the second to last, etc.)
+--
+-- __CAUTION: THIS FUNCTION THROWS AN EXCEPTION WHEN USED ON ANYTHING OTHER__
+-- __THAN OBJECTS OR ARRAYS WHEN USING TEXT, AND ANYTHING OTHER THAN ARRAYS__
+-- __WHEN USING INTEGERS!__
+--
+-- === __Objects and arrays__
+--
+-- @
+-- {"a": 3.14}            - "a"         == {}
+-- {"a": "b"}             - "b"         == {"a": "b"}
+-- {"a": 3.14}            - "a"         == {}
+-- {"a": 3.14, "c": true} - "a"         == {"c": true}
+-- ["a", 2, "c"]          - "a"         == [2, "c"] -- can remove strings from arrays
+-- [true, "b", 5]         - 0           == ["b", 5]
+-- [true, "b", 5]         - 3           == [true, "b", 5]
+-- [true, "b", 5]         - -1          == [true, "b"]
+-- [true, "b", 5]         - -4          == [true, "b", 5]
+-- []                     - 1           == []
+-- {"1": true}            - 1           == ERROR: cannot delete from object using integer index
+-- 1                      - \<anything\>  == ERROR: cannot delete from scalar
+-- "a"                    - \<anything\>  == ERROR: cannot delete from scalar
+-- true                   - \<anything\>  == ERROR: cannot delete from scalar
+-- null                   - \<anything\>  == ERROR: cannot delete from scalar
+-- @
+--
+-- === __PostgreSQL Documentation__
+--
+-- @
+--    | Type    | Description                                                            |  Example
+-- ---+---------+------------------------------------------------------------------------+-------------------------------------------------
+--  - | text    | Delete key/value pair or string element from left operand.             | '{"a": "b"}'::jsonb - 'a'
+--    |         | Key/value pairs are matched based on their key value.                  |
+--  - | integer | Delete the array element with specified index (Negative integers count | '["a", "b"]'::jsonb - 1
+--    |         | from the end). Throws an error if top level container is not an array. |
+-- @
+--
+-- @since 3.1.0
+(-.) :: JSONBExpr a -> JSONAccessor -> JSONBExpr b
+(-.) value (JSONKey txt) = unsafeSqlBinOp " - " value $ val txt
+(-.) value (JSONIndex i) = unsafeSqlBinOp " - " value $ val i
+
+-- | /Requires PostgreSQL version >= 10/
+--
+-- Removes a set of keys from an object, or string elements from an array.
+--
+-- This is the same operator internally as `-.`, but the option to use a @text
+-- array@, instead of @text@ or @integer@ was only added in version 10.
+-- That's why this function is seperate from `-.`
+--
+-- NOTE: The following is equivalent:
+--
+-- @{some JSON expression} -. "a" -. "b"@
+--
+-- is equivalent to
+--
+-- @{some JSON expression} --. ["a","b"]@
+--
+-- === __PostgreSQL Documentation__
+--
+-- @
+--    | Type    | Description                                                            |  Example
+-- ---+---------+------------------------------------------------------------------------+-------------------------------------------------
+--  - | text[]  | Delete multiple key/value pairs or string elements from left operand.  | '{"a": "b", "c": "d"}'::jsonb - '{a,c}'::text[]
+--    |         | Key/value pairs are matched based on their key value.                  |
+-- @
+--
+-- @since 3.1.0
+(--.) :: JSONBExpr a -> [Text] -> JSONBExpr b
+(--.) value = unsafeSqlBinOp " - " value . mkTextArray
+
+-- | /Requires PostgreSQL version >= 9.5/
+--
+-- This operator can remove elements nested in an object.
+--
+-- If a 'Text' is not parsable as a number when selecting in an array
+-- (even when halfway through the selection) an exception will be thrown.
+--
+-- Negative integers delete counting from the end of an array.
+-- (e.g. @-1@ being the last element, @-2@ being the second to last, etc.)
+--
+-- __CAUTION: THIS FUNCTION THROWS AN EXCEPTION WHEN USED__
+-- __ON ANYTHING OTHER THAN OBJECTS OR ARRAYS, AND WILL__
+-- __ALSO THROW WHEN TRYING TO SELECT AN ARRAY ELEMENT WITH__
+-- __A NON-INTEGER TEXT__
+--
+-- === __Objects__
+--
+-- @
+-- {"a": 3.14, "b": null}        #- []        == {"a": 3.14, "b": null}
+-- {"a": 3.14, "b": null}        #- ["a"]     == {"b": null}
+-- {"a": 3.14, "b": null}        #- ["a","b"] == {"a": 3.14, "b": null}
+-- {"a": {"b":false}, "b": null} #- ["a","b"] == {"a": {}, "b": null}
+-- @
+--
+-- === __Arrays__
+--
+-- @
+-- [true, {"b":null}, 5]       #- []            == [true, {"b":null}, 5]
+-- [true, {"b":null}, 5]       #- ["0"]         == [{"b":null}, 5]
+-- [true, {"b":null}, 5]       #- ["b"]         == ERROR: path element at position 1 is not an integer: "b"
+-- [true, {"b":null}, 5]       #- ["1","b"]     == [true, {}, 5]
+-- [true, {"b":null}, 5]       #- ["-2","b"]    == [true, {}, 5]
+-- {"a": {"b":[false,4,null]}} #- ["a","b","2"] == {"a": {"b":[false,4]}}
+-- {"a": {"b":[false,4,null]}} #- ["a","b","c"] == ERROR: path element at position 3 is not an integer: "c"
+-- @
+--
+-- === __Other values__
+--
+-- @
+-- 1    \#- {anything} == ERROR: cannot delete from scalar
+-- "a"  \#- {anything} == ERROR: cannot delete from scalar
+-- true \#- {anything} == ERROR: cannot delete from scalar
+-- null \#- {anything} == ERROR: cannot delete from scalar
+-- @
+--
+-- === __PostgreSQL Documentation__
+--
+-- @
+--     | Type   | Description                                             |  Example
+-- ----+--------+---------------------------------------------------------+------------------------------------
+--  \#- | text[] | Delete the field or element with specified path         | '["a", {"b":1}]'::jsonb \#- '{1,b}'
+--     |        | (for JSON arrays, negative integers count from the end) |
+-- @
+--
+-- @since 3.1.0
+(#-.) :: JSONBExpr a -> [Text] -> JSONBExpr b
+(#-.) value = unsafeSqlBinOp " #- " value . mkTextArray
+
+mkTextArray :: [Text] -> SqlExpr (Value PersistValue)
+mkTextArray = val . PersistArray . fmap toPersistValue

src/Database/Esqueleto/PostgreSQL/JSON/Instances.hs

@@ -0,0 +1,123 @@
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# language DerivingStrategies #-}
+
+module Database.Esqueleto.PostgreSQL.JSON.Instances where
+
+import Data.Aeson (FromJSON(..), ToJSON(..), encode, eitherDecodeStrict)
+import Data.Bifunctor (first)
+import qualified Data.ByteString.Lazy as BSL (toStrict)
+import Data.String (IsString(..))
+import Data.Text (Text)
+import qualified Data.Text as T (concat, pack)
+import qualified Data.Text.Encoding as TE (decodeUtf8, encodeUtf8)
+import Database.Esqueleto.Internal.PersistentImport
+import Database.Esqueleto.Internal.Internal (SqlExpr, Value, just, val)
+import GHC.Generics (Generic)
+
+-- | Newtype wrapper around any type with a JSON representation.
+--
+-- @since 3.1.0
+newtype JSONB a = JSONB { unJSONB :: a }
+    deriving stock
+        ( Generic
+        , Eq
+        , Foldable
+        , Functor
+        , Ord
+        , Read
+        , Show
+        , Traversable
+        )
+    deriving newtype
+        ( FromJSON
+        , ToJSON
+        )
+
+-- | 'SqlExpr' of a NULL-able 'JSONB' value. Hence the 'Maybe'.
+--
+-- Note: NULL here is a PostgreSQL NULL, not a JSON 'null'
+type JSONBExpr a = SqlExpr (Value (Maybe (JSONB a)))
+
+-- | Convenience function to lift a regular value into
+-- a 'JSONB' expression.
+jsonbVal :: (FromJSON a, ToJSON a) => a -> JSONBExpr a
+jsonbVal = just . val . JSONB
+
+-- | Used with certain JSON operators.
+--
+-- This data type has 'Num' and 'IsString' instances
+-- for ease of use by using integer and string literals.
+--
+-- >>> 3 :: JSONAccessor
+-- JSONIndex 3
+-- >>> -3 :: JSONAccessor
+-- JSONIndex -3
+--
+-- >>> "name" :: JSONAccessor
+-- JSONKey "name"
+--
+-- NOTE: DO NOT USE ANY OF THE 'Num' METHODS ON THIS TYPE!
+data JSONAccessor
+    = JSONIndex Int
+    | JSONKey Text
+    deriving (Generic, Eq, Show)
+
+-- | I repeat, DO NOT use any method other than 'fromInteger'!
+instance Num JSONAccessor where
+    fromInteger = JSONIndex . fromInteger
+    negate (JSONIndex i) = JSONIndex $ negate i
+    negate (JSONKey _) = error "Can not negate a JSONKey"
+    (+) = numErr
+    (-) = numErr
+    (*) = numErr
+    abs = numErr
+    signum = numErr
+
+numErr :: a
+numErr = error "Do not use 'Num' methods on JSONAccessors"
+
+instance IsString JSONAccessor where
+    fromString = JSONKey . T.pack
+
+-- | @since 3.1.0
+instance (FromJSON a, ToJSON a) => PersistField (JSONB a) where
+    toPersistValue = PersistLiteralEscaped . BSL.toStrict . encode . unJSONB
+    fromPersistValue pVal = fmap JSONB $ case pVal of
+        PersistByteString bs -> first (badParse $ TE.decodeUtf8 bs) $ eitherDecodeStrict bs
+        PersistText t -> first (badParse t) $ eitherDecodeStrict (TE.encodeUtf8 t)
+        x -> Left $ fromPersistValueError "string or bytea" x
+
+-- | jsonb
+--
+-- @since 3.1.0
+instance (FromJSON a, ToJSON a) => PersistFieldSql (JSONB a) where
+    sqlType _ = SqlOther "JSONB"
+
+badParse :: Text -> String -> Text
+badParse t = fromPersistValueParseError t . T.pack
+
+fromPersistValueError
+    :: Text -- ^ Database type(s), should appear different from Haskell name, e.g. "integer" or "INT", not "Int".
+    -> PersistValue -- ^ Incorrect value
+    -> Text -- ^ Error message
+fromPersistValueError databaseType received = T.concat
+    [ "Failed to parse Haskell newtype `JSONB a`; "
+    , "expected ", databaseType
+    , " from database, but received: ", T.pack (show received)
+    , ". Potential solution: Check that your database schema matches your Persistent model definitions."
+    ]
+
+fromPersistValueParseError
+    :: Text -- ^ Received value
+    -> Text -- ^ Additional error
+    -> Text -- ^ Error message
+fromPersistValueParseError received err = T.concat
+    [ "Failed to parse Haskell type `JSONB a`, "
+    , "but received ", received
+    , " | with error: ", err
+    ]

src/Database/Esqueleto/SQLite.hs

@@ -0,0 +1,18 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | This module contain SQLite-specific functions.
+--
+-- @since 2.2.8
+module Database.Esqueleto.SQLite
+  ( random_
+  ) where
+
+import Database.Esqueleto.Internal.Internal hiding (random_)
+import Database.Esqueleto.Internal.PersistentImport
+
+-- | (@random()@) Split out into database specific modules
+-- because MySQL uses `rand()`.
+--
+-- /Since: 2.6.0/
+random_ :: (PersistField a, Num a) => SqlExpr (Value a)
+random_ = unsafeSqlValue "RANDOM()"

stack-7.10.yaml

@@ -1,6 +0,0 @@
-flags: {}
-packages:
-- '.'
-resolver: lts-6.12
-extra-deps:
-  - persistent-2.5

stack-8.0.yaml

@@ -1,17 +0,0 @@
-# resolver: nightly-2017-01-10
-resolver: lts-8.8
-# compiler: ghc-8.0.2
-
-packages:
-- '.'
-extra-deps:
-- doctest-prop-0.2.0.1
-- quickcheck-properties-0.1
-# - http-client-0.5.0
-# - fail-4.9.0.0
-# - http-types-0.9
-# - attoparsec-0.13.0.1
-# - doctest-0.10.1
-# - semigroups-0.18.0.1
-# - uri-bytestring-0.1.9
-# - temporary-resourcet-0.1.0.0

stack-8.10.yaml

@@ -0,0 +1,12 @@
+resolver: lts-17.8
+
+packages:
+  - '.'
+  - 'examples'
+
+extra-deps:
+- lift-type-0.1.0.1
+- persistent-2.13.0.0
+- persistent-sqlite-2.13.0.0
+- persistent-mysql-2.13.0.0
+- persistent-postgresql-2.13.0.0

stack-8.2.yaml

@@ -0,0 +1,25 @@
+resolver: lts-10.6
+
+packages:
+  - '.'
+
+extra-deps:
+  - aeson-1.4.1.0
+  - aeson-compat-0.3.8
+  - attoparsec-0.13.2.2
+  - case-insensitive-1.2.0.11
+  - conduit-1.3.0
+  - conduit-extra-1.3.0
+  - hashable-1.2.7.0
+  - monad-logger-0.3.28.1
+  - persistent-2.10.0
+  - persistent-mysql-2.10.0
+  - persistent-postgresql-2.10.0
+  - persistent-sqlite-2.10.0
+  - persistent-template-2.7.0
+  - postgresql-libpq-0.9.4.2
+  - postgresql-simple-0.6.1
+  - resourcet-1.2.0
+  - scientific-0.3.6.2
+  - text-1.2.3.0
+  - unliftio-0.2.0.0

stack-8.4.yaml

@@ -0,0 +1,15 @@
+resolver: lts-12.2
+
+packages:
+  - '.'
+
+extra-deps:
+  - aeson-1.4.1.0
+  - persistent-2.10.0
+  - persistent-postgresql-2.10.0
+  - persistent-sqlite-2.10.0
+  - persistent-mysql-2.10.0
+  - persistent-template-2.7.0
+  - postgresql-libpq-0.9.4.2
+  - postgresql-simple-0.6.1
+  - transformers-0.5.5.2

stack-8.6.yaml

@@ -0,0 +1,15 @@
+resolver: lts-13.6
+
+packages:
+  - '.'
+  - 'examples'
+
+extra-deps:
+  - git: https://github.com/yesodweb/persistent
+    commit: 0b8f9f3305c9b60c947565de882abfbfd8cb5702
+    subdirs:
+      - persistent
+      - persistent-template
+      - persistent-mysql
+      - persistent-postgresql
+      - persistent-sqlite

stack-8.8.yaml

@@ -0,0 +1,12 @@
+resolver: lts-16.31
+
+packages:
+  - '.'
+  - 'examples'
+
+extra-deps:
+- persistent-2.12.0.1
+- persistent-template-2.12.0.0
+- persistent-mysql-2.12.0.0
+- persistent-postgresql-2.12.0.0
+- persistent-sqlite-2.12.0.0

stack-8.8.yaml.lock

@@ -0,0 +1,77 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/lock_files
+
+packages:
+- completed:
+    subdir: persistent
+    name: persistent
+    version: 2.11.0.0
+    git: https://github.com/yesodweb/persistent
+    pantry-tree:
+      size: 2099
+      sha256: cd4d895557a60b40543c4a6804d32346a1c14c39e28658bb6852d8f4904ef1de
+    commit: 0b8f9f3305c9b60c947565de882abfbfd8cb5702
+  original:
+    subdir: persistent
+    git: https://github.com/yesodweb/persistent
+    commit: 0b8f9f3305c9b60c947565de882abfbfd8cb5702
+- completed:
+    subdir: persistent-template
+    name: persistent-template
+    version: '2.9'
+    git: https://github.com/yesodweb/persistent
+    pantry-tree:
+      size: 620
+      sha256: 0602872c9c38ccc6966b4a1fd1d102a345f94ad855077157d588536ee6803343
+    commit: 0b8f9f3305c9b60c947565de882abfbfd8cb5702
+  original:
+    subdir: persistent-template
+    git: https://github.com/yesodweb/persistent
+    commit: 0b8f9f3305c9b60c947565de882abfbfd8cb5702
+- completed:
+    subdir: persistent-mysql
+    name: persistent-mysql
+    version: 2.10.3
+    git: https://github.com/yesodweb/persistent
+    pantry-tree:
+      size: 577
+      sha256: a3b9d2ef77af25dca203a4dbe2857b6a1d4e421bbe376f261288e9a8ebfda28f
+    commit: 0b8f9f3305c9b60c947565de882abfbfd8cb5702
+  original:
+    subdir: persistent-mysql
+    git: https://github.com/yesodweb/persistent
+    commit: 0b8f9f3305c9b60c947565de882abfbfd8cb5702
+- completed:
+    subdir: persistent-postgresql
+    name: persistent-postgresql
+    version: 2.11.0.0
+    git: https://github.com/yesodweb/persistent
+    pantry-tree:
+      size: 907
+      sha256: 6f1ad1c5b0b22cf455c6b1b4551a749d21bb72042597450c8ef9ff1eb5a74782
+    commit: 0b8f9f3305c9b60c947565de882abfbfd8cb5702
+  original:
+    subdir: persistent-postgresql
+    git: https://github.com/yesodweb/persistent
+    commit: 0b8f9f3305c9b60c947565de882abfbfd8cb5702
+- completed:
+    subdir: persistent-sqlite
+    name: persistent-sqlite
+    version: 2.11.0.0
+    git: https://github.com/yesodweb/persistent
+    pantry-tree:
+      size: 891
+      sha256: fc9106077e16b406a5a823c732e3b543822a530f2befc446e49acf68797f6d42
+    commit: 0b8f9f3305c9b60c947565de882abfbfd8cb5702
+  original:
+    subdir: persistent-sqlite
+    git: https://github.com/yesodweb/persistent
+    commit: 0b8f9f3305c9b60c947565de882abfbfd8cb5702
+snapshots:
+- completed:
+    size: 532382
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/14.yaml
+    sha256: 1ef27e36f38824abafc43224ca612211b3828fa9ffd31ba0fc2867ae2e19ba90
+  original: lts-16.14

stack-nightly.yaml

@@ -0,0 +1,14 @@
+resolver: nightly-2022-03-29
+
+packages:
+  - "."
+  - 'examples'
+
+
+extra-deps:
+  - time-1.12.1
+  - base-compat-0.12.1
+  - directory-1.3.7.0
+  - process-1.6.14.0
+  - Cabal-3.6.3.0
+  - unix-2.7.2.2

stack-nightly.yaml.lock

@@ -0,0 +1,54 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/lock_files
+
+packages:
+- completed:
+    hackage: time-1.12.1@sha256:af1fafc1fb66e3d0afb66fb5ab8629f74c038bebd42c234b581aff7abc201089,6295
+    pantry-tree:
+      size: 7208
+      sha256: 96205222b57c39156ee646d710a4100a119dc28f211c57cacaf741f6c1bb35da
+  original:
+    hackage: time-1.12.1
+- completed:
+    hackage: base-compat-0.12.1@sha256:20e50848d9dfee1523fafe8950060b04fae43d402c15553da5c7cacd116f7846,6960
+    pantry-tree:
+      size: 9038
+      sha256: 2f2c14615443954f117613d77835234b598718e611fb4cf4522e01980bf1bcbd
+  original:
+    hackage: base-compat-0.12.1
+- completed:
+    hackage: directory-1.3.7.0@sha256:d44788eac41268d951679fdcc343adc8a65fcf5b016bdf6c1f996bf78dde798e,2940
+    pantry-tree:
+      size: 3433
+      sha256: 2352834a6424cc8b462706c15e08bb721e120829b147b6d798eade4ebce425f5
+  original:
+    hackage: directory-1.3.7.0
+- completed:
+    hackage: process-1.6.14.0@sha256:b6ad76fd3f4bf133cdc2dc9176e23447f2a0a8e9316047d53154cd11f871446d,2845
+    pantry-tree:
+      size: 1544
+      sha256: 72300155a8fd5a91f6b25dfebb77db05aa27a0b866dbfb2d7098c5e4580ca105
+  original:
+    hackage: process-1.6.14.0
+- completed:
+    hackage: Cabal-3.6.3.0@sha256:ff97c442b0c679c1c9876acd15f73ac4f602b973c45bde42b43ec28265ee48f4,12459
+    pantry-tree:
+      size: 19757
+      sha256: b250a53bdb56844f047a2927833bb565b936a289abfa85dfc2a63148d776368a
+  original:
+    hackage: Cabal-3.6.3.0
+- completed:
+    hackage: unix-2.7.2.2@sha256:15f5365c5995634e45de1772b9504761504a310184e676bc2ef60a14536dbef9,3496
+    pantry-tree:
+      size: 3536
+      sha256: 36434ced74d679622d61b69e8d92e1bd632d9ef3e284c63094653b2e473b0553
+  original:
+    hackage: unix-2.7.2.2
+snapshots:
+- completed:
+    size: 539378
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2022/3/29.yaml
+    sha256: c959441a05f6fa4d45ae6e258290f04d399245b8436263b4abb525c7f73da6a5
+  original: nightly-2022-03-29

stack.yaml

@@ -1 +1 @@
-stack-8.0.yaml
+stack-8.10.yaml

style-guide.md

@@ -0,0 +1,9 @@
+# Style Guide
+
+- Please use `stylish-haskell` on the project to keep imports consistent and
+  clean. We have a custom [`.stylish-haskell.yaml`](.stylish-haskell.yaml) file.
+  You can run `stylish-haskell` from vim with `:%! stylish-haskell`.
+- Four space indent.
+- Prefer indentation over any other form of alignment.
+- If text goes off the screen due to four space indentation, factor out
+  functions and values into names to reduce indentation.

test/Common/Test/Import.hs

@@ -0,0 +1,87 @@
+{-# LANGUAGE CPP, AllowAmbiguousTypes #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Common.Test.Import
+    ( module Common.Test.Import
+    , module X
+    ) where
+
+import System.Environment
+import Control.Applicative
+import Common.Test.Models as X
+import Database.Esqueleto.Experimental as X hiding (random_)
+import Test.Hspec as X
+import UnliftIO as X
+import Control.Monad
+import Test.QuickCheck
+import Data.Text  as X (Text)
+import Control.Monad.Trans.Reader as X (ReaderT, mapReaderT, ask)
+
+type SpecDb = SpecWith ConnectionPool
+
+asserting :: MonadIO f => IO () -> SqlPersistT f ()
+asserting a = liftIO a
+
+noExceptions :: Expectation
+noExceptions = pure ()
+
+itDb
+    :: (HasCallStack)
+    => String
+    -> SqlPersistT IO x
+    -> SpecDb
+itDb message action = do
+    it message $ \connection -> do
+        void $ testDb connection action
+
+propDb
+    :: (HasCallStack, Testable a)
+    => String
+    -> ((SqlPersistT IO () -> IO ()) -> a )
+    -> SpecDb
+propDb message action = do
+    it message $ \connection -> do
+        property (action (testDb connection))
+
+testDb :: ConnectionPool -> SqlPersistT IO a -> IO a
+testDb conn action =
+    liftIO $ flip runSqlPool conn $ do
+        a <- action
+        transactionUndo
+        pure a
+
+setDatabaseState
+    :: SqlPersistT IO a
+    -> SqlPersistT IO ()
+    -> SpecWith ConnectionPool
+    -> SpecWith ConnectionPool
+setDatabaseState create clean test =
+    beforeWith (\conn -> runSqlPool create conn >> pure conn) $
+    after (\conn -> runSqlPool clean conn) $
+    test
+
+isCI :: IO Bool
+isCI =  do
+    env <- getEnvironment
+    return $ case lookup "TRAVIS" env <|> lookup "CI" env of
+        Just "true" -> True
+        _ -> False

test/Common/Test/Models.hs

@@ -0,0 +1,189 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Common.Test.Models where
+
+import Data.Time
+import Database.Esqueleto.Experimental
+import Database.Persist.Sql
+import Database.Persist.TH
+
+share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
+  Foo
+    name Int
+    Primary name
+    deriving Show Eq Ord
+  Bar
+    quux FooId
+    deriving Show Eq Ord
+  Baz
+    blargh FooId
+    deriving Show Eq
+  Shoop
+    baz BazId
+    deriving Show Eq
+  Asdf
+    shoop ShoopId
+    deriving Show Eq
+  Another
+    why BazId
+  YetAnother
+    argh ShoopId
+
+  Person
+    name String
+    age Int Maybe
+    weight Int Maybe
+    favNum Int
+    deriving Eq Show Ord
+  BlogPost
+    title String
+    authorId PersonId
+    deriving Eq Show
+  Comment
+    body String
+    blog BlogPostId
+    deriving Eq Show
+  CommentReply
+    body String
+    comment CommentId
+  Profile
+    name String
+    person PersonId
+    deriving Eq Show
+  Reply
+    guy PersonId
+    body String
+    deriving Eq Show
+
+  Lord
+    county String maxlen=100
+    dogs Int Maybe
+    Primary county
+    deriving Eq Show
+
+  Deed
+    contract String maxlen=100
+    ownerId LordId maxlen=100
+    Primary contract
+    deriving Eq Show
+
+  Follow
+    follower PersonId
+    followed PersonId
+    deriving Eq Show
+
+  CcList
+    names [String]
+
+  Frontcover
+    number Int
+    title String
+    Primary number
+    deriving Eq Show
+  Article
+    title String
+    frontcoverNumber Int
+    Foreign Frontcover fkfrontcover frontcoverNumber
+    deriving Eq Show
+  ArticleMetadata
+    articleId ArticleId
+    Primary articleId
+    deriving Eq Show
+  Tag
+    name String maxlen=100
+    Primary name
+    deriving Eq Show
+  ArticleTag
+    articleId ArticleId
+    tagId     TagId maxlen=100
+    Primary   articleId tagId
+    deriving Eq Show
+  Article2
+    title String
+    frontcoverId FrontcoverId
+    deriving Eq Show
+  Point
+    x Int
+    y Int
+    name String
+    Primary x y
+    deriving Eq Show
+  Circle
+    centerX Int
+    centerY Int
+    name String
+    Foreign Point fkpoint centerX centerY
+    deriving Eq Show
+  Numbers
+    int    Int
+    double Double
+    deriving Eq Show
+
+  JoinOne
+    name    String
+    deriving Eq Show
+
+  JoinTwo
+    joinOne JoinOneId
+    name    String
+    deriving Eq Show
+
+  JoinThree
+    joinTwo JoinTwoId
+    name    String
+    deriving Eq Show
+
+  JoinFour
+    name    String
+    joinThree JoinThreeId
+    deriving Eq Show
+
+  JoinOther
+    name    String
+    deriving Eq Show
+
+  JoinMany
+    name      String
+    joinOther JoinOtherId
+    joinOne   JoinOneId
+    deriving Eq Show
+
+  DateTruncTest
+    created   UTCTime
+    deriving Eq Show
+|]
+
+-- Unique Test schema
+share [mkPersist sqlSettings, mkMigrate "migrateUnique"] [persistUpperCase|
+  OneUnique
+    name String
+    value Int
+    UniqueValue value
+    deriving Eq Show
+|]
+
+
+instance ToBaseId ArticleMetadata where
+    type BaseEnt ArticleMetadata = Article
+    toBaseIdWitness articleId = ArticleMetadataKey articleId
+

test/Common/Test/Select.hs

@@ -0,0 +1,22 @@
+module Common.Test.Select where
+
+import Common.Test.Import
+
+testSelect :: SpecDb
+testSelect = do
+    describe "select" $ do
+        itDb "works for a single value" $ do
+            ret <- select $ return $ val (3 :: Int)
+            asserting $ ret `shouldBe` [ Value 3 ]
+
+        itDb "works for a pair of a single value and ()" $ do
+            ret <- select $ return (val (3 :: Int), ())
+            asserting $ ret `shouldBe` [ (Value 3, ()) ]
+
+        itDb "works for a single ()" $ do
+            ret <- select $ return ()
+            asserting $ ret `shouldBe` [ () ]
+
+        itDb "works for a single NULL value" $ do
+            ret <- select $ return nothing
+            asserting $ ret `shouldBe` [ Value (Nothing :: Maybe Int) ]

test/MySQL/Test.hs

@@ -0,0 +1,223 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module MySQL.Test where
+
+import Common.Test.Import hiding (from, on)
+
+import Control.Applicative
+import Control.Monad (void)
+import Control.Monad.IO.Class (MonadIO(liftIO))
+import Control.Monad.Logger (runNoLoggingT, runStderrLoggingT)
+import Control.Monad.Trans.Reader (ReaderT, mapReaderT)
+import qualified Control.Monad.Trans.Resource as R
+import Database.Esqueleto
+import Database.Esqueleto.Experimental hiding (from, on)
+import qualified Database.Esqueleto.Experimental as Experimental
+import Database.Persist.MySQL
+       ( connectDatabase
+       , connectHost
+       , connectPassword
+       , connectPort
+       , connectUser
+       , defaultConnectInfo
+       , withMySQLConn
+       , createMySQLPool
+       )
+
+import Test.Hspec
+
+import Common.Test
+
+testMysqlSum :: SpecDb
+testMysqlSum = do
+  itDb "works with sum_" $ do
+      _ <- insert' p1
+      _ <- insert' p2
+      _ <- insert' p3
+      _ <- insert' p4
+      ret <- select $
+             from $ \p->
+             return $ joinV $ sum_ (p ^. PersonAge)
+      liftIO $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Double ) ]
+
+testMysqlTwoAscFields :: SpecDb
+testMysqlTwoAscFields = do
+  itDb "works with two ASC fields (one call)" $ do
+      p1e <- insert' p1
+      p2e <- insert' p2
+      p3e <- insert' p3
+      p4e <- insert' p4
+      ret <- select $
+             from $ \p -> do
+             orderBy [asc (p ^. PersonAge), asc (p ^. PersonName)]
+             return p
+      liftIO $ ret `shouldBe` [ p2e, p4e, p3e, p1e ]
+
+testMysqlOneAscOneDesc :: SpecDb
+testMysqlOneAscOneDesc = do
+  itDb "works with one ASC and one DESC field (two calls)" $ do
+      p1e <- insert' p1
+      p2e <- insert' p2
+      p3e <- insert' p3
+      p4e <- insert' p4
+      ret <- select $
+             from $ \p -> do
+             orderBy [desc (p ^. PersonAge)]
+             orderBy [asc (p ^. PersonName)]
+             return p
+      liftIO $ ret `shouldBe` [ p1e, p4e, p3e, p2e ]
+
+
+
+
+testMysqlCoalesce :: SpecDb
+testMysqlCoalesce = do
+  itDb "works on PostgreSQL and MySQL with <2 arguments" $ do
+      _ :: [Value (Maybe Int)] <-
+        select $
+        from $ \p -> do
+        return (coalesce [p ^. PersonAge])
+      return ()
+
+
+
+
+testMysqlUpdate :: SpecDb
+testMysqlUpdate = do
+  itDb "works on a simple example" $ do
+      p1k <- insert p1
+      p2k <- insert p2
+      p3k <- insert p3
+      let anon = "Anonymous"
+      ()  <- update $ \p -> do
+             set p [ PersonName =. val anon
+                   , PersonAge *=. just (val 2) ]
+             where_ (p ^. PersonName !=. val "Mike")
+      n   <- updateCount $ \p -> do
+             set p [ PersonAge +=. just (val 1) ]
+             where_ (p ^. PersonName !=. val "Mike")
+      ret <- select $
+             from $ \p -> do
+             orderBy [ asc (p ^. PersonName), asc (p ^. PersonAge) ]
+             return p
+      -- MySQL: nulls appear first, and update returns actual number
+      --        of changed rows
+      liftIO $ n `shouldBe` 1
+      liftIO $ ret `shouldBe` [ Entity p2k (Person anon Nothing (Just 37) 2)
+                              , Entity p1k (Person anon (Just 73) Nothing 1)
+                              , Entity p3k p3 ]
+
+nameContains :: (SqlString s)
+             => (SqlExpr (Value [Char])
+             -> SqlExpr (Value s)
+             -> SqlExpr (Value Bool))
+             -> s
+             -> [Entity Person]
+             -> SqlPersistT IO ()
+nameContains f t expected = do
+  ret <- select $
+         from $ \p -> do
+         where_ (f
+                  (p ^. PersonName)
+                  (concat_ [(%), val t, (%)]))
+         orderBy [asc (p ^. PersonName)]
+         return p
+  liftIO $ ret `shouldBe` expected
+
+
+testMysqlTextFunctions :: SpecDb
+testMysqlTextFunctions = do
+  describe "text functions" $ do
+    itDb "like, (%) and (++.) work on a simple example" $ do
+         [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4]
+         nameContains like "h"  [p1e, p2e]
+         nameContains like "i"  [p4e, p3e]
+         nameContains like "iv" [p4e]
+
+
+testMysqlUnionWithLimits :: SpecDb
+testMysqlUnionWithLimits = do
+  describe "MySQL Union" $ do
+    itDb "supports limit/orderBy by parenthesizing" $ do
+        mapM_ (insert . Foo) [1..6]
+
+        let q1 = do
+              foo <- Experimental.from $ Table @Foo
+              where_ $ foo ^. FooName <=. val 3
+              orderBy [asc $ foo ^. FooName]
+              limit 2
+              pure $ foo ^. FooName
+
+        let q2 = do
+              foo <- Experimental.from $ Table @Foo
+              where_ $ foo ^. FooName >. val 3
+              orderBy [asc $ foo ^. FooName]
+              limit 2
+              pure $ foo ^. FooName
+
+
+        ret <- select $ Experimental.from $ q1 `union_` q2
+        liftIO $ ret `shouldMatchList` [Value 1, Value 2, Value 4, Value 5]
+
+spec :: Spec
+spec = beforeAll mkConnectionPool $ do
+    tests
+
+    describe "MySQL specific tests" $ do
+        -- definitely doesn't work at the moment
+        -- testMysqlRandom
+        testMysqlSum
+        testMysqlTwoAscFields
+        testMysqlOneAscOneDesc
+        testMysqlCoalesce
+        testMysqlUpdate
+        testMysqlTextFunctions
+        testMysqlUnionWithLimits
+
+verbose :: Bool
+verbose = False
+
+migrateIt :: R.MonadUnliftIO m => SqlPersistT m ()
+migrateIt = do
+  mapReaderT R.runResourceT $ void $ runMigrationSilent migrateAll
+  cleanDB
+
+mkConnectionPool :: IO ConnectionPool
+mkConnectionPool = do
+    ci <- isCI
+    let connInfo
+            | ci =
+                defaultConnectInfo
+                    { connectHost     = "127.0.0.1"
+                    , connectUser     = "travis"
+                    , connectPassword = "esqutest"
+                    , connectDatabase = "esqutest"
+                    , connectPort     = 33306
+                    }
+            | otherwise =
+                defaultConnectInfo
+                    { connectHost     = "localhost"
+                    , connectUser     = "travis"
+                    , connectPassword = "esqutest"
+                    , connectDatabase = "esqutest"
+                    , connectPort     = 3306
+                    }
+    pool <-
+        if verbose
+        then
+            runStderrLoggingT $
+                createMySQLPool connInfo 4
+        else
+            runNoLoggingT $
+                createMySQLPool connInfo 4
+
+
+    flip runSqlPool pool $ do
+        migrateIt
+        cleanDB
+
+    pure pool

test/PostgreSQL/MigrateJSON.hs

@@ -0,0 +1,36 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module PostgreSQL.MigrateJSON where
+
+import Common.Test.Import hiding (Value, from, on)
+
+import Data.Aeson (Value)
+import Database.Esqueleto.Legacy (from)
+import Database.Esqueleto.PostgreSQL.JSON (JSONB)
+import Database.Persist.TH
+
+-- JSON Table for PostgreSQL
+share [mkPersist sqlSettings, mkMigrate "migrateJSON"] [persistUpperCase|
+Json
+  value (JSONB Value)
+  deriving Show
+|]
+
+cleanJSON
+    :: forall m. MonadIO m
+    => SqlPersistT m ()
+cleanJSON = delete $ from $ \(_ :: SqlExpr (Entity Json)) -> return ()

test/SQLite/Test.hs

@@ -0,0 +1,165 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module SQLite.Test where
+
+import Common.Test.Import hiding (from, on)
+
+import Control.Monad (void)
+import Control.Monad.Logger (runNoLoggingT, runStderrLoggingT)
+import Database.Esqueleto.Legacy hiding (random_)
+import Database.Esqueleto.SQLite (random_)
+import Database.Persist.Sqlite (createSqlitePool)
+import Database.Sqlite (SqliteException)
+
+import Common.Test
+
+testSqliteRandom :: SpecDb
+testSqliteRandom = do
+    itDb "works with random_" $ do
+        _ <- select $ return (random_ :: SqlExpr (Value Int))
+        asserting noExceptions
+
+testSqliteSum :: SpecDb
+testSqliteSum = do
+    itDb "works with sum_" $ do
+        _ <- insert' p1
+        _ <- insert' p2
+        _ <- insert' p3
+        _ <- insert' p4
+        ret <- select $
+               from $ \p->
+               return $ joinV $ sum_ (p ^. PersonAge)
+        asserting $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Int) ]
+
+
+
+
+
+testSqliteTwoAscFields :: SpecDb
+testSqliteTwoAscFields = do
+    itDb "works with two ASC fields (one call)" $ do
+        p1e <- insert' p1
+        p2e <- insert' p2
+        p3e <- insert' p3
+        p4e <- insert' p4
+        ret <- select $
+               from $ \p -> do
+               orderBy [asc (p ^. PersonAge), asc (p ^. PersonName)]
+               return p
+        -- in SQLite and MySQL, its the reverse
+        asserting $ ret `shouldBe` [ p2e, p4e, p3e, p1e ]
+
+testSqliteOneAscOneDesc :: SpecDb
+testSqliteOneAscOneDesc = do
+    itDb "works with one ASC and one DESC field (two calls)" $ do
+        p1e <- insert' p1
+        p2e <- insert' p2
+        p3e <- insert' p3
+        p4e <- insert' p4
+        ret <- select $
+               from $ \p -> do
+               orderBy [desc (p ^. PersonAge)]
+               orderBy [asc (p ^. PersonName)]
+               return p
+        asserting $ ret `shouldBe` [ p1e, p4e, p3e, p2e ]
+
+testSqliteCoalesce :: SpecDb
+testSqliteCoalesce = do
+    itDb "throws an exception on SQLite with <2 arguments" $ do
+        eres <- try $ select $
+               from $ \p -> do
+               return (coalesce [p ^. PersonAge]) :: SqlQuery (SqlExpr (Value (Maybe Int)))
+        asserting $ case eres of
+            Left (_ :: SqliteException) ->
+                pure ()
+            Right _ ->
+                expectationFailure "Expected SqliteException with <2 args to coalesce"
+
+testSqliteUpdate :: SpecDb
+testSqliteUpdate = do
+    itDb "works on a simple example" $ do
+        p1k <- insert p1
+        p2k <- insert p2
+        p3k <- insert p3
+        let anon = "Anonymous" :: String
+        ()  <- update $ \p -> do
+               set p [ PersonName =. val anon
+                     , PersonAge *=. just (val 2) ]
+               where_ (p ^. PersonName !=. val "Mike")
+        n   <- updateCount $ \p -> do
+               set p [ PersonAge +=. just (val 1) ]
+               where_ (p ^. PersonName !=. val "Mike")
+        ret <- select $
+               from $ \p -> do
+               orderBy [ asc (p ^. PersonName), asc (p ^. PersonAge) ]
+               return p
+        -- SQLite: nulls appear first, update returns matched rows.
+        asserting $ do
+            n `shouldBe` 2
+            ret `shouldMatchList`
+                [ Entity p2k (Person anon Nothing (Just 37) 2)
+                , Entity p1k (Person anon (Just 73) Nothing 1)
+                , Entity p3k p3
+                ]
+
+testSqliteTextFunctions :: SpecDb
+testSqliteTextFunctions = do
+    describe "text functions" $ do
+        itDb "like, (%) and (++.) work on a simple example" $ do
+            let query :: String -> SqlPersistT IO [Entity Person]
+                query t =
+                    select $
+                    from $ \p -> do
+                    where_ (like
+                             (p ^. PersonName)
+                             ((%) ++. val t ++. (%)))
+                    orderBy [asc (p ^. PersonName)]
+                    return p
+            [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4]
+            r0 <- query "h"
+            r1 <- query "i"
+            r2 <- query "iv"
+            asserting $ do
+                r0 `shouldBe` [p1e, p2e]
+                r1 `shouldBe` [p4e, p3e]
+                r2 `shouldBe` [p4e]
+
+spec :: HasCallStack => Spec
+spec = beforeAll mkConnectionPool $ do
+    tests
+
+    describe "SQLite specific tests" $ do
+      testAscRandom random_
+      testRandomMath
+      testSqliteRandom
+      testSqliteSum
+      testSqliteTwoAscFields
+      testSqliteOneAscOneDesc
+      testSqliteCoalesce
+      testSqliteUpdate
+      testSqliteTextFunctions
+
+mkConnectionPool :: IO ConnectionPool
+mkConnectionPool = do
+    conn <-
+        if verbose
+        then runStderrLoggingT $
+            createSqlitePool ".esqueleto-test.sqlite" 4
+        else runNoLoggingT $
+            createSqlitePool ".esqueleto-test.sqlite" 4
+    flip runSqlPool conn $ do
+        migrateIt
+
+    pure conn
+
+verbose :: Bool
+verbose = False
+
+migrateIt :: MonadUnliftIO m => SqlPersistT m ()
+migrateIt = do
+  void $ runMigrationSilent migrateAll
+  cleanDB

test/Spec.hs

@@ -0,0 +1,22 @@
+module Main where
+
+import Test.Hspec
+import Test.Hspec.Core.Spec
+
+import qualified SQLite.Test as SQLite
+import qualified MySQL.Test as MySQL
+import qualified PostgreSQL.Test as Postgres
+
+main :: IO ()
+main = hspec spec
+
+spec :: Spec
+spec = do
+    parallel $ describe "Esqueleto" $ do
+        describe "SQLite" $ do
+            sequential $ SQLite.spec
+        describe "MySQL" $ do
+            sequential $ MySQL.spec
+        describe "Postgresql" $ do
+            sequential $ Postgres.spec
+

test/expected-compile-failures/.gitignore

@@ -0,0 +1,3 @@
+.stack-work/
+expected-compile-failures.cabal
+*~

test/expected-compile-failures/README.md

@@ -0,0 +1,6 @@
+# expected-compile-failures
+
+This subdirectory contains a stack project for expected compilation failures. To
+add a new "test case", create a new `executable` stanza in the `package.yaml`
+file. The Travis CI test script ([`test.sh`](test.sh)) will attempt to compile
+the executable and will exit with an error if it successfully compiled.

test/expected-compile-failures/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

test/expected-compile-failures/package.yaml

@@ -0,0 +1,55 @@
+name:                expected-compile-failures
+version:             0.1.0.0
+github:              bitemyapp/esqueleto
+license:             BSD3
+author:              Matt Parsons
+maintainer:          parsonsmatt@gmail.com
+copyright:           2018 Matt Parsons
+
+extra-source-files:
+- README.md
+
+description:         Please see the README on GitHub at <https://github.com/bitemyapp/esqueleto/test/expected-compile-failures#readme>
+
+dependencies:
+- base >= 4.7 && < 5
+- esqueleto
+- persistent
+- persistent-template
+
+default-extensions:
+- FlexibleContexts
+- FlexibleInstances
+- GADTs
+- GeneralizedNewtypeDeriving
+- MultiParamTypeClasses
+- NoMonomorphismRestriction
+- OverloadedStrings
+- QuasiQuotes
+- ScopedTypeVariables
+- StandaloneDeriving
+- TemplateHaskell
+- TypeFamilies
+
+library:
+  source-dirs: src
+
+executables:
+  update-with-read-role:
+    main:                Main.hs
+    source-dirs:         update-read-role
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - expected-compile-failures
+  write-with-read-role:
+    main:                Main.hs
+    source-dirs:         write-read-role
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - expected-compile-failures

test/expected-compile-failures/src/Lib.hs

@@ -0,0 +1,33 @@
+{-# LANGUAGE UndecidableInstances, DerivingStrategies #-}
+module Lib where
+
+import Control.Monad.IO.Class (MonadIO)
+import Database.Persist
+import Database.Persist.Sql (SqlReadT)
+import           Database.Esqueleto                   (SqlExpr, SqlQuery, from,
+                                                       val, (<#), insertSelect, (<&>), (^.))
+import           Database.Esqueleto.Internal.Language (Insertion)
+import           Database.Persist.TH                  (mkDeleteCascade,
+                                                       mkMigrate, mkPersist,
+                                                       persistLowerCase, share,
+                                                       sqlSettings)
+
+share [ mkPersist sqlSettings
+      , mkDeleteCascade sqlSettings
+      , mkMigrate "migrateAll"] [persistLowerCase|
+  Person
+    name String
+    age Int Maybe
+    born Int Maybe
+    deriving Eq Show
+  BlogPost
+    title String
+    authorId PersonId
+    deriving Eq Show
+  Follow
+    follower PersonId
+    followed PersonId
+    deriving Eq Show
+|]
+
+

test/expected-compile-failures/stack-8.2.yaml

@@ -0,0 +1,26 @@
+resolver: lts-10.6
+
+extra-deps:
+- aeson-1.4.1.0
+- aeson-compat-0.3.8
+- attoparsec-0.13.2.2
+- case-insensitive-1.2.0.11
+- conduit-1.3.0
+- conduit-extra-1.3.0
+- hashable-1.2.7.0
+- monad-logger-0.3.28.1
+- persistent-2.10.0
+- persistent-mysql-2.10.0
+- persistent-postgresql-2.10.0
+- persistent-sqlite-2.10.0
+- persistent-template-2.7.0
+- postgresql-libpq-0.9.4.2
+- postgresql-simple-0.6.1
+- resourcet-1.2.0
+- scientific-0.3.6.2
+- text-1.2.3.0
+- unliftio-0.2.0.0
+
+packages:
+- .
+- ../../../esqueleto

test/expected-compile-failures/stack-8.4.yaml

@@ -0,0 +1,17 @@
+resolver: lts-12.24
+
+packages:
+- .
+- ../../../esqueleto
+
+extra-deps:
+- aeson-1.4.1.0
+- persistent-2.10.0
+- persistent-mysql-2.10.0
+- persistent-postgresql-2.10.0
+- persistent-sqlite-2.10.0
+- persistent-template-2.7.0
+- postgresql-libpq-0.9.4.2
+- postgresql-simple-0.6.1
+- transformers-0.5.5.2
+allow-newer: true

test/expected-compile-failures/stack-8.6.yaml

@@ -0,0 +1,15 @@
+resolver: nightly-2018-12-18
+
+extra-deps:
+- persistent-2.10.0
+- persistent-mysql-2.10.0
+- persistent-postgresql-2.10.0
+- persistent-sqlite-2.10.0
+- persistent-template-2.7.0
+- postgresql-simple-0.6.1
+
+allow-newer: true
+
+packages:
+- .
+- ../../../esqueleto

test/expected-compile-failures/stack.yaml

@@ -0,0 +1,16 @@
+resolver: lts-12.24
+
+packages:
+- .
+- ../../../esqueleto
+
+extra-deps:
+- aeson-1.4.1.0
+- persistent-2.10.0
+- persistent-mysql-2.10.0
+- persistent-postgresql-2.10.0
+- persistent-sqlite-2.10.0
+- persistent-template-2.7.0
+- postgresql-libpq-0.9.4.2
+- postgresql-simple-0.6.1
+- transformers-0.5.5.2

test/expected-compile-failures/stack.yaml.lock

@@ -0,0 +1,75 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/lock_files
+
+packages:
+- completed:
+    hackage: aeson-1.4.1.0@sha256:a72639fbf44d5c2d5270fb6d9484629ed332d3029987fafd7580b5204265fb8b,6372
+    pantry-tree:
+      size: 39767
+      sha256: 3eee6f6a05e563ebdd45e93348240d79eb20c267e70683360758327745d3249d
+  original:
+    hackage: aeson-1.4.1.0
+- completed:
+    hackage: persistent-2.10.0@sha256:6e4566c2cf8dda6bf3e00f4f813dd711e7796a1598f46c5c729491f4b643c91d,4708
+    pantry-tree:
+      size: 2094
+      sha256: 5ae7466479cf300e9bf07dc9780a432b4338c4e1e56fc732399260303cdf2f84
+  original:
+    hackage: persistent-2.10.0
+- completed:
+    hackage: persistent-mysql-2.10.0@sha256:4bf76721312104b726406d3cac4a30185e9e19898605615ded6cbfe5cdabda6a,2884
+    pantry-tree:
+      size: 460
+      sha256: 15737a7f8af7085fa6f83f1c084ff4de4922f28576633aa9aab4a8e668ccc5c3
+  original:
+    hackage: persistent-mysql-2.10.0
+- completed:
+    hackage: persistent-postgresql-2.10.0@sha256:87384a179e44b57af7b12b00ccfdfc4bc03010a438aad207b9f38def0147cda2,2829
+    pantry-tree:
+      size: 671
+      sha256: 5a2b25b40cb440466792b9ae293de95b4fcfcd1410c1c7aed9ffc8001699f5dc
+  original:
+    hackage: persistent-postgresql-2.10.0
+- completed:
+    hackage: persistent-sqlite-2.10.0@sha256:d41ad3e2d9b88ab31bfdcd15e76ad41cd495573937921026b3b13f010ff9b8cf,4664
+    pantry-tree:
+      size: 681
+      sha256: 86ad7225024dbe74421b78ab6a6c3e05aeb94d0633cde413f7e91453bee3e7c0
+  original:
+    hackage: persistent-sqlite-2.10.0
+- completed:
+    hackage: persistent-template-2.7.0@sha256:1855a36c7dbfa1554c1711c1d61c41e83495bcb1986851cf1b3340f44ed269af,2703
+    pantry-tree:
+      size: 560
+      sha256: 073f355d9425b1553e8e4f8553bb06e63d185c0e113c75512f969eeb92bcb4db
+  original:
+    hackage: persistent-template-2.7.0
+- completed:
+    hackage: postgresql-libpq-0.9.4.2@sha256:3a3f372cf72706f349104f73d4ea5dee9c3eeac1ff749301110dadb55e2ac66f,2804
+    pantry-tree:
+      size: 549
+      sha256: b045b567464d6c86ecc23a3915a6aa81c52cfbaa1c51c7fe9649366185c9ce6b
+  original:
+    hackage: postgresql-libpq-0.9.4.2
+- completed:
+    hackage: postgresql-simple-0.6.1@sha256:316e6424da50ec863c74dcf2d7c86cfe6ee00cb142c07a422eb118577dc1d3b7,5256
+    pantry-tree:
+      size: 4055
+      sha256: c22e1f054f3be5eaad5eba5abc793504be85e441ff671bf203013ac8f72f9c79
+  original:
+    hackage: postgresql-simple-0.6.1
+- completed:
+    hackage: transformers-0.5.5.2@sha256:c6a1dc5261d87de1d7d0876b670ca8782c43ac89e59ec2bafa1e32d25c7d3509,3122
+    pantry-tree:
+      size: 2365
+      sha256: 5c38ca49a4b2468b6c61682a722611c8a54699bb94f8d6e0ee9f2c546477f116
+  original:
+    hackage: transformers-0.5.5.2
+snapshots:
+- completed:
+    size: 508835
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/12/24.yaml
+    sha256: b0a5564eb448e69b9f6a4f67fe72016d9e7ec24e37de1826e1a9cfd064a1b6a5
+  original: lts-12.24

test/expected-compile-failures/test.sh

@@ -0,0 +1,14 @@
+#!/bin/env bash
+
+# This script attempts to build each executable in the package, which should all
+# fail with a compiler error. If any executable builds successfully, then we exit
+# the script.
+
+# We have to use 2>&1 because `stack ide targets` outputs to stderr for some
+# reason.
+for target in $(stack ide targets 2>&1 | grep exe); do
+    echo "Building target: $target"
+    if stack build --fast $target; then
+        exit 1
+    fi
+done

test/expected-compile-failures/update-read-role/Main.hs

@@ -0,0 +1,25 @@
+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
+
+module Main where
+
+import           Control.Monad.IO.Class               (MonadIO)
+import           Database.Esqueleto
+import           Database.Esqueleto.Internal.Language (Insertion)
+import           Database.Persist.Sql                 (SqlWriteT)
+import           Database.Persist.TH                  (mkDeleteCascade,
+                                                       mkMigrate, mkPersist,
+                                                       persistLowerCase, share,
+                                                       sqlSettings)
+
+import           Lib
+
+main :: IO ()
+main = pure ()
+
+updateQuery :: SqlExpr (Entity Person) -> SqlQuery ()
+updateQuery = \p -> do
+    set p [ PersonAge =. just (val 123) -. p ^. PersonBorn ]
+    where_ $ isNothing (p ^. PersonAge)
+
+shouldFail :: MonadIO m => SqlReadT m ()
+shouldFail = update updateQuery

test/expected-compile-failures/write-read-role/Main.hs

@@ -0,0 +1,27 @@
+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
+
+module Main where
+
+import           Control.Monad.IO.Class               (MonadIO)
+import           Database.Esqueleto                   (SqlExpr, SqlQuery, from,
+                                                       insertSelect, val, (<#),
+                                                       (<&>), (^.))
+import           Database.Esqueleto.Internal.Language (Insertion)
+import           Database.Persist.Sql                 (SqlReadT)
+import           Database.Persist.TH                  (mkDeleteCascade,
+                                                       mkMigrate, mkPersist,
+                                                       persistLowerCase, share,
+                                                       sqlSettings)
+
+import           Lib
+
+main :: IO ()
+main = pure ()
+
+insertQuery :: SqlQuery (SqlExpr (Insertion BlogPost))
+insertQuery =
+  from $ \p ->
+  return $ BlogPost <# (val "Group Blog Post") <&> (p ^. PersonId)
+
+shouldFail :: MonadIO m => SqlReadT m ()
+shouldFail = insertSelect insertQuery

test/new-join-compiler-errors/README.md

@@ -0,0 +1,6 @@
+# expected-compile-failures
+
+This subdirectory contains a stack project for expected compilation failures. To
+add a new "test case", create a new `executable` stanza in the `package.yaml`
+file. The Travis CI test script ([`test.sh`](test.sh)) will attempt to compile
+the executable and will exit with an error if it successfully compiled.

test/new-join-compiler-errors/bad-errors/Main.hs

@@ -0,0 +1,45 @@
+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
+{-# LANGUAGE TypeApplications #-}
+module Main where
+
+import           Control.Monad.IO.Class               (MonadIO)
+import           Database.Esqueleto hiding (from,on)
+import           Database.Esqueleto.Experimental
+import           Database.Esqueleto.Internal.Language (Insertion)
+import           Database.Persist.Sql                 (SqlWriteT)
+import           Database.Persist.TH                  (mkDeleteCascade,
+                                                       mkMigrate, mkPersist,
+                                                       persistLowerCase, share,
+                                                       sqlSettings)
+
+import           Lib
+
+main :: IO ()
+main = pure ()
+
+-- Missing on condition leads to an unintelligeable error and points to the wrong spot
+missingOnConditionShouldFail :: MonadIO m => SqlPersistT m [(Entity Person, Entity BlogPost)]
+missingOnConditionShouldFail = select $ do
+    (people :& blogPosts) <-
+      from $ Table @Person
+      `LeftOuterJoin` Table @BlogPost
+    pure (people, blogPosts)
+
+-- Mismatched union when one part is returning a different shape than the other 
+mismatchedUnion :: MonadIO m => SqlPersistT m [(Value String, Value (Maybe Int))]
+mismatchedUnion = select . from $ 
+  (SelectQuery $ do
+    people <- from $ Table @Person
+    pure (people ^. PersonName, people ^. PersonAge))
+  `Union`
+  (SelectQuery $ do
+    people <- from $ Table @Person
+    pure (people ^. PersonName))
+
+incorrectNumberOfOnElements = select . from $
+  Table @Person
+  `LeftOuterJoin` Table @Follow
+  `on` (\(people :& follows) -> just (people ^. PersonId) ==. follows ?. FollowFollowed)
+  `LeftOuterJoin` Table @Person
+  `on` (\(follows :& followers) -> followers ?. PersonId ==. follows ?. FollowFollower)
+

test/new-join-compiler-errors/new-join-compiler-errors.cabal

@@ -0,0 +1,55 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.31.2.
+--
+-- see: https://github.com/sol/hpack
+--
+-- hash: 2bf9103f4701fb3c063743dbb88970ee68ecbeaeb87eea96ca21096da1264968
+
+name:           new-join-compiler-errors
+version:        0.1.0.0
+description:    Please see the README on GitHub at <https://github.com/bitemyapp/esqueleto/test/new-join-compiler-errors#readme>
+homepage:       https://github.com/bitemyapp/esqueleto#readme
+bug-reports:    https://github.com/bitemyapp/esqueleto/issues
+author:         Ben Levy
+maintainer:     benjaminlevy007@gmail.com
+copyright:      2020 Ben Levy
+license:        BSD3
+build-type:     Simple
+extra-source-files:
+    README.md
+
+source-repository head
+  type: git
+  location: https://github.com/bitemyapp/esqueleto
+
+library
+  exposed-modules:
+      Lib
+  other-modules:
+      Paths_new_join_compiler_errors
+  hs-source-dirs:
+      src
+  default-extensions: FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses NoMonomorphismRestriction OverloadedStrings QuasiQuotes ScopedTypeVariables StandaloneDeriving TemplateHaskell TypeFamilies
+  build-depends:
+      base >=4.7 && <5
+    , esqueleto
+    , persistent
+    , persistent-template
+  default-language: Haskell2010
+
+executable bad-errors
+  main-is: Main.hs
+  other-modules:
+      Paths_new_join_compiler_errors
+  hs-source-dirs:
+      bad-errors
+  default-extensions: FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses NoMonomorphismRestriction OverloadedStrings QuasiQuotes ScopedTypeVariables StandaloneDeriving TemplateHaskell TypeFamilies
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      base >=4.7 && <5
+    , esqueleto
+    , new-join-compiler-errors
+    , persistent
+    , persistent-template
+  default-language: Haskell2010

test/new-join-compiler-errors/package.yaml

@@ -0,0 +1,46 @@
+name:                new-join-compiler-errors
+version:             0.1.0.0
+github:              bitemyapp/esqueleto
+license:             BSD3
+author:              Ben Levy 
+maintainer:          benjaminlevy007@gmail.com 
+copyright:           2020 Ben Levy
+
+extra-source-files:
+- README.md
+
+description:         Please see the README on GitHub at <https://github.com/bitemyapp/esqueleto/test/new-join-compiler-errors#readme>
+
+dependencies:
+- base >= 4.7 && < 5
+- esqueleto
+- persistent
+- persistent-template
+
+default-extensions:
+- FlexibleContexts
+- FlexibleInstances
+- GADTs
+- GeneralizedNewtypeDeriving
+- MultiParamTypeClasses
+- NoMonomorphismRestriction
+- OverloadedStrings
+- QuasiQuotes
+- ScopedTypeVariables
+- StandaloneDeriving
+- TemplateHaskell
+- TypeFamilies
+
+library:
+  source-dirs: src
+
+executables:
+  bad-errors: 
+    main:                Main.hs
+    source-dirs:         bad-errors
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - new-join-compiler-errors

test/new-join-compiler-errors/src/Lib.hs

@@ -0,0 +1,33 @@
+{-# LANGUAGE UndecidableInstances, DerivingStrategies #-}
+module Lib where
+
+import Control.Monad.IO.Class (MonadIO)
+import Database.Persist
+import Database.Persist.Sql (SqlReadT)
+import           Database.Esqueleto                   (SqlExpr, SqlQuery, from,
+                                                       val, (<#), insertSelect, (<&>), (^.))
+import           Database.Esqueleto.Internal.Language (Insertion)
+import           Database.Persist.TH                  (mkDeleteCascade,
+                                                       mkMigrate, mkPersist,
+                                                       persistLowerCase, share,
+                                                       sqlSettings)
+
+share [ mkPersist sqlSettings
+      , mkDeleteCascade sqlSettings
+      , mkMigrate "migrateAll"] [persistLowerCase|
+  Person
+    name String
+    age Int Maybe
+    born Int Maybe
+    deriving Eq Show
+  BlogPost
+    title String
+    authorId PersonId
+    deriving Eq Show
+  Follow
+    follower PersonId
+    followed PersonId
+    deriving Eq Show
+|]
+
+

test/new-join-compiler-errors/stack.yaml

@@ -0,0 +1,16 @@
+resolver: lts-13.6
+
+packages:
+- .
+- ../../../esqueleto
+
+extra-deps:
+- aeson-1.4.1.0
+- persistent-2.10.0
+- persistent-mysql-2.10.0
+- persistent-postgresql-2.10.0
+- persistent-sqlite-2.10.0
+- persistent-template-2.7.0
+- postgresql-libpq-0.9.4.2
+- postgresql-simple-0.6.1
+- transformers-0.5.5.2