Add source to SqlAggregate, the Over instance uses this to prevent pseudo-aggregates(from groupBy) and already windowed values from being windowed

From raw

.github/workflows/haskell.yml

@@ -32,13 +32,13 @@ jobs:
           --health-retries=3
     strategy:
       matrix:
-        cabal: ["3.6"]
-        ghc: ["8.6.5", "8.8.4", "8.10.4", "9.0.2", "9.2.2"]
+        cabal: ["3.2"]
+        ghc: ["8.6.5", "8.8.3", "8.10.1"]
     env:
       CONFIG: "--enable-tests --enable-benchmarks "
     steps:
       - uses: actions/checkout@v2
-      - uses: haskell/actions/setup@v1
+      - uses: actions/setup-haskell@v1.1.4
         id: setup-haskell-cabal
         with:
           ghc-version: ${{ matrix.ghc }}
@@ -68,9 +68,8 @@ jobs:
             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-test --disable-optimization -j $CONFIG
       - run: cabal v2-haddock -j $CONFIG
       - run: cabal v2-sdist

.gitignore

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

Makefile

@@ -21,19 +21,7 @@ test-ghci:
 	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"
-
-
+	ghcid -c "stack ghci --ghci-options -fobject-code esqueleto:test:sqlite"
 
 init-pgsql:
 	sudo -u postgres -- createuser -s esqutest

README.md

@@ -1,4 +1,4 @@
-Esqueleto [![CI](https://github.com/bitemyapp/esqueleto/actions/workflows/haskell.yml/badge.svg?branch=master)](https://github.com/bitemyapp/esqueleto/actions/workflows/haskell.yml)
+Esqueleto [![TravisCI](https://travis-ci.org/bitemyapp/esqueleto.svg)](https://travis-ci.org/bitemyapp/esqueleto)
 ==========
 
 ![Skeleton](./esqueleto.png)
@@ -127,61 +127,7 @@ 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))`.
-
-### 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)
-```
+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))`.
 
 ## Experimental/New Joins
 
@@ -541,6 +487,5 @@ 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';
+mysql> GRANT ALL ON esqutest.* TO 'travis';
 ```

cabal.project

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

changelog.md

@@ -1,114 +1,17 @@
-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
+        - 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
+        - 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
+        - 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

esqueleto.cabal

@@ -1,7 +1,7 @@
 cabal-version: 1.12
 
 name:           esqueleto
-version:        3.5.4.0
+version:        3.5.0.0
 synopsis:       Type-safe EDSL for SQL queries on persistent backends.
 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.
                 .
@@ -29,8 +29,11 @@ source-repository head
 library
     exposed-modules:
         Database.Esqueleto
-        Database.Esqueleto.Legacy
         Database.Esqueleto.Experimental
+        Database.Esqueleto.Experimental.Aggregates
+        Database.Esqueleto.Experimental.WindowFunctions
+        Database.Esqueleto.Internal.Language
+        Database.Esqueleto.Internal.Sql
         Database.Esqueleto.Internal.Internal
         Database.Esqueleto.Internal.ExprParser
         Database.Esqueleto.MySQL
@@ -53,17 +56,17 @@ library
     build-depends:
         base >=4.8 && <5.0
       , aeson >=1.0
-      , attoparsec >= 0.13 && < 0.15
+      , attoparsec >= 0.13 && < 0.14
       , blaze-html
       , bytestring
       , conduit >=1.3
       , containers
       , monad-logger
-      , persistent >=2.13 && <3
+      , persistent >=2.10.0 && <2.12
       , resourcet >=1.2
       , tagged >=0.2
       , text >=0.11 && <1.3
-      , time >=1.5.0.1 && <=1.13
+      , time >=1.5.0.1 && <=1.10
       , transformers >=0.2
       , unliftio
       , unordered-containers >=0.2
@@ -75,24 +78,54 @@ library
         -Wpartial-fields
         -Wmissing-home-modules
         -Widentities
+        -Wredundant-constraints
         -Wcpp-undef
         -Wcpp-undef
+        -Wmonomorphism-restriction
     default-language: Haskell2010
 
-test-suite specs
+test-suite mysql
     type: exitcode-stdio-1.0
-    main-is: Spec.hs
+    main-is: MySQL/Test.hs
+    other-modules:
+        Common.Test
+        Paths_esqueleto
+    hs-source-dirs:
+        test
+    ghc-options: -Wall
+    build-depends:
+        base >=4.8 && <5.0
+      , attoparsec
+      , blaze-html
+      , bytestring
+      , conduit >=1.3
+      , containers
+      , esqueleto
+      , exceptions
+      , hspec
+      , monad-logger
+      , mtl
+      , mysql
+      , mysql-simple
+      , persistent
+      , persistent-mysql
+      , persistent-template
+      , resourcet >=1.2
+      , tagged >=0.2
+      , text >=0.11 && <1.3
+      , time
+      , transformers >=0.2
+      , unliftio
+      , unordered-containers >=0.2
+    default-language: Haskell2010
+
+test-suite postgresql
+    type: exitcode-stdio-1.0
+    main-is: PostgreSQL/Test.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
+        Paths_esqueleto
     hs-source-dirs:
         test
     ghc-options: -Wall -threaded
@@ -102,27 +135,56 @@ test-suite specs
       , attoparsec
       , blaze-html
       , bytestring
-      , conduit
+      , conduit >=1.3
       , containers
       , esqueleto
       , exceptions
       , hspec
-      , hspec-core
       , monad-logger
       , mtl
-      , mysql
-      , mysql-simple
       , persistent
-      , persistent-mysql
       , persistent-postgresql
-      , persistent-sqlite
+      , persistent-template
+      , postgresql-libpq
       , postgresql-simple
-      , QuickCheck
-      , resourcet
-      , tagged
-      , text
+      , resourcet >=1.2
+      , tagged >=0.2
+      , text >=0.11 && <1.3
       , time
-      , transformers
+      , transformers >=0.2
       , unliftio
-      , unordered-containers
+      , unordered-containers >=0.2
+      , vector
+    default-language: Haskell2010
+
+test-suite sqlite
+    type: exitcode-stdio-1.0
+    main-is: SQLite/Test.hs
+    other-modules:
+        Common.Test
+        Paths_esqueleto
+    hs-source-dirs:
+        test
+    build-depends:
+        base >=4.8 && <5.0
+      , attoparsec
+      , blaze-html
+      , bytestring
+      , conduit >=1.3
+      , containers
+      , esqueleto
+      , exceptions
+      , hspec
+      , monad-logger
+      , mtl
+      , persistent
+      , persistent-sqlite
+      , persistent-template
+      , resourcet >=1.2
+      , tagged >=0.2
+      , text >=0.11 && <1.3
+      , time
+      , transformers >=0.2
+      , unliftio
+      , unordered-containers >=0.2
     default-language: Haskell2010

examples/.gitignore

@@ -0,0 +1 @@
+*.cabal

examples/Blog.hs

@@ -11,7 +11,7 @@ module Blog
 
 import           Control.Monad.Base          (MonadBase (..))
 import           Control.Monad.IO.Unlift     (MonadUnliftIO(..), wrappedWithRunInIO)
-import           Control.Monad.Logger        (MonadLoggerIO, MonadLogger, NoLoggingT (..))
+import           Control.Monad.Logger        (MonadLogger, NoLoggingT (..))
 import           Control.Monad.Reader
 import           Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..),
                                               MonadTransControl (..),
@@ -26,7 +26,6 @@ newtype BlogT m a = BlogT { unBlogT :: NoLoggingT (ReaderT ConnectionString m) a
            , MonadLogger
            , MonadReader ConnectionString
            , MonadIO
-           , MonadLoggerIO
            )
 
 instance MonadUnliftIO m => MonadUnliftIO (BlogT m) where

examples/Main.hs

@@ -10,6 +10,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
@@ -19,15 +20,14 @@ module Main
     ) where
 
 import Blog
-import Control.Monad (void)
-import Control.Monad (forM_)
+import Control.Monad (forM_, void)
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Control.Monad.IO.Unlift (MonadUnliftIO)
-import Control.Monad.Logger (MonadLogger, MonadLoggerIO)
+import Control.Monad.Logger (MonadLogger)
 import Control.Monad.Reader (MonadReader(..), runReaderT)
 import Control.Monad.Trans.Control (MonadBaseControl)
 import Data.Monoid ((<>))
-import Database.Esqueleto
+import Database.Esqueleto.Experimental
 import Database.Persist.Postgresql (ConnectionString, withPostgresqlConn)
 import Database.Persist.TH
        ( AtLeastOneUniqueKey(..)
@@ -62,9 +62,9 @@ putPersons :: (MonadIO m, MonadLogger m)
            => SqlPersistT m ()
 putPersons = do
   -- | Select all values from the `person` table
-  people <- select $
-              from $ \person -> do
-              return person
+  people <- select $ do
+            person <- from $ table @Person
+            return person
 
   -- | entityVal extracts the Person value, which we then extract
   -- | the person name from the record and print it
@@ -75,8 +75,8 @@ getJohns :: (MonadIO m, MonadLogger m)
          => SqlReadT m [Entity Person]
 getJohns =
   -- | Select all persons where their name is equal to "John"
-  select $
-  from $ \p -> do
+  select $ do
+    p <- from $ table @Person
     where_ (p ^. PersonName ==. val "John")
     return p
 
@@ -85,8 +85,8 @@ 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
+  select $ do
+    p <- from $ table @Person
     where_ (p ^. PersonAge >=. just (val 18))
     return p
 
@@ -95,8 +95,10 @@ 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
+  select $ do
+    p :& b <-
+        from $ table @Person
+        `crossJoin` table @BlogPost
     where_ (b ^. BlogPostAuthorId ==. p ^. PersonId)
     orderBy [asc (b ^. BlogPostTitle)]
     return (b, p)
@@ -108,9 +110,11 @@ 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)
+  select $ do
+    (p :& mb) <-
+        from $ table @Person
+        `leftJoin` table @BlogPost
+        `on` (\(p :& mb) -> (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId))
     orderBy [asc (p ^. PersonName), asc (mb ?. BlogPostTitle)]
     return (p, mb)
 
@@ -122,10 +126,13 @@ followers =
   -- | 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)
+  select $ do
+    (p1 :& f :& p2) <-
+        from $ table @Person
+        `innerJoin` table @Follow
+        `on` (\(p1 :& f) -> p1 ^. PersonId ==. f ^. FollowFollower)
+        `innerJoin` table @Person
+        `on` (\(_ :& f :& p2) -> p2 ^. PersonId ==. f ^. FollowFollowed)
     return (p1, f, p2)
 
 
@@ -146,8 +153,8 @@ deleteYoungsters = do
   -- | 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
+  youngsters <- select $ do
+    p <- from $ table @Person
     where_ (p ^. PersonAge <. just (val 14))
     pure p
   forM_ youngsters (deleteCascade . entityKey)
@@ -157,7 +164,8 @@ insertBlogPosts :: (MonadIO m, MonadLogger m)
                 => SqlWriteT m ()
 insertBlogPosts =
   -- | Insert a new blogpost for every person
-  insertSelect $ from $ \p ->
+  insertSelect $ do
+    p <- from $ table @Person
     return $ BlogPost <# (val "Group Blog Post") <&> (p ^. PersonId)
 
 
@@ -165,7 +173,6 @@ runDB :: (MonadReader ConnectionString m,
           MonadIO m,
           MonadBaseControl IO m,
           MonadUnliftIO m,
-          MonadLoggerIO m,
           MonadLogger m)
       => SqlPersistT m a -> m a
 runDB query = do

examples/esqueleto-examples.cabal

@@ -1,49 +0,0 @@
-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

@@ -13,7 +13,8 @@ extra-source-files:
 dependencies:
 - base
 - esqueleto
-- persistent >= 2.12
+- persistent
+- persistent-template
 - persistent-postgresql
 - mtl
 - monad-logger

src/Database/Esqueleto.hs

@@ -1,8 +1,8 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# 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:
@@ -32,15 +32,11 @@
 -- Other than identifier name clashes, @esqueleto@ does not
 -- conflict with @persistent@ in any way.
 --
--- Note that the facilities for @JOIN@ have been significantly improved in the
+-- Note that the faciliites 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." #-}
+module Database.Esqueleto
   ( -- * Setup
     -- $setup
 
@@ -79,6 +75,8 @@ module Database.Esqueleto {-# WARNING "This module will switch over to the Exper
   , else_
   , from
   , Value(..)
+  , pattern Value
+  , unValue
   , ValueList(..)
   , OrderBy
   , DistinctOn
@@ -97,7 +95,6 @@ module Database.Esqueleto {-# WARNING "This module will switch over to the Exper
   , SqlExpr
   , SqlEntity
   , select
-  , selectOne
   , selectSource
   , delete
   , deleteCount
@@ -129,8 +126,14 @@ module Database.Esqueleto {-# WARNING "This module will switch over to the Exper
   , module Database.Esqueleto.Internal.PersistentImport
   ) where
 
-import Database.Esqueleto.Legacy
+import Control.Monad.IO.Class (MonadIO)
+import Control.Monad.Trans.Reader (ReaderT)
+import Data.Int (Int64)
+import qualified Data.Map.Strict as Map
+import Database.Esqueleto.Internal.Language
 import Database.Esqueleto.Internal.PersistentImport
+import Database.Esqueleto.Internal.Sql
+import qualified Database.Persist
 
 
 -- $setup

src/Database/Esqueleto/Experimental.hs

@@ -4,8 +4,8 @@
 -- 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".
+-- Esqueleto users are encouraged to migrate to this module, as it will become
+-- the default in a new major version @4.0.0.0@.
 module Database.Esqueleto.Experimental
     ( -- * Setup
       -- $setup
@@ -90,7 +90,7 @@ module Database.Esqueleto.Experimental
     , joinV
     , withNonNull
 
-    , countRows
+    , countRows_
     , count
     , countDistinct
 
@@ -170,6 +170,7 @@ module Database.Esqueleto.Experimental
     , then_
     , else_
     , Value(..)
+    , pattern Value
     , ValueList(..)
     , OrderBy
     , DistinctOn
@@ -190,7 +191,6 @@ module Database.Esqueleto.Experimental
     , SqlExpr
     , SqlEntity
     , select
-    , selectOne
     , selectSource
     , delete
     , deleteCount
@@ -219,9 +219,13 @@ module Database.Esqueleto.Experimental
     , module Database.Esqueleto.Internal.PersistentImport
     ) where
 
-import Database.Esqueleto.Internal.Internal hiding (From, from, on)
+import Data.Coerce
+import Database.Esqueleto.Internal.Internal hiding
+       (From, from, groupBy, on, sum_, (?.), (^.))
+import qualified Database.Esqueleto.Internal.Internal as I ((?.), (^.))
 import Database.Esqueleto.Internal.PersistentImport
 
+import Database.Esqueleto.Experimental.Aggregates
 import Database.Esqueleto.Experimental.From
 import Database.Esqueleto.Experimental.From.CommonTableExpression
 import Database.Esqueleto.Experimental.From.Join
@@ -561,3 +565,4 @@ import Database.Esqueleto.Experimental.ToMaybe
 -- )
 -- @
 --
+--

src/Database/Esqueleto/Experimental/Aggregates.hs

@@ -0,0 +1,153 @@
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Database.Esqueleto.Experimental.Aggregates
+    where
+
+import Control.Monad.IO.Class
+import qualified Control.Monad.Trans.Writer as W
+import Data.Coerce (Coercible, coerce)
+import Data.Proxy
+import Database.Esqueleto.Internal.Internal
+       ( GroupByClause(..)
+       , SideData(..)
+       , SqlExpr(..)
+       , SqlQuery(..)
+       , SqlQueryHaving(..)
+       , SqlSelect(..)
+       , ToSomeValues(..)
+       , noMeta
+       , select
+       , unsafeSqlFunction
+       )
+import qualified Database.Esqueleto.Internal.Internal as I
+import Database.Esqueleto.Internal.PersistentImport
+       ( Entity
+       , EntityField
+       , Key
+       , PersistEntity
+       , PersistField
+       , SqlReadT
+       , persistIdField
+       )
+
+class SqlExprEntity expr where
+    (^.) :: (PersistEntity val, PersistField typ)
+        => expr (Entity val)
+        -> EntityField val typ
+        -> expr typ
+    (?.) :: (PersistEntity val, PersistField typ)
+        => expr (Maybe (Entity val))
+        -> EntityField val typ
+        -> expr (Maybe typ)
+
+    -- | Project a field of an entity.
+instance SqlExprEntity SqlExpr where
+    (^.) = (I.^.)
+    (?.) = (I.?.)
+
+newtype SqlAggregate source a = SqlAggregate { unsafeSqlAggregate :: SqlExpr a }
+deriving via SqlExpr instance SqlExprEntity (SqlAggregate source)
+instance forall a source. PersistField a => SqlSelect (SqlAggregate source a) a where
+    sqlSelectCols info (SqlAggregate e) = sqlSelectCols info e
+    sqlSelectColCount = const 1
+    sqlSelectProcessRow _ = sqlSelectProcessRow (Proxy :: Proxy (SqlExpr a))
+instance SqlQueryHaving (SqlAggregate source Bool) where
+    having expr = Q $ W.tell mempty { sdHavingClause = I.Where (coerce expr) }
+instance SqlQueryHaving (SqlAggregate source (Maybe Bool)) where
+    having expr = Q $ W.tell mempty { sdHavingClause = I.Where (coerce expr) }
+
+test :: (PersistEntity ent, PersistField a, PersistField b, PersistField c)
+     => SqlExpr (Maybe (Entity ent))
+     -> EntityField ent a
+     -> SqlExpr b
+     -> SqlExpr c
+     -> SqlQuery (SqlExpr (Maybe a), SqlExpr b, SqlExpr (Maybe Int), SqlExpr Int)
+test ent field y other = do
+    groupBy (ent, y) $ \(ent', y') ->
+        pure (ent' ?. field, y', sum_ other, countRows_)
+
+
+-- Tuple magic, only SqlExprs are on the leaves.
+-- The Coercible instance from the SqlExpr a -> SqlExpr b allows 0 cost casting
+class Coercible a r => Aggregateable a r | a -> r, r -> a where
+    toAggregate :: a -> r
+    toAggregate = coerce
+
+    fromAggregate :: r -> a
+    fromAggregate = coerce
+
+data GroupedValue
+instance Aggregateable () () where
+instance Aggregateable (SqlExpr a) (SqlAggregate GroupedValue a) where
+instance (Aggregateable a ra, Aggregateable b rb) => Aggregateable (a,b) (ra, rb) where
+instance
+    ( Aggregateable a ra
+    , Aggregateable b rb
+    , Aggregateable c rc
+    ) => Aggregateable (a,b,c) (ra,rb,rc) where
+instance
+    ( Aggregateable a ra
+    , Aggregateable b rb
+    , Aggregateable c rc
+    , Aggregateable d rd
+    ) => Aggregateable (a,b,c,d) (ra,rb,rc,rd) where
+instance
+    ( Aggregateable a ra
+    , Aggregateable b rb
+    , Aggregateable c rc
+    , Aggregateable d rd
+    , Aggregateable e re
+    ) => Aggregateable (a,b,c,d,e) (ra,rb,rc,rd,re) where
+instance
+    ( Aggregateable a ra
+    , Aggregateable b rb
+    , Aggregateable c rc
+    , Aggregateable d rd
+    , Aggregateable e re
+    , Aggregateable f rf
+    ) => Aggregateable (a,b,c,d,e,f) (ra,rb,rc,rd,re,rf) where
+instance
+    ( Aggregateable a ra
+    , Aggregateable b rb
+    , Aggregateable c rc
+    , Aggregateable d rd
+    , Aggregateable e re
+    , Aggregateable f rf
+    , Aggregateable g rg
+    ) => Aggregateable (a,b,c,d,e,f,g) (ra,rb,rc,rd,re,rf,rg) where
+instance
+    ( Aggregateable a ra
+    , Aggregateable b rb
+    , Aggregateable c rc
+    , Aggregateable d rd
+    , Aggregateable e re
+    , Aggregateable f rf
+    , Aggregateable g rg
+    , Aggregateable h rh
+    ) => Aggregateable (a,b,c,d,e,f,g,h) (ra,rb,rc,rd,re,rf,rg,rh) where
+
+groupBy :: ( ToSomeValues a
+           , Aggregateable a a'
+           , Aggregateable b b'
+           ) => a -> (a' -> SqlQuery b') -> SqlQuery b
+groupBy a f = do
+    Q $ W.tell $ mempty{sdGroupByClause = GroupBy $ toSomeValues a }
+    fmap fromAggregate $ f $ toAggregate a
+
+-- Aggregation Functions
+countRows_ :: forall n s. (PersistField n, Integral n) => SqlAggregate s n
+countRows_ = SqlAggregate $ ERaw noMeta $ \_ _ -> ("COUNT(*)", [])
+
+sum_ :: forall n a w. (PersistField a, PersistField n, Integral n) => SqlExpr a -> SqlAggregate w (Maybe n)
+sum_ = coerce . unsafeSqlFunction "SUM"
+

src/Database/Esqueleto/Experimental/From.hs

@@ -18,8 +18,9 @@
 module Database.Esqueleto.Experimental.From
     where
 
+import Control.Arrow (first)
+import Control.Monad (ap)
 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
@@ -27,8 +28,6 @@ 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.
@@ -54,7 +53,7 @@ type RawFn = NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue])
 -- the FromRaw FromClause constructor directly when converting
 -- from a @From@ to a @SqlQuery@ using @from@
 --
--- @since 3.5.0.0
+-- /Since: 3.5.0.0/
 newtype From a = From
     { unFrom :: SqlQuery (a, RawFn)}
 
@@ -64,13 +63,13 @@ newtype From a = From
 -- as well as supporting backwards compatibility for the
 -- data constructor join tree used prior to /3.5.0.0/
 --
--- @since 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" #-}
+{-# DEPRECATED Table "/Since: 3.5.0.0/ - use 'table' instead" #-}
 data Table a = Table
 
 instance PersistEntity ent => ToFrom (Table ent) (SqlExpr (Entity ent)) where
@@ -82,18 +81,18 @@ instance PersistEntity ent => ToFrom (Table ent) (SqlExpr (Entity ent)) where
 -- select $ from $ table \@People
 -- @
 --
--- @since 3.5.0.0
+-- /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)
+    ident <- newIdentFor (entityDB 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
+            let db@(DBName dbText) = entityDB def
+            in ( fromDBName info db <>
+                     if dbText == identText
                      then mempty
                      else " AS " <> useIdent info ident
                , mempty
@@ -121,7 +120,7 @@ instance (SqlSelect a r, ToAlias a, ToAliasReference a) => ToFrom (SqlQuery a) a
 --      ...
 -- @
 --
--- @since 3.5.0.0
+-- /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

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

@@ -12,6 +12,7 @@ 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)
+import Database.Esqueleto.Internal.PersistentImport (DBName(..))
 
 -- | @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

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

@@ -10,12 +10,12 @@
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 
-{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints #-}
 
 module Database.Esqueleto.Experimental.From.Join
     where
 
-import Data.Bifunctor (first)
+import Control.Arrow (first)
 import Data.Kind (Constraint)
 import Data.Proxy
 import qualified Data.Text.Lazy.Builder as TLB
@@ -39,59 +39,46 @@ import GHC.TypeLits
 -- See the examples at the beginning of this module to see how this
 -- operator is used in 'JOIN' operations.
 data (:&) a b = a :& b
+    deriving (Show, Eq)
 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
+fromInductiveTupleP :: Proxy (a :& b) -> Proxy (a, b)
+fromInductiveTupleP = const Proxy
+toInductiveTuple :: (a, b) -> (a :& b)
+toInductiveTuple (a, b) = a :& b
+
+instance (SqlSelect a a', SqlSelect b b') => SqlSelect (a :& b) (a' :& b') where
+    sqlSelectCols esc (a :& b) = sqlSelectCols esc (a, b)
+    sqlSelectColCount  = sqlSelectColCount . fromInductiveTupleP
+    sqlSelectProcessRow p = fmap toInductiveTuple . sqlSelectProcessRow (fromInductiveTupleP p)
+
+class ValidOnClause a where
+    -- | 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 :: a -> (b -> SqlExpr Bool) -> (a, b -> SqlExpr Bool)
+    on = (,)
+infix 9 `on`
+
 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 :: TLB.Builder -> RawFn -> RawFn -> Maybe (SqlExpr Bool) -> RawFn
 fromJoin joinKind lhs rhs monClause =
     \paren info ->
         first (parensM paren) $
@@ -104,14 +91,14 @@ fromJoin joinKind lhs rhs monClause =
         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, b -> SqlExpr 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 "`on` " ':<>: 'ShowType (expected -> SqlExpr Bool)
                     ':$$: 'Text ""
                   )
 
@@ -128,11 +115,11 @@ type family HasOnClause actual expected :: Constraint where
 --         p ^. PersonId ==. bp ^. BlogPostAuthorId)
 -- @
 --
--- @since 3.5.0.0
+-- /Since: 3.5.0.0/
 innerJoin :: ( ToFrom a a'
              , ToFrom b b'
              , HasOnClause rhs (a' :& b')
-             , rhs ~ (b, (a' :& b') -> SqlExpr (Value Bool))
+             , rhs ~ (b, (a' :& b') -> SqlExpr Bool)
              ) => a -> rhs -> From (a' :& b')
 innerJoin lhs (rhs, on') = From $ do
      (leftVal, leftFrom) <- unFrom (toFrom lhs)
@@ -150,13 +137,13 @@ innerJoin lhs (rhs, on') = From $ do
 --
 -- See example 6
 --
--- @since 3.5.0.0
+-- /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))
+                    , rhs ~ (a' -> SqlQuery b, (a' :& b) -> SqlExpr Bool)
                     )
                  => a -> rhs -> From (a' :& b)
 innerJoinLateral lhs (rhsFn, on') = From $ do
@@ -175,7 +162,7 @@ innerJoinLateral lhs (rhsFn, on') = From $ do
 -- \`crossJoin\` table \@BlogPost
 -- @
 --
--- @since 3.5.0.0
+-- /Since: 3.5.0.0/
 crossJoin :: ( ToFrom a a'
              , ToFrom b b'
              ) => a -> b -> From (a' :& b')
@@ -194,7 +181,7 @@ crossJoin lhs rhs = From $ do
 --
 -- See example 6
 --
--- @since 3.5.0.0
+-- /Since: 3.5.0.0/
 crossJoinLateral :: ( ToFrom a a'
                     , SqlSelect b r
                     , ToAlias b
@@ -223,12 +210,12 @@ crossJoinLateral lhs rhsFn = From $ do
 --         p ^. PersonId ==. bp ?. BlogPostAuthorId)
 -- @
 --
--- @since 3.5.0.0
+-- /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))
+            , rhs ~ (b, (a' :& ToMaybeT b') -> SqlExpr Bool)
             ) => a -> rhs -> From (a' :& ToMaybeT b')
 leftJoin lhs (rhs, on') = From $ do
      (leftVal, leftFrom) <- unFrom (toFrom lhs)
@@ -247,14 +234,14 @@ leftJoin lhs (rhs, on') = From $ do
 --
 -- See example 6 for how to use LATERAL
 --
--- @since 3.5.0.0
+-- /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))
+                   , rhs ~ (a' -> SqlQuery b, (a' :& ToMaybeT b) -> SqlExpr Bool)
                    )
                  => a -> rhs -> From (a' :& ToMaybeT b)
 leftJoinLateral lhs (rhsFn, on') = From $ do
@@ -279,12 +266,12 @@ leftJoinLateral lhs (rhsFn, on') = From $ do
 --         p ?. PersonId ==. bp ^. BlogPostAuthorId)
 -- @
 --
--- @since 3.5.0.0
+-- /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))
+             , rhs ~ (b, (ToMaybeT a' :& b') -> SqlExpr Bool)
              ) => a -> rhs -> From (ToMaybeT a' :& b')
 rightJoin lhs (rhs, on') = From $ do
      (leftVal, leftFrom) <- unFrom (toFrom lhs)
@@ -307,13 +294,13 @@ rightJoin lhs (rhs, on') = From $ do
 --         p ?. PersonId ==. bp ?. BlogPostAuthorId)
 -- @
 --
--- @since 3.5.0.0
+-- /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))
+                 , rhs ~ (b, (ToMaybeT a' :& ToMaybeT b') -> SqlExpr Bool)
                  ) => a -> rhs -> From (ToMaybeT a' :& ToMaybeT b')
 fullOuterJoin lhs (rhs, on') = From $ do
      (leftVal, leftFrom) <- unFrom (toFrom lhs)
@@ -347,7 +334,7 @@ class DoInnerJoin lateral lhs rhs res | lateral rhs lhs -> res where
 instance ( ToFrom a a'
          , ToFrom b b'
          , HasOnClause rhs (a' :& b')
-         , rhs ~ (b, (a' :& b') -> SqlExpr (Value Bool))
+         , rhs ~ (b, (a' :& b') -> SqlExpr Bool)
          ) => DoInnerJoin NotLateral a rhs (a' :& b') where
     doInnerJoin _ = innerJoin
 
@@ -356,7 +343,7 @@ instance ( ToFrom a a'
          , ToAlias b
          , ToAliasReference b
          , d ~ (a' :& b)
-         ) => DoInnerJoin Lateral a (a' -> SqlQuery b, d -> SqlExpr (Value Bool)) d where
+         ) => DoInnerJoin Lateral a (a' -> SqlQuery b, d -> SqlExpr Bool) d where
     doInnerJoin _ = innerJoinLateral
 
 instance ( DoInnerJoin lateral lhs rhs r, lateral ~ IsLateral rhs )
@@ -371,7 +358,7 @@ instance ( ToFrom a a'
          , ToMaybe b'
          , ToMaybeT b' ~ mb
          , HasOnClause rhs (a' :& mb)
-         , rhs ~ (b, (a' :& mb) -> SqlExpr (Value Bool))
+         , rhs ~ (b, (a' :& mb) -> SqlExpr Bool)
          ) => DoLeftJoin NotLateral a rhs (a' :& mb) where
     doLeftJoin _ = leftJoin
 
@@ -381,7 +368,7 @@ instance ( ToFrom a a'
          , SqlSelect b r
          , ToAlias b
          , ToAliasReference b
-         ) => DoLeftJoin Lateral a (a' -> SqlQuery b, d -> SqlExpr (Value Bool)) d where
+         ) => DoLeftJoin Lateral a (a' -> SqlQuery b, d -> SqlExpr Bool) d where
     doLeftJoin _ = leftJoinLateral
 
 instance ( DoLeftJoin lateral lhs rhs r, lateral ~ IsLateral rhs )
@@ -407,7 +394,7 @@ instance ( ToFrom a a'
          , ToMaybeT a' ~ ma
          , HasOnClause rhs (ma :& b')
          , ErrorOnLateral b
-         , rhs ~ (b, (ma :& b') -> SqlExpr (Value Bool))
+         , rhs ~ (b, (ma :& b') -> SqlExpr Bool)
          ) => ToFrom (RightOuterJoin a rhs) (ma :& b') where
     toFrom (RightOuterJoin a b) = rightJoin a b
 
@@ -419,7 +406,7 @@ instance ( ToFrom a a'
          , ToMaybeT b' ~ mb
          , HasOnClause rhs (ma :& mb)
          , ErrorOnLateral b
-         , rhs ~ (b, (ma :& mb) -> SqlExpr (Value Bool))
+         , rhs ~ (b, (ma :& mb) -> SqlExpr Bool)
          ) => ToFrom (FullOuterJoin a rhs) (ma :& mb) where
     toFrom (FullOuterJoin a b) = fullOuterJoin a b
 

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

@@ -21,14 +21,15 @@ 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)
+import Database.Esqueleto.Internal.PersistentImport
+       (DBName(..), Entity, PersistEntity, 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
+-- /Since: 3.5.0.0/
 newtype SqlSetOperation a = SqlSetOperation
     { unSqlSetOperation :: NeedParens -> SqlQuery (a, IdentInfo -> (TLB.Builder, [PersistValue]))}
 
@@ -41,7 +42,7 @@ instance ToAliasReference a => ToFrom (SqlSetOperation a) a where
 
 -- | Type class to support direct use of @SqlQuery@ in a set operation tree
 --
--- @since 3.5.0.0
+-- /Since: 3.5.0.0/
 class ToSqlSetOperation a r | a -> r where
     toSqlSetOperation :: a -> SqlSetOperation r
 instance ToSqlSetOperation (SqlSetOperation a) a where
@@ -66,7 +67,7 @@ instance (SqlSelect a r, ToAlias a, ToAliasReference a) => ToSqlSetOperation (Sq
             pure (aliasedValue, \info -> first (parensM p') $ toRawSql SELECT info aliasedQuery)
 
 -- | Helper function for defining set operations
--- @since 3.5.0.0
+-- /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
@@ -82,7 +83,7 @@ instance ToSqlSetOperation a a' => ToSqlSetOperation (Union a a) a' where
 -- | Overloaded @union_@ function to support use in both 'SqlSetOperation'
 -- and 'withRecursive'
 --
--- @since 3.5.0.0
+-- /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
@@ -94,7 +95,7 @@ instance (ToSqlSetOperation a c, ToSqlSetOperation b c, res ~ SqlSetOperation c)
 -- | Overloaded @unionAll_@ function to support use in both 'SqlSetOperation'
 -- and 'withRecursive'
 --
--- @since 3.5.0.0
+-- /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

src/Database/Esqueleto/Experimental/ToAlias.hs

@@ -15,27 +15,23 @@ type ToAliasT a = a
 class ToAlias a where
     toAlias :: a -> SqlQuery a
 
-instance ToAlias (SqlExpr (Value a)) where
+instance {-# OVERLAPPABLE #-} ToAlias (SqlExpr a) where
     toAlias e@(ERaw m f)
-      | Just _ <- sqlExprMetaAlias m = pure e
+      | Just _ <- sqlExprMetaAlias m, not (sqlExprMetaIsReference 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
+    toAlias (ERaw m f) = 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
+    toAlias (ERaw m f) = 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

src/Database/Esqueleto/Experimental/ToAliasReference.hs

@@ -16,7 +16,7 @@ type ToAliasReferenceT a = a
 class ToAliasReference a where
     toAliasReference :: Ident -> a -> SqlQuery a
 
-instance ToAliasReference (SqlExpr (Value a)) where
+instance {-# OVERLAPPABLE #-} ToAliasReference (SqlExpr a) where
     toAliasReference aliasSource (ERaw m _)
       | Just alias <- sqlExprMetaAlias m = pure $ ERaw m{sqlExprMetaIsReference = True} $ \_ info ->
           (useIdent info aliasSource <> "." <> useIdent info alias, [])
@@ -24,7 +24,7 @@ instance ToAliasReference (SqlExpr (Value a)) where
 
 instance ToAliasReference (SqlExpr (Entity a)) where
     toAliasReference aliasSource (ERaw m _)
-      | Just _ <- sqlExprMetaAlias m =
+      | Just _ <- sqlExprMetaAlias m, False <- sqlExprMetaIsReference m =
           pure $ ERaw m{sqlExprMetaIsReference = True} $ \_ info ->
             (useIdent info aliasSource, [])
     toAliasReference _ e = pure e

src/Database/Esqueleto/Experimental/ToMaybe.hs

@@ -15,18 +15,10 @@ 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 (SqlExpr a) where
+    type ToMaybeT (SqlExpr a) = SqlExpr (Maybe (Nullable a))
+    toMaybe = veryUnsafeCoerceSqlExpr
 
 instance (ToMaybe a, ToMaybe b) => ToMaybe (a,b) where
     type ToMaybeT (a, b) = (ToMaybeT a, ToMaybeT b)

src/Database/Esqueleto/Experimental/WindowFunctions.hs

@@ -0,0 +1,270 @@
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Database.Esqueleto.Experimental.WindowFunctions
+    where
+
+import Control.Arrow (first)
+import Data.Coerce (coerce)
+import Data.Int (Int64)
+import Data.Semigroup (First(..))
+import qualified Data.Text.Lazy.Builder as TLB
+import Database.Esqueleto.Experimental.Aggregates
+import Database.Esqueleto.Internal.Internal
+       ( IdentInfo
+       , NeedParens(..)
+       , OrderBy
+       , SideData(..)
+       , SomeValue(..)
+       , SqlExpr(..)
+       , SqlQuery(..)
+       , SqlSelect(..)
+       , ToSomeValues(..)
+       , Value(..)
+       , asc
+       , noMeta
+       , parens
+       , parensM
+       , select
+       , uncommas'
+       , unsafeSqlFunction
+       , val
+       , (?.)
+       , (^.)
+       )
+import Database.Esqueleto.Internal.PersistentImport
+       ( Entity
+       , EntityField
+       , PersistEntity
+       , PersistField
+       , PersistValue(..)
+       , SqlReadT
+       , fromPersistValue
+       )
+
+--( "LAG(?) OVER (PARTITION BY ?, ? ORDER BY ? ASC ROWS BETWEEN ? PRECEEDING AND UNBOUNDED FOLLOWING)"
+--, [PersistInt64 10,PersistInt64 10,PersistBool True,PersistInt64 10,PersistInt64 1]
+--)
+example =
+    lag_ (val @Int64 10) Nothing Nothing `over_`
+        (  partitionBy_ (val @Int64 10, val True)
+        <> frame_ (rows $ between (preceeding 1) unboundedFollowing)
+        <> orderBy_ [asc (val @Int64 10)]
+        )
+
+example2 = countRows_ @Int64 `over_` ()
+
+lag :: SqlExpr (Value a) -> WindowExpr a
+lag v = lag_ v Nothing Nothing
+
+lag_ :: SqlExpr a -> Maybe (SqlExpr Int64) -> Maybe (SqlExpr a) -> WindowExpr a
+lag_ v mOffset mDefaultVal =
+    coerce $
+    case (mOffset, mDefaultVal) of
+      (Just offset, Just defaultVal) ->
+          unsafeSqlFunction "LAG" (v, offset, defaultVal)
+      (Just offset, Nothing) ->
+          unsafeSqlFunction "LAG" (v, offset)
+      (Nothing, _) ->
+          unsafeSqlFunction "LAG" v
+
+-- Phantom helper type
+data PartitionBy
+data Window = Window
+    { windowPartitionBy :: Maybe (First (SqlExpr PartitionBy))
+    , windowOrderBy     :: Maybe [SqlExpr OrderBy]
+    , windowFrame       :: Maybe (First Frame)
+    }
+
+partitionBy_ :: ToSomeValues a => a -> Window
+partitionBy_ expr = mempty{windowPartitionBy = Just $ First $ ERaw noMeta $ \_ info ->
+    let (b, v) = uncommas' $ fmap (\(SomeValue (ERaw _ f)) -> f Never info) $ toSomeValues expr
+    in ("PARTITION BY " <> b, v)
+                          }
+
+orderBy_ :: [SqlExpr OrderBy] -> Window
+orderBy_ []    = mempty
+orderBy_ exprs = mempty{windowOrderBy=Just exprs}
+
+class RenderWindow a where
+    renderWindow :: IdentInfo -> a -> (TLB.Builder, [PersistValue])
+instance RenderWindow () where
+    renderWindow _ = mempty
+instance RenderWindow Window where
+    renderWindow info window =
+        let (partition, partitionVal) = maybe mempty ((\(ERaw _ f) -> f Never info) . getFirst) (windowPartitionBy window)
+            (order, orderVal) = maybe mempty (first ((<>) " ORDER BY ") . uncommas' . fmap (\(ERaw _ f) -> f Never info)) (windowOrderBy window)
+            (frame, frameVal) = maybe mempty (renderWindow info . getFirst) (windowFrame window)
+        in (partition <> order <> frame, partitionVal <> orderVal <> frameVal)
+
+instance Semigroup Window where
+    (Window a b c) <> (Window a' b' c') = Window (a <> a') (b <> b') (c <> c')
+
+instance Monoid Window where
+    mempty = Window mempty mempty mempty
+    mappend = (<>)
+
+data Frame = Frame (Maybe FrameKind) FrameBody (Maybe FrameExclusion)
+
+frame_ :: ToFrame frame => frame -> Window
+frame_ f = mempty{windowFrame = Just $ First $ toFrame f}
+
+instance RenderWindow Frame where
+    renderWindow info (Frame mKind frameBody mExclusion) =
+        let (kind, kindVals) = maybe mempty (renderWindow info) mKind
+            (exclusion, exclusionVals) = maybe mempty (renderWindow info) mExclusion
+            (body, bodyVals) = renderWindow info frameBody
+        in (" " <> kind <> body <> exclusion, kindVals <> bodyVals <> exclusionVals)
+
+class ToFrame a where
+    toFrame :: a -> Frame
+instance ToFrame Frame where
+    toFrame = id
+
+newtype FrameKind = FrameKind { unFrameKind :: (TLB.Builder, [PersistValue]) }
+
+instance RenderWindow FrameKind where
+    renderWindow _ = unFrameKind
+
+frameKind :: ToFrame frame => TLB.Builder -> frame -> Frame
+frameKind tlb frame =
+    let Frame _ b e = toFrame frame
+    in Frame (Just (FrameKind (tlb <> " ", []))) b e
+
+range :: ToFrame frame => frame -> Frame
+range = frameKind "RANGE"
+
+rows :: ToFrame frame => frame -> Frame
+rows = frameKind "ROWS"
+
+groups :: ToFrame frame => frame -> Frame
+groups = frameKind "GROUPS"
+
+newtype FrameExclusion = FrameExclusion { unFrameExclusion :: (TLB.Builder, [PersistValue]) }
+
+instance RenderWindow FrameExclusion where
+    renderWindow _ = unFrameExclusion
+
+frameExclusion :: ToFrame frame => TLB.Builder -> frame -> Frame
+frameExclusion tlb frame =
+    let Frame k b _ = toFrame frame
+    in Frame k b (Just $ FrameExclusion (" EXCLUDE " <> tlb, []))
+
+excludeCurrentRow :: ToFrame frame => frame -> Frame
+excludeCurrentRow = frameExclusion "CURRENT ROW"
+
+excludeGroup :: ToFrame frame => frame -> Frame
+excludeGroup = frameExclusion "GROUP"
+
+excludeTies :: ToFrame frame => frame -> Frame
+excludeTies = frameExclusion "TIES"
+
+excludeNoOthers :: ToFrame frame => frame -> Frame
+excludeNoOthers = frameExclusion "NO OTHERS"
+
+-- In order to prevent runtime errors we do some magic rewriting of queries that wouldn't be valid SQL.
+-- In the case of an implicit frame end `following 10` would become BETWEEN 10 FOLLOWING AND CURRENT ROW
+-- This is illegal so `following 10` instead becomes `BETWEEN CURRENT_ROW AND 10 FOLLOWING`
+-- Additionally `BETWEEN` requires that the frame start be before the frame end.
+-- To prevent this error the frame will be flipped automatically.
+-- i.e. `between (following 10) (preceeding 10)` becomes `BETWEEEN 10 PRECEEDING AND 10 FOLLOWING`
+-- therefore `between (following 10) (preceeding 10) === between (preceeding 10) (following 10)
+data FrameBody
+    = FrameStart FrameRange
+    | FrameBetween FrameRange FrameRange
+
+instance ToFrame FrameBody where
+    toFrame b = Frame Nothing b Nothing
+
+instance RenderWindow FrameBody where
+    renderWindow info (FrameStart (FrameRangeFollowing b)) = renderWindow info (FrameBetween FrameRangeCurrentRow (FrameRangeFollowing b))
+    renderWindow info (FrameStart f) = renderWindow info f
+    renderWindow info (FrameBetween startRange endRange)
+          | startRange > endRange = renderWindow info (FrameBetween endRange startRange)
+    renderWindow  info (FrameBetween r r') =
+        let (b, v) = renderWindow info r
+            (b', v') = renderWindow info r'
+        in ("BETWEEN " <> b <> " AND " <> b', v <> v')
+
+instance ToFrame FrameRange where
+    toFrame r = Frame Nothing (FrameStart r) Nothing
+instance RenderWindow FrameRange where
+    renderWindow _ (FrameRangeCurrentRow) = ("CURRENT ROW", [])
+    renderWindow _ (FrameRangePreceeding bounds) = renderBounds bounds <> (" PRECEEDING", [])
+    renderWindow _ (FrameRangeFollowing bounds) = renderBounds bounds <> (" FOLLOWING", [])
+
+renderBounds :: FrameRangeBound -> (TLB.Builder, [PersistValue])
+renderBounds (FrameRangeUnbounded) = ("UNBOUNDED", [])
+renderBounds (FrameRangeBounded i) = ("?", [PersistInt64 i])
+
+data FrameRange
+    = FrameRangePreceeding FrameRangeBound
+    | FrameRangeCurrentRow
+    | FrameRangeFollowing FrameRangeBound
+    deriving Eq
+
+instance Ord FrameRange where
+    FrameRangePreceeding b1 <= FrameRangePreceeding b2 = b1 <= b2
+    FrameRangePreceeding _  <= FrameRangeCurrentRow    = True
+    FrameRangePreceeding _  <= FrameRangeFollowing  _  = True
+    FrameRangeCurrentRow    <= FrameRangePreceeding _  = False
+    FrameRangeCurrentRow    <= FrameRangeCurrentRow    = True
+    FrameRangeCurrentRow    <= FrameRangeFollowing  _  = True
+    FrameRangeFollowing  _  <= FrameRangePreceeding _  = False
+    FrameRangeFollowing  _  <= FrameRangeCurrentRow    = False
+    FrameRangeFollowing  b1 <= FrameRangeFollowing  b2 = b1 <= b2
+
+data FrameRangeBound
+    = FrameRangeUnbounded
+    | FrameRangeBounded Int64
+    deriving Eq
+
+instance Ord FrameRangeBound where
+    FrameRangeUnbounded <= FrameRangeBounded _ = False
+    FrameRangeUnbounded <= FrameRangeUnbounded = True
+    FrameRangeBounded _ <= FrameRangeUnbounded = True
+    FrameRangeBounded a <= FrameRangeBounded b = a <= b
+
+between :: FrameRange -> FrameRange -> FrameBody
+between = FrameBetween
+
+unboundedPreceeding :: FrameRange
+unboundedPreceeding = FrameRangePreceeding FrameRangeUnbounded
+
+preceeding :: Int64 -> FrameRange
+preceeding offset = FrameRangePreceeding (FrameRangeBounded offset)
+
+following :: Int64 -> FrameRange
+following offset = FrameRangeFollowing (FrameRangeBounded offset)
+
+unboundedFollowing :: FrameRange
+unboundedFollowing = FrameRangeFollowing FrameRangeUnbounded
+
+currentRow :: FrameRange
+currentRow = FrameRangeCurrentRow
+
+data WindowAggregate
+class Over expr where
+    over_ :: RenderWindow window => expr a -> window -> SqlAggregate WindowAggregate a
+
+newtype WindowExpr a = WindowExpr { unsafeWindowExpr :: SqlExpr a }
+instance Over WindowExpr where
+    (WindowExpr (ERaw _ f)) `over_` window = SqlAggregate $ ERaw noMeta $ \p info ->
+        let (b, v) = f Never info
+            (w, vw) = renderWindow info window
+        in (parensM p $ b <> " OVER " <> parens w , v <> vw)
+
+-- Only universally quantified SqlAggregate's can be used
+-- TODO Add nicer type error
+data NoWindow
+deriving via WindowExpr instance (s ~ NoWindow) => Over (SqlAggregate s)

src/Database/Esqueleto/Internal/ExprParser.hs

@@ -16,7 +16,6 @@ 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:
@@ -44,7 +43,7 @@ parseOnExpr sqlBackend text = do
 -- with postgresql, mysql, and sqlite backends.
 mkEscapeChar :: SqlBackend -> Either String Char
 mkEscapeChar sqlBackend =
-    case Text.uncons (getEscapedRawName "" sqlBackend) of
+    case Text.uncons (connEscapeName sqlBackend (DBName "")) of
         Nothing ->
             Left "Failed to get an escape character from the SQL backend."
         Just (c, _) ->
@@ -64,9 +63,9 @@ skipToEscape escapeChar = void (takeWhile (/= escapeChar))
 
 parseEscapedIdentifier :: ExprParser [Char]
 parseEscapedIdentifier escapeChar = do
-    _ <- char escapeChar
+    char escapeChar
     str <- parseEscapedChars escapeChar
-    _ <- char escapeChar
+    char escapeChar
     pure str
 
 parseTableAccess :: ExprParser TableAccess

src/Database/Esqueleto/Internal/Language.hs

@@ -0,0 +1,143 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- | This is an internal module, anything exported by this module
+-- may change without a major version bump.  Please use only
+-- "Database.Esqueleto" if possible.
+--
+-- This module is deprecated as of 3.4.0.1, and will be removed in 3.5.0.0.
+module Database.Esqueleto.Internal.Language
+    {-# DEPRECATED "Use Database.Esqueleto.Internal.Internal instead. This module will be removed in 3.5.0.0 " #-}
+    ( -- * The pretty face
+      from
+    , Value
+    , pattern Value
+    , unValue
+    , ValueList(..)
+    , SomeValue(..)
+    , ToSomeValues(..)
+    , InnerJoin(..)
+    , CrossJoin(..)
+    , LeftOuterJoin(..)
+    , RightOuterJoin(..)
+    , FullOuterJoin(..)
+    , OnClauseWithoutMatchingJoinException(..)
+    , OrderBy
+    , DistinctOn
+    , Update
+    , Insertion
+    , LockingKind(..)
+    , SqlString
+    , ToBaseId(..)
+      -- * The guts
+    , JoinKind(..)
+    , IsJoinKind(..)
+    , BackendCompatible(..)
+    , PreprocessedFrom
+    , From
+    , FromPreprocess
+    , when_
+    , then_
+    , else_
+    , 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
+    , subSelectList
+    , subSelectForeign
+    , subSelectUnsafe
+    ) where
+
+import Database.Esqueleto.Internal.Internal
+import Database.Esqueleto.Internal.PersistentImport

src/Database/Esqueleto/Internal/PersistentImport.hs

@@ -3,141 +3,142 @@
 module Database.Esqueleto.Internal.PersistentImport
 -- NOTE: switch back to a module export once https://gitlab.haskell.org/ghc/ghc/merge_requests/276
 -- 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
+    ( 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,
+    askLogFunc,
+    close',
+    createSqlPool,
+    liftSqlPersistMPool,
+    runSqlConn,
+    runSqlPersistM,
+    runSqlPersistMPool,
+    runSqlPool,
+    withSqlConn,
+    withSqlPool,
+    readToUnknown,
+    readToWrite,
+    writeToUnknown,
+    entityKeyFields,
+    entityPrimary,
+    fromPersistValueText,
+    keyAndEntityFields,
+    toEmbedEntityDef,
+    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(..),
+    DBName(..),
+    EmbedEntityDef(..),
+    EmbedFieldDef(..),
+    EntityDef(..),
+    ExtraLine,
+    FieldDef(..),
+    FieldType(..),
+    ForeignDef(..),
+    ForeignFieldDef,
+    HaskellName(..),
+    IsNullable(..),
+    OnlyUniqueException(..),
+    PersistException(..),
+    PersistFilter(..),
+    PersistUpdate(..),
+    PersistValue(..),
+    ReferenceDef(..),
+    SqlType(..),
+    UniqueDef(..),
+    UpdateException(..),
+    WhyNullable(..)
     ) where
 
 import Database.Persist.Sql hiding

src/Database/Esqueleto/Internal/Sql.hs

@@ -0,0 +1,78 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+
+-- | This is an internal module, anything exported by this module
+-- may change without a major version bump.  Please use only
+-- "Database.Esqueleto" if possible.
+--
+-- This module is deprecated as of 3.4.0.1, and will be removed in 3.5.0.0.
+module Database.Esqueleto.Internal.Sql
+    {-# DEPRECATED "Use Database.Esqueleto.Internal.Internal instead. This module will be removed in 3.5.0.0 " #-}
+    ( -- * The pretty face
+      SqlQuery
+    , SqlExpr(..)
+    , SqlEntity
+    , select
+    , selectSource
+    , delete
+    , deleteCount
+    , update
+    , updateCount
+    , insertSelect
+    , insertSelectCount
+      -- * The guts
+    , unsafeSqlCase
+    , unsafeSqlBinOp
+    , unsafeSqlValue
+    , unsafeSqlEntity
+    , unsafeSqlCastAs
+    , unsafeSqlFunction
+    , unsafeSqlExtractSubField
+    , UnsafeSqlFunctionArgument
+    , OrderByClause
+    , rawSelectSource
+    , runSource
+    , rawEsqueleto
+    , toRawSql
+    , Mode(..)
+    , NeedParens(..)
+    , IdentState
+    , renderExpr
+    , initialIdentState
+    , IdentInfo
+    , SqlSelect(..)
+    , veryUnsafeCoerceSqlExprValue
+    , veryUnsafeCoerceSqlExprValueList
+    -- * Helper functions
+    , renderQueryToText
+    , renderQuerySelect
+    , renderQueryUpdate
+    , renderQueryDelete
+    , renderQueryInsertInto
+    , makeOrderByNoNewline
+    , uncommas'
+    , parens
+    , toArgList
+    , builderToText
+    , Ident(..)
+    , valkey
+    , valJ
+    , deleteKey
+    , associateJoin
+    ) where
+
+import Database.Esqueleto.Internal.Internal

src/Database/Esqueleto/Legacy.hs

@@ -1,416 +0,0 @@
-{-# 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

@@ -14,5 +14,5 @@ import Database.Esqueleto.Internal.PersistentImport
 -- because MySQL uses `rand()`.
 --
 -- /Since: 2.6.0/
-random_ :: (PersistField a, Num a) => SqlExpr (Value a)
+random_ :: (PersistField a, Num a) => SqlExpr a
 random_ = unsafeSqlValue "RAND()"

src/Database/Esqueleto/PostgreSQL.hs

@@ -1,8 +1,6 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE Rank2Types #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -28,7 +26,6 @@ module Database.Esqueleto.PostgreSQL
     , insertSelectWithConflict
     , insertSelectWithConflictCount
     , filterWhere
-    , values
     -- * Internal
     , unsafeSqlAggregateFunction
     ) where
@@ -36,42 +33,37 @@ module Database.Esqueleto.PostgreSQL
 #if __GLASGOW_HASKELL__ < 804
 import Data.Semigroup
 #endif
-import Control.Arrow (first)
+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.List.NonEmpty (NonEmpty((:|)))
+import qualified Data.List.NonEmpty as NonEmpty
 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
 -- because MySQL uses `rand()`.
 --
 -- @since 2.6.0
-random_ :: (PersistField a, Num a) => SqlExpr (Value a)
+random_ :: (PersistField a, Num a) => SqlExpr a
 random_ = unsafeSqlValue "RANDOM()"
 
 -- | Empty array literal. (@val []@) does unfortunately not work
-emptyArray :: SqlExpr (Value [a])
+emptyArray :: SqlExpr [a]
 emptyArray = unsafeSqlValue "'{}'"
 
 -- | Coalesce an array with an empty default value
 maybeArray ::
      (PersistField a, PersistField [a])
-  => SqlExpr (Value (Maybe [a]))
-  -> SqlExpr (Value [a])
+  => SqlExpr (Maybe [a])
+  -> SqlExpr [a]
 maybeArray x = coalesceDefault [x] (emptyArray)
 
 -- | Aggregate mode
@@ -90,7 +82,7 @@ unsafeSqlAggregateFunction
     -> AggMode
     -> a
     -> [OrderByClause]
-    -> SqlExpr (Value b)
+    -> SqlExpr 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
@@ -114,14 +106,14 @@ unsafeSqlAggregateFunction name mode args orderByClauses = ERaw noMeta $ \_ info
 --- into an array.
 arrayAggWith
     :: AggMode
-    -> SqlExpr (Value a)
+    -> SqlExpr a
     -> [OrderByClause]
-    -> SqlExpr (Value (Maybe [a]))
+    -> SqlExpr (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 :: (PersistField a) => SqlExpr a -> SqlExpr (Maybe [a])
 arrayAgg x = arrayAggWith AggModeAll x []
 
 -- | (@array_agg@) Concatenate distinct input values, including @NULL@s, into
@@ -130,19 +122,19 @@ arrayAgg x = arrayAggWith AggModeAll x []
 -- @since 2.5.3
 arrayAggDistinct
     :: (PersistField a, PersistField [a])
-    => SqlExpr (Value a)
-    -> SqlExpr (Value (Maybe [a]))
+    => SqlExpr a
+    -> SqlExpr (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 :: SqlExpr [a] -> SqlExpr a -> SqlExpr [a]
 arrayRemove arr elem' = unsafeSqlFunction "array_remove" (arr, elem')
 
 -- | Remove @NULL@ values from an array
-arrayRemoveNull :: SqlExpr (Value [Maybe a]) -> SqlExpr (Value [a])
+arrayRemoveNull :: SqlExpr [Maybe a] -> SqlExpr [a]
 -- This can't be a call to arrayRemove because it changes the value type
 arrayRemoveNull x = unsafeSqlFunction "array_remove" (x, unsafeSqlValue "NULL")
 
@@ -152,10 +144,10 @@ arrayRemoveNull x = unsafeSqlFunction "array_remove" (x, unsafeSqlValue "NULL")
 stringAggWith ::
      SqlString s
   => AggMode -- ^ Aggregate mode (ALL or DISTINCT)
-  -> SqlExpr (Value s) -- ^ Input values.
-  -> SqlExpr (Value s) -- ^ Delimiter.
+  -> SqlExpr s -- ^ Input values.
+  -> SqlExpr s -- ^ Delimiter.
   -> [OrderByClause] -- ^ ORDER BY clauses
-  -> SqlExpr (Value (Maybe s)) -- ^ Concatenation.
+  -> SqlExpr (Maybe s) -- ^ Concatenation.
 stringAggWith mode expr delim os =
   unsafeSqlAggregateFunction "string_agg" mode (expr, delim) os
 
@@ -165,19 +157,19 @@ stringAggWith mode expr delim os =
 -- @since 2.2.8
 stringAgg ::
      SqlString s
-  => SqlExpr (Value s) -- ^ Input values.
-  -> SqlExpr (Value s) -- ^ Delimiter.
-  -> SqlExpr (Value (Maybe s)) -- ^ Concatenation.
+  => SqlExpr s -- ^ Input values.
+  -> SqlExpr s -- ^ Delimiter.
+  -> SqlExpr (Maybe s) -- ^ Concatenation.
 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
-chr :: SqlString s => SqlExpr (Value Int) -> SqlExpr (Value s)
+chr :: SqlString s => SqlExpr Int -> SqlExpr s
 chr = unsafeSqlFunction "chr"
 
-now_ :: SqlExpr (Value UTCTime)
+now_ :: SqlExpr UTCTime
 now_ = unsafeSqlFunction "NOW" ()
 
 upsert
@@ -214,7 +206,7 @@ upsertBy
     -- ^ the record in the database after the operation
 upsertBy uniqueKey record updates = do
     sqlB <- R.ask
-    case getConnUpsertSql sqlB of
+    case connUpsertSql sqlB of
         Nothing ->
             -- Postgres backend should have connUpsertSql, if this error is
             -- thrown, check changes on persistent
@@ -226,7 +218,7 @@ upsertBy uniqueKey record updates = do
     entDef = entityDef (Just record)
     updatesText conn = first builderToText $ renderUpdates conn updates
 #if MIN_VERSION_persistent(2,11,0)
-    uniqueFields = persistUniqueToFieldNames uniqueKey
+    uniqueFields = NonEmpty.fromList (persistUniqueToFieldNames uniqueKey)
     handler sqlB upsertSql = do
         let (updateText, updateVals) =
                 updatesText sqlB
@@ -289,8 +281,8 @@ insertSelectWithConflict
     -- violated. The expression takes the current and excluded value to produce
     -- the updates.
     -> SqlWriteT m ()
-insertSelectWithConflict unique query a =
-    void $ insertSelectWithConflictCount unique query a
+insertSelectWithConflict unique query =
+    void . insertSelectWithConflictCount unique query
 
 -- | Same as 'insertSelectWithConflict' but returns the number of rows affected.
 --
@@ -314,10 +306,10 @@ insertSelectWithConflictCount unique query conflictQuery = do
     updates = conflictQuery entCurrent entExcluded
     combine (tlb1,vals1) (tlb2,vals2) = (builderToText (tlb1 `mappend` tlb2), vals1 ++ vals2)
     entExcluded = unsafeSqlEntity (I "excluded")
-    tableName = unEntityNameDB . getEntityDBName . entityDef
+    tableName = unDBName . entityDB . entityDef
     entCurrent = unsafeSqlEntity (I (tableName proxy))
     uniqueDef = toUniqueDef unique
-    constraint = TLB.fromText . unConstraintNameDB . uniqueDBName $ uniqueDef
+    constraint = TLB.fromText . unDBName . uniqueDBName $ uniqueDef
     renderedUpdates :: (BackendCompatible SqlBackend backend) => backend -> (TLB.Builder, [PersistValue])
     renderedUpdates conn = renderUpdates conn updates
     conflict conn = (mconcat ([
@@ -358,11 +350,11 @@ insertSelectWithConflictCount unique query conflictQuery = do
 --
 -- @since 3.3.3.3
 filterWhere
-    :: SqlExpr (Value a)
+    :: SqlExpr a
     -- ^ Aggregate function
-    -> SqlExpr (Value Bool)
+    -> SqlExpr Bool
     -- ^ Filter clause
-    -> SqlExpr (Value a)
+    -> SqlExpr a
 filterWhere aggExpr clauseExpr = ERaw noMeta $ \_ info ->
     let (aggBuilder, aggValues) = case aggExpr of
             ERaw _ aggF     -> aggF Never info
@@ -371,68 +363,3 @@ filterWhere aggExpr clauseExpr = ERaw noMeta $ \_ 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

@@ -136,8 +136,9 @@ module Database.Esqueleto.PostgreSQL.JSON
     ) where
 
 import Data.Text (Text)
-import Database.Esqueleto.Internal.Internal hiding ((-.), (?.), (||.))
+import Database.Esqueleto.Internal.Language hiding ((-.), (?.), (||.))
 import Database.Esqueleto.Internal.PersistentImport
+import Database.Esqueleto.Internal.Sql
 import Database.Esqueleto.PostgreSQL.JSON.Instances
 
 infixl 6 ->., ->>., #>., #>>.
@@ -188,7 +189,7 @@ infixl 6 ||., -., --., #-.
 -- @
 --
 -- @since 3.1.0
-(->>.) :: JSONBExpr a -> JSONAccessor -> SqlExpr (Value (Maybe Text))
+(->>.) :: JSONBExpr a -> JSONAccessor -> SqlExpr (Maybe Text)
 (->>.) value (JSONKey txt) = unsafeSqlBinOp " ->> " value $ val txt
 (->>.) value (JSONIndex i) = unsafeSqlBinOp " ->> " value $ val i
 
@@ -252,7 +253,7 @@ infixl 6 ||., -., --., #-.
 -- @
 --
 -- @since 3.1.0
-(#>>.) :: JSONBExpr a -> [Text] -> SqlExpr (Value (Maybe Text))
+(#>>.) :: JSONBExpr a -> [Text] -> SqlExpr (Maybe Text)
 (#>>.)  value = unsafeSqlBinOp " #>> " value . mkTextArray
 
 -- | /Requires PostgreSQL version >= 9.4/
@@ -274,7 +275,7 @@ infixl 6 ||., -., --., #-.
 -- @
 --
 -- @since 3.1.0
-(@>.) :: JSONBExpr a -> JSONBExpr b -> SqlExpr (Value Bool)
+(@>.) :: JSONBExpr a -> JSONBExpr b -> SqlExpr Bool
 (@>.) = unsafeSqlBinOp " @> "
 
 -- | /Requires PostgreSQL version >= 9.4/
@@ -296,7 +297,7 @@ infixl 6 ||., -., --., #-.
 -- @
 --
 -- @since 3.1.0
-(<@.) :: JSONBExpr a -> JSONBExpr b -> SqlExpr (Value Bool)
+(<@.) :: JSONBExpr a -> JSONBExpr b -> SqlExpr Bool
 (<@.) = unsafeSqlBinOp " <@ "
 
 -- | /Requires PostgreSQL version >= 9.4/
@@ -319,7 +320,7 @@ infixl 6 ||., -., --., #-.
 -- @
 --
 -- @since 3.1.0
-(?.) :: JSONBExpr a -> Text -> SqlExpr (Value Bool)
+(?.) :: JSONBExpr a -> Text -> SqlExpr Bool
 (?.) value = unsafeSqlBinOp " ?? " value . val
 
 -- | /Requires PostgreSQL version >= 9.4/
@@ -342,7 +343,7 @@ infixl 6 ||., -., --., #-.
 -- @
 --
 -- @since 3.1.0
-(?|.) :: JSONBExpr a -> [Text] -> SqlExpr (Value Bool)
+(?|.) :: JSONBExpr a -> [Text] -> SqlExpr Bool
 (?|.) value = unsafeSqlBinOp " ??| " value . mkTextArray
 
 -- | /Requires PostgreSQL version >= 9.4/
@@ -365,7 +366,7 @@ infixl 6 ||., -., --., #-.
 -- @
 --
 -- @since 3.1.0
-(?&.) :: JSONBExpr a -> [Text] -> SqlExpr (Value Bool)
+(?&.) :: JSONBExpr a -> [Text] -> SqlExpr Bool
 (?&.) value = unsafeSqlBinOp " ??& " value . mkTextArray
 
 -- | /Requires PostgreSQL version >= 9.5/
@@ -578,5 +579,5 @@ infixl 6 ||., -., --., #-.
 (#-.) :: JSONBExpr a -> [Text] -> JSONBExpr b
 (#-.) value = unsafeSqlBinOp " #- " value . mkTextArray
 
-mkTextArray :: [Text] -> SqlExpr (Value PersistValue)
+mkTextArray :: [Text] -> SqlExpr PersistValue
 mkTextArray = val . PersistArray . fmap toPersistValue

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

@@ -2,21 +2,22 @@
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# language DerivingStrategies #-}
 
 module Database.Esqueleto.PostgreSQL.JSON.Instances where
 
-import Data.Aeson (FromJSON(..), ToJSON(..), encode, eitherDecodeStrict)
+import Data.Aeson (FromJSON(..), ToJSON(..), eitherDecodeStrict, encode)
 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 (Value, just, val)
 import Database.Esqueleto.Internal.PersistentImport
-import Database.Esqueleto.Internal.Internal (SqlExpr, Value, just, val)
+import Database.Esqueleto.Internal.Sql (SqlExpr)
 import GHC.Generics (Generic)
 
 -- | Newtype wrapper around any type with a JSON representation.
@@ -41,7 +42,7 @@ newtype JSONB a = JSONB { unJSONB :: a }
 -- | '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)))
+type JSONBExpr a = SqlExpr (Maybe (JSONB a))
 
 -- | Convenience function to lift a regular value into
 -- a 'JSONB' expression.
@@ -86,7 +87,7 @@ instance IsString JSONAccessor where
 
 -- | @since 3.1.0
 instance (FromJSON a, ToJSON a) => PersistField (JSONB a) where
-    toPersistValue = PersistLiteralEscaped . BSL.toStrict . encode . unJSONB
+    toPersistValue = PersistDbSpecific . 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)

src/Database/Esqueleto/SQLite.hs

@@ -14,5 +14,5 @@ import Database.Esqueleto.Internal.PersistentImport
 -- because MySQL uses `rand()`.
 --
 -- /Since: 2.6.0/
-random_ :: (PersistField a, Num a) => SqlExpr (Value a)
+random_ :: (PersistField a, Num a) => SqlExpr a
 random_ = unsafeSqlValue "RANDOM()"

stack-8.10.yaml

@@ -1,12 +0,0 @@
-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.8.yaml

@@ -1,12 +1,12 @@
-resolver: lts-16.31
+resolver: lts-16.14
 
 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
+- persistent-2.11.0.0
+- persistent-template-2.9.1.0
+- persistent-mysql-2.10.3
+- persistent-postgresql-2.11.0.0
+- persistent-sqlite-2.11.0.0

stack-nightly.yaml

@@ -1,14 +1,4 @@
-resolver: nightly-2022-03-29
-
+resolver: nightly-2020-09-20
 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

@@ -3,52 +3,10 @@
 # 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
+packages: []
 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
+    size: 467884
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2020/1/24.yaml
+    sha256: 55c1a4fc9222bc3b8cf91461f38e2641da675a7296f06528f47340c19d0c6e85
+  original: nightly-2020-01-24

stack.yaml

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

test/Common/Test/Import.hs

@@ -1,87 +0,0 @@
-{-# 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

@@ -1,189 +0,0 @@
-{-# 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

@@ -1,22 +0,0 @@
-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

@@ -4,15 +4,12 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 
-module MySQL.Test where
+module Main (main) 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 Control.Monad.Trans.Reader (ReaderT)
 import qualified Control.Monad.Trans.Resource as R
 import Database.Esqueleto
 import Database.Esqueleto.Experimental hiding (from, on)
@@ -25,16 +22,28 @@ import Database.Persist.MySQL
        , connectUser
        , defaultConnectInfo
        , withMySQLConn
-       , createMySQLPool
        )
-
 import Test.Hspec
 
 import Common.Test
 
-testMysqlSum :: SpecDb
+
+-- testMysqlRandom :: Spec
+-- testMysqlRandom = do
+--   -- This is known not to work until
+--   -- we can differentiate behavior by database
+--   it "works with random_" $
+--     run $ do
+--       _ <- select $ return (random_ :: SqlExpr (Value Double))
+--       return ()
+
+
+
+
+testMysqlSum :: Spec
 testMysqlSum = do
-  itDb "works with sum_" $ do
+  it "works with sum_" $
+    run $ do
       _ <- insert' p1
       _ <- insert' p2
       _ <- insert' p3
@@ -44,9 +53,13 @@ testMysqlSum = do
              return $ joinV $ sum_ (p ^. PersonAge)
       liftIO $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Double ) ]
 
-testMysqlTwoAscFields :: SpecDb
+
+
+
+testMysqlTwoAscFields :: Spec
 testMysqlTwoAscFields = do
-  itDb "works with two ASC fields (one call)" $ do
+  it "works with two ASC fields (one call)" $
+    run $ do
       p1e <- insert' p1
       p2e <- insert' p2
       p3e <- insert' p3
@@ -57,9 +70,13 @@ testMysqlTwoAscFields = do
              return p
       liftIO $ ret `shouldBe` [ p2e, p4e, p3e, p1e ]
 
-testMysqlOneAscOneDesc :: SpecDb
+
+
+
+testMysqlOneAscOneDesc :: Spec
 testMysqlOneAscOneDesc = do
-  itDb "works with one ASC and one DESC field (two calls)" $ do
+  it "works with one ASC and one DESC field (two calls)" $
+    run $ do
       p1e <- insert' p1
       p2e <- insert' p2
       p3e <- insert' p3
@@ -74,9 +91,10 @@ testMysqlOneAscOneDesc = do
 
 
 
-testMysqlCoalesce :: SpecDb
+testMysqlCoalesce :: Spec
 testMysqlCoalesce = do
-  itDb "works on PostgreSQL and MySQL with <2 arguments" $ do
+  it "works on PostgreSQL and MySQL with <2 arguments" $
+    run $ do
       _ :: [Value (Maybe Int)] <-
         select $
         from $ \p -> do
@@ -86,9 +104,10 @@ testMysqlCoalesce = do
 
 
 
-testMysqlUpdate :: SpecDb
+testMysqlUpdate :: Spec
 testMysqlUpdate = do
-  itDb "works on a simple example" $ do
+  it "works on a simple example" $
+    run $ do
       p1k <- insert p1
       p2k <- insert p2
       p3k <- insert p3
@@ -111,13 +130,20 @@ testMysqlUpdate = do
                               , Entity p1k (Person anon (Just 73) Nothing 1)
                               , Entity p3k p3 ]
 
-nameContains :: (SqlString s)
+
+
+
+nameContains :: (BaseBackend backend ~ SqlBackend,
+                 BackendCompatible SqlBackend backend,
+                 MonadIO m, SqlString s,
+                 IsPersistBackend backend, PersistQueryRead backend,
+                 PersistUniqueRead backend)
              => (SqlExpr (Value [Char])
              -> SqlExpr (Value s)
              -> SqlExpr (Value Bool))
              -> s
              -> [Entity Person]
-             -> SqlPersistT IO ()
+             -> ReaderT backend m ()
 nameContains f t expected = do
   ret <- select $
          from $ \p -> do
@@ -129,20 +155,22 @@ nameContains f t expected = do
   liftIO $ ret `shouldBe` expected
 
 
-testMysqlTextFunctions :: SpecDb
+testMysqlTextFunctions :: Spec
 testMysqlTextFunctions = do
   describe "text functions" $ do
-    itDb "like, (%) and (++.) work on a simple example" $ do
+    it "like, (%) and (++.) work on a simple example" $
+       run $ 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 :: Spec
 testMysqlUnionWithLimits = do
   describe "MySQL Union" $ do
-    itDb "supports limit/orderBy by parenthesizing" $ do
+    it "supports limit/orderBy by parenthesizing" $ do
+      run $ do
         mapM_ (insert . Foo) [1..6]
 
         let q1 = do
@@ -163,61 +191,59 @@ testMysqlUnionWithLimits = do
         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
+
+main :: IO ()
+main = do
+  hspec $ do
+    tests run
+
+    describe "Test MySQL locking" $ do
+      testLocking withConn
 
     describe "MySQL specific tests" $ do
-        -- definitely doesn't work at the moment
-        -- testMysqlRandom
-        testMysqlSum
-        testMysqlTwoAscFields
-        testMysqlOneAscOneDesc
-        testMysqlCoalesce
-        testMysqlUpdate
-        testMysqlTextFunctions
-        testMysqlUnionWithLimits
+      -- definitely doesn't work at the moment
+      -- testMysqlRandom
+      testMysqlSum
+      testMysqlTwoAscFields
+      testMysqlOneAscOneDesc
+      testMysqlCoalesce
+      testMysqlUpdate
+      testMysqlTextFunctions
+      testMysqlUnionWithLimits
+
+
+
+
+run, runSilent, runVerbose :: Run
+runSilent  act = runNoLoggingT     $ run_worker act
+runVerbose act = runStderrLoggingT $ run_worker act
+run =
+  if verbose
+  then runVerbose
+  else runSilent
+
 
 verbose :: Bool
 verbose = False
 
-migrateIt :: R.MonadUnliftIO m => SqlPersistT m ()
+
+run_worker :: RunDbMonad m => SqlPersistT (R.ResourceT m) a -> m a
+run_worker act = withConn $ runSqlConn (migrateIt >> act)
+
+
+migrateIt :: RunDbMonad m => SqlPersistT (R.ResourceT m) ()
 migrateIt = do
-  mapReaderT R.runResourceT $ void $ runMigrationSilent migrateAll
+  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
+withConn :: RunDbMonad m => (SqlBackend -> R.ResourceT m a) -> m a
+withConn =
+  R.runResourceT .
+  withMySQLConn defaultConnectInfo
+    { connectHost     = "127.0.0.1"
+    , connectUser     = "travis"
+    , connectPassword = "esqutest"
+    , connectDatabase = "esqutest"
+    , connectPort     = 33306
+    }

test/PostgreSQL/MigrateJSON.hs

@@ -16,21 +16,23 @@
 
 module PostgreSQL.MigrateJSON where
 
-import Common.Test.Import hiding (Value, from, on)
-
+import Control.Monad.Trans.Resource (ResourceT)
 import Data.Aeson (Value)
-import Database.Esqueleto.Legacy (from)
+import Database.Esqueleto (SqlExpr, delete, from)
 import Database.Esqueleto.PostgreSQL.JSON (JSONB)
+import Database.Persist (Entity)
+import Database.Persist.Sql (SqlPersistT)
 import Database.Persist.TH
 
+import Common.Test (RunDbMonad)
+
 -- JSON Table for PostgreSQL
 share [mkPersist sqlSettings, mkMigrate "migrateJSON"] [persistUpperCase|
 Json
   value (JSONB Value)
-  deriving Show
 |]
 
 cleanJSON
-    :: forall m. MonadIO m
-    => SqlPersistT m ()
+  :: (forall m. RunDbMonad m
+  => SqlPersistT (ResourceT m) ())
 cleanJSON = delete $ from $ \(_ :: SqlExpr (Entity Json)) -> return ()

test/SQLite/Test.hs

@@ -1,140 +1,181 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ScopedTypeVariables
+           , FlexibleContexts
+           , RankNTypes
+           , TypeFamilies
+           , OverloadedStrings
+#-}
 
-module SQLite.Test where
-
-import Common.Test.Import hiding (from, on)
+module Main (main) where
 
 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 Control.Monad.IO.Class (MonadIO(liftIO))
+import Control.Monad.Logger (runStderrLoggingT, runNoLoggingT)
+import Control.Monad.Trans.Reader (ReaderT)
+import Database.Persist.Sqlite (withSqliteConn)
 import Database.Sqlite (SqliteException)
+import Database.Esqueleto hiding (random_)
+import Database.Esqueleto.SQLite (random_)
+import qualified Control.Monad.Trans.Resource as R
+import Test.Hspec
 
 import Common.Test
 
-testSqliteRandom :: SpecDb
+
+
+
+testSqliteRandom :: Spec
 testSqliteRandom = do
-    itDb "works with random_" $ do
-        _ <- select $ return (random_ :: SqlExpr (Value Int))
-        asserting noExceptions
+  it "works with random_" $
+    run $ do
+      _ <- select $ return (random_ :: SqlExpr (Value Int))
+      return ()
 
-testSqliteSum :: SpecDb
+
+
+
+
+testSqliteSum :: Spec
 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) ]
+  it "works with sum_" $
+    run $ 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 :: Int) ]
 
 
 
 
 
-testSqliteTwoAscFields :: SpecDb
+testSqliteTwoAscFields :: Spec
 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 ]
+  it "works with two ASC fields (one call)" $
+    run $ 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
+      liftIO $ ret `shouldBe` [ p2e, p4e, p3e, p1e ]
 
-testSqliteOneAscOneDesc :: SpecDb
+
+
+
+
+testSqliteOneAscOneDesc :: Spec
 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 ]
+  it "works with one ASC and one DESC field (two calls)" $
+    run $ 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 ]
 
-testSqliteCoalesce :: SpecDb
+
+
+
+
+testSqliteCoalesce :: Spec
 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"
+  it "throws an exception on SQLite with <2 arguments" $
+    run (select $
+         from $ \p -> do
+         return (coalesce [p ^. PersonAge]) :: SqlQuery (SqlExpr (Value (Maybe Int))))
+    `shouldThrow` (\(_ :: SqliteException) -> True)
 
-testSqliteUpdate :: SpecDb
+
+
+
+
+testSqliteUpdate :: Spec
 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
-                ]
+  it "works on a simple example" $
+    run $ 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
+      -- SQLite: nulls appear first, update returns matched rows.
+      liftIO $ n `shouldBe` 2
+      liftIO $ ret `shouldBe` [ Entity p2k (Person anon Nothing (Just 37) 2)
+                              , Entity p1k (Person anon (Just 73) Nothing 1)
+                              , Entity p3k p3 ]
 
-testSqliteTextFunctions :: SpecDb
+
+
+
+
+nameContains :: (BaseBackend backend ~ SqlBackend,
+                 BackendCompatible SqlBackend backend,
+                 MonadIO m, SqlString s,
+                 IsPersistBackend backend, PersistQueryRead backend,
+                 PersistUniqueRead backend)
+             => (SqlExpr (Value [Char])
+             -> SqlExpr (Value s)
+             -> SqlExpr (Value Bool))
+             -> s
+             -> [Entity Person]
+             -> ReaderT backend m ()
+nameContains f t expected = do
+  ret <- select $
+         from $ \p -> do
+         where_ (f
+                  (p ^. PersonName)
+                  ((%) ++. val t ++. (%)))
+         orderBy [asc (p ^. PersonName)]
+         return p
+  liftIO $ ret `shouldBe` expected
+
+testSqliteTextFunctions :: Spec
 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]
+  describe "text functions" $ do
+    it "like, (%) and (++.) work on a simple example" $
+       run $ 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]
 
-spec :: HasCallStack => Spec
-spec = beforeAll mkConnectionPool $ do
-    tests
+
+
+
+
+main :: IO ()
+main = do
+  hspec $ do
+    tests run
+
+    describe "Test SQLite locking" $ do
+      testLocking withConn
 
     describe "SQLite specific tests" $ do
-      testAscRandom random_
-      testRandomMath
+      testAscRandom random_ run
+      testRandomMath run
       testSqliteRandom
       testSqliteSum
       testSqliteTwoAscFields
@@ -143,23 +184,32 @@ spec = beforeAll mkConnectionPool $ do
       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
+
+
+
+run, runSilent, runVerbose :: Run
+runSilent  act = runNoLoggingT     $ run_worker act
+runVerbose act = runStderrLoggingT $ run_worker act
+run =
+  if verbose
+  then runVerbose
+  else runSilent
+
 
 verbose :: Bool
 verbose = False
 
-migrateIt :: MonadUnliftIO m => SqlPersistT m ()
+
+run_worker :: RunDbMonad m => SqlPersistT (R.ResourceT m) a -> m a
+run_worker act = withConn $ runSqlConn (migrateIt >> act)
+
+
+migrateIt :: RunDbMonad m => SqlPersistT (R.ResourceT m) ()
 migrateIt = do
   void $ runMigrationSilent migrateAll
-  cleanDB
+
+
+withConn :: RunDbMonad m => (SqlBackend -> R.ResourceT m a) -> m a
+withConn =
+  R.runResourceT . withSqliteConn ":memory:"

test/Spec.hs

@@ -1,22 +0,0 @@
-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
-