haskell/esqueleto
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Esqueleto.Legacy (#259)

Browse Source 
* Esqueleto.Legacy

* Add changelog entry

* Delete deprecated modules

* a bit more

* ghc 9 support, clean warns

* yes

* okkk
This commit is contained in:
Matt Parsons 2021-05-26 14:27:04 -06:00 committed by GitHub
parent ea4ff33b93
commit b295bc6a5f
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
18 changed files with 626 additions and 433 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.github/workflows/haskell.yml vendored
View File

@ -33,7 +33,7 @@ jobs:
strategy:
matrix:
cabal: ["3.4"]
ghc: ["8.6.5", "8.8.4", "8.10.4"]
ghc: ["8.6.5", "8.8.4", "8.10.4", "9.0.1"]
env:
CONFIG: "--enable-tests --enable-benchmarks "
steps:
@ -71,6 +71,6 @@ jobs:
${{ 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
- run: cabal v2-test --disable-optimization -j $CONFIG --test-options "--fail-on-focus"
- run: cabal v2-haddock -j $CONFIG
- run: cabal v2-sdist

23
changelog.md
View File

@ -1,14 +1,27 @@
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

4
esqueleto.cabal
View File

@ -29,9 +29,8 @@ source-repository head
library
exposed-modules:
Database.Esqueleto
Database.Esqueleto.Legacy
Database.Esqueleto.Experimental
Database.Esqueleto.Internal.Language
Database.Esqueleto.Internal.Sql
Database.Esqueleto.Internal.Internal
Database.Esqueleto.Internal.ExprParser
Database.Esqueleto.MySQL
@ -76,7 +75,6 @@ library
-Wpartial-fields
-Wmissing-home-modules
-Widentities
-Wredundant-constraints
-Wcpp-undef
-Wcpp-undef
-Wmonomorphism-restriction

17
src/Database/Esqueleto.hs
View File

@ -2,6 +2,7 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
-- | The @esqueleto@ EDSL (embedded domain specific language).
-- This module replaces @Database.Persist@, so instead of
-- importing that module you should just import this one:
@ -31,11 +32,15 @@
-- Other than identifier name clashes, @esqueleto@ does not
-- conflict with @persistent@ in any way.
--
-- Note that the faciliites for @JOIN@ have been significantly improved in the
-- Note that the facilities for @JOIN@ have been significantly improved in the
-- "Database.Esqueleto.Experimental" module. The definition of 'from' and 'on'
-- in this module will be replaced with those at the 4.0.0.0 version, so you are
-- encouraged to migrate to the new method.
module Database.Esqueleto
--
-- This module has an attached WARNING message indicating that the Experimental
-- syntax will become the default. If you want to continue using the old syntax,
-- please refer to "Database.Esqueleto.Legacy" as a drop-in replacement.
module Database.Esqueleto {-# WARNING "This module will switch over to the Experimental syntax in an upcoming major version release. Please migrate to the Database.Esqueleto.Legacy module to continue using the old syntax, or translate to the new and improved syntax in Database.Esqueleto.Experimental." #-}
( -- * Setup
-- $setup
@ -123,14 +128,8 @@ module Database.Esqueleto
, module Database.Esqueleto.Internal.PersistentImport
) where
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.Legacy
import Database.Esqueleto.Internal.PersistentImport
import Database.Esqueleto.Internal.Sql
import qualified Database.Persist
-- $setup

7
src/Database/Esqueleto/Experimental.hs
View File

@ -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.
--
-- Esqueleto users are encouraged to migrate to this module, as it will become
-- the default in a new major version @4.0.0.0@.
-- This syntax will become the default syntax exported from the library in
-- version @3.6.0.0@. To use the old syntax, see "Database.Esqueleto.Legacy".
module Database.Esqueleto.Experimental
( -- * Setup
-- $setup
@ -229,9 +229,6 @@ import Database.Esqueleto.Experimental.ToAlias
import Database.Esqueleto.Experimental.ToAliasReference
import Database.Esqueleto.Experimental.ToMaybe
import GHC.TypeLits
import Database.Persist (EntityNameDB(..))
-- $setup
--
-- If you're already using "Database.Esqueleto", then you can get

12
src/Database/Esqueleto/Experimental/From.hs
View File

@ -18,8 +18,6 @@
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
@ -56,7 +54,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)}
@ -66,13 +64,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
@ -84,7 +82,7 @@ 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)
@ -123,7 +121,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

68
src/Database/Esqueleto/Experimental/From/Join.hs
View File

@ -1,37 +1,31 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Database.Esqueleto.Experimental.From.Join
where
import Data.Bifunctor (first)
import Data.Kind (Constraint)
import Data.Proxy
import qualified Data.Text.Lazy.Builder as TLB
import Database.Esqueleto.Experimental.From
import Database.Esqueleto.Experimental.From.SqlSetOperation
import Database.Esqueleto.Experimental.ToAlias
import Database.Esqueleto.Experimental.ToAliasReference
import Database.Esqueleto.Experimental.ToMaybe
import Database.Esqueleto.Internal.Internal hiding
(From (..),
from,
fromJoin,
on)
import Database.Esqueleto.Internal.PersistentImport (Entity (..),
EntityField,
PersistEntity,
PersistField)
import GHC.TypeLits
import Data.Bifunctor (first)
import Data.Kind (Constraint)
import Data.Proxy
import qualified Data.Text.Lazy.Builder as TLB
import Database.Esqueleto.Experimental.From
import Database.Esqueleto.Experimental.ToAlias
import Database.Esqueleto.Experimental.ToAliasReference
import Database.Esqueleto.Experimental.ToMaybe
import Database.Esqueleto.Internal.Internal hiding
(From(..), from, fromJoin, on)
import GHC.TypeLits
-- | A left-precedence pair. Pronounced \"and\". Used to represent expressions
-- that have been joined together.
@ -110,7 +104,7 @@ 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')
@ -132,7 +126,7 @@ 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
@ -157,7 +151,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')
@ -176,7 +170,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
@ -205,7 +199,7 @@ 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'
@ -229,7 +223,7 @@ 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)
@ -261,7 +255,7 @@ 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'
@ -289,7 +283,7 @@ 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'

13
src/Database/Esqueleto/Experimental/From/SqlSetOperation.hs
View File

@ -21,15 +21,14 @@ 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
(Entity, PersistEntity, PersistValue)
import Database.Esqueleto.Internal.PersistentImport (PersistValue)
-- | Data type used to implement the SqlSetOperation language
-- this type is implemented in the same way as a @From@
--
-- Semantically a @SqlSetOperation@ is always a @From@ but not vice versa
--
-- /Since: 3.5.0.0/
-- @since 3.5.0.0
newtype SqlSetOperation a = SqlSetOperation
{ unSqlSetOperation :: NeedParens -> SqlQuery (a, IdentInfo -> (TLB.Builder, [PersistValue]))}
@ -42,7 +41,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
@ -67,7 +66,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
@ -83,7 +82,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
@ -95,7 +94,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

147
src/Database/Esqueleto/Internal/Internal.hs
View File

@ -28,7 +28,6 @@ module Database.Esqueleto.Internal.Internal where
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NEL
import Control.Applicative ((<|>))
import Data.Coerce (Coercible, coerce)
import Control.Arrow (first, (***))
import Control.Exception (Exception, throw, throwIO)
import Control.Monad (MonadPlus(..), guard, void)
@ -66,12 +65,12 @@ import Database.Persist (FieldNameDB(..), EntityNameDB(..))
import Database.Persist.Sql.Util
( entityColumnCount
, keyAndEntityColumnNames
, hasNaturalKey
, isIdField
, parseEntityValues
)
import Text.Blaze.Html (Html)
import Data.Coerce (coerce)
import Data.Kind (Type)
-- | (Internal) Start a 'from' query with an entity. 'from'
-- does two kinds of magic using 'fromStart', 'fromJoin' and
@ -95,7 +94,7 @@ fromStart
fromStart = do
let ed = entityDef (Proxy :: Proxy a)
ident <- newIdentFor (coerce $ getEntityDBName ed)
let ret = unsafeSqlEntity ident
let ret = unsafeSqlEntity ident
f' = FromStart ident ed
return (PreprocessedFrom ret f')
@ -264,7 +263,7 @@ asc = orderByExpr " ASC"
-- | Descending order of this field or SqlExpression.
desc :: PersistField a => SqlExpr (Value a) -> SqlExpr OrderBy
desc = orderByExpr " DESC"
desc = orderByExpr " DESC"
orderByExpr :: TLB.Builder -> SqlExpr (Value a) -> SqlExpr OrderBy
orderByExpr orderByType (ERaw m f)
@ -381,7 +380,7 @@ distinctOnOrderBy exprs act =
--
-- @since 1.3.10
rand :: SqlExpr OrderBy
rand = ERaw noMeta $ \_ _ -> ("RANDOM()", [])
rand = ERaw noMeta $ \_ _ -> ("RANDOM()", [])
-- | @HAVING@.
--
@ -550,7 +549,7 @@ subSelectUnsafe = sub SELECT
ERaw m f ^. field
| isIdField field = idFieldValue
| Just alias <- sqlExprMetaAlias m =
ERaw noMeta $ \_ info ->
ERaw noMeta $ \_ info ->
f Never info <> ("." <> useIdent info (aliasedEntityColumnIdent alias fieldDef), [])
| otherwise = ERaw noMeta $ \_ info -> (dot info $ persistFieldDef field, [])
where
@ -567,20 +566,20 @@ ERaw m f ^. field
idFields ->
let renderedFields info = dot info <$> NEL.toList idFields
in ERaw noMeta{ sqlExprMetaCompositeFields = Just renderedFields} $
in ERaw noMeta{ sqlExprMetaCompositeFields = Just renderedFields} $
\p info -> (parensM p $ uncommas $ renderedFields info, [])
ed = entityDef $ getEntityVal (Proxy :: Proxy (SqlExpr (Entity val)))
dot info fieldDef =
dot info fieldDef' =
sourceIdent info <> "." <> fieldIdent
where
sourceIdent = fmap fst $ f Never
fieldIdent
| Just baseI <- sqlExprMetaAlias m =
useIdent info $ aliasedEntityColumnIdent baseI fieldDef
| otherwise =
fromDBName info (coerce $ fieldDB fieldDef)
fieldIdent
| Just baseI <- sqlExprMetaAlias m =
useIdent info $ aliasedEntityColumnIdent baseI fieldDef'
| otherwise =
fromDBName info (coerce $ fieldDB fieldDef')
-- | Project an SqlExpression that may be null, guarding against null cases.
withNonNull
@ -629,13 +628,14 @@ isNothing v =
case v of
ERaw m f ->
case sqlExprMetaCompositeFields m of
Just fields ->
Just fields ->
ERaw noMeta $ \p info ->
first (parensM p) . flip (,) [] . (intersperseB " AND " . map (<> " IS NULL")) $ fields info
Nothing ->
ERaw noMeta $ \p info ->
first (parensM p) . isNullExpr $ f Never info
where
isNullExpr :: (TLB.Builder, a) -> (TLB.Builder, a)
isNullExpr = first ((<> " IS NULL"))
-- | Analogous to 'Just', promotes a value of type @typ@ into
@ -657,10 +657,10 @@ joinV = veryUnsafeCoerceSqlExprValue
countHelper :: Num a => TLB.Builder -> TLB.Builder -> SqlExpr (Value typ) -> SqlExpr (Value a)
countHelper open close v =
case v of
ERaw meta f ->
ERaw meta f ->
if hasCompositeKeyMeta meta then
countRows
else
else
countRawSql (f Never)
where
countRawSql :: (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value a)
@ -688,7 +688,7 @@ not_ v = ERaw noMeta $ \p info -> first ("NOT " <>) $ x p info
ERaw m f ->
if hasCompositeKeyMeta m then
throw (CompositeKeyErr NotError)
else
else
let (b, vals) = f Never info
in (parensM p b, vals)
@ -923,22 +923,22 @@ justList (ERaw m f) = ERaw m f
--
-- Where @personIds@ is of type @[Key Person]@.
in_ :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (ValueList typ) -> SqlExpr (Value Bool)
(ERaw _ v) `in_` (ERaw _ list) =
ERaw noMeta $ \p info ->
let (b1, vals1) = v Parens info
(b2, vals2) = list Parens info
in
(ERaw _ v) `in_` (ERaw _ list) =
ERaw noMeta $ \_ info ->
let (b1, vals1) = v Parens info
(b2, vals2) = list Parens info
in
if b2 == "()" then
("FALSE", [])
else
else
(b1 <> " IN " <> b2, vals1 <> vals2)
-- | @NOT IN@ operator.
notIn :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (ValueList typ) -> SqlExpr (Value Bool)
(ERaw _ v) `notIn` (ERaw _ list) =
ERaw noMeta $ \p info ->
let (b1, vals1) = v Parens info
(b2, vals2) = list Parens info
(ERaw _ v) `notIn` (ERaw _ list) =
ERaw noMeta $ \_ info ->
let (b1, vals1) = v Parens info
(b2, vals2) = list Parens info
in (b1 <> " NOT IN " <> b2, vals1 <> vals2)
-- | @EXISTS@ operator. For example:
@ -952,15 +952,15 @@ notIn :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (ValueList typ) -> S
-- return person
-- @
exists :: SqlQuery () -> SqlExpr (Value Bool)
exists q = ERaw noMeta $ \p info ->
exists q = ERaw noMeta $ \p info ->
let ERaw _ f = existsHelper q
(b, vals) = f Never info
in ( parensM p $ "EXISTS " <> b, vals)
-- | @NOT EXISTS@ operator.
notExists :: SqlQuery () -> SqlExpr (Value Bool)
notExists q = ERaw noMeta $ \p info ->
let ERaw _ f = existsHelper q
notExists q = ERaw noMeta $ \p info ->
let ERaw _ f = existsHelper q
(b, vals) = f Never info
in ( parensM p $ "NOT EXISTS " <> b, vals)
@ -989,14 +989,14 @@ field /=. expr = setAux field (\ent -> ent ^. field /. expr)
-- | Apply a 'PersistField' constructor to @SqlExpr Value@ arguments.
(<#) :: (a -> b) -> SqlExpr (Value a) -> SqlExpr (Insertion b)
(<#) _ (ERaw _ f) = ERaw noMeta f
(<#) _ (ERaw _ f) = ERaw noMeta f
-- | Apply extra @SqlExpr Value@ arguments to a 'PersistField' constructor
(<&>) :: SqlExpr (Insertion (a -> b)) -> SqlExpr (Value a) -> SqlExpr (Insertion b)
(ERaw _ f) <&> (ERaw _ g) =
ERaw noMeta $ \_ info ->
let (fb, fv) = f Never info
(gb, gv) = g Never info
let (fb, fv) = f Never info
(gb, gv) = g Never info
in (fb <> ", " <> gb, fv ++ gv)
-- | @CASE@ statement. For example:
@ -1448,7 +1448,7 @@ instance SqlString a => SqlString (Maybe a) where
-- key on a query into another (cf. 'toBaseId').
class ToBaseId ent where
-- | e.g. @type BaseEnt MyBase = MyChild@
type BaseEnt ent :: *
type BaseEnt ent :: Type
-- | Convert from the key of the BaseEnt(ity) to the key of the child entity.
-- This function is not actually called, but that it typechecks proves this operation is safe.
toBaseIdWitness :: Key (BaseEnt ent) -> Key ent
@ -2042,43 +2042,43 @@ data SqlExprMeta = SqlExprMeta
sqlExprMetaCompositeFields :: Maybe (IdentInfo -> [TLB.Builder])
, sqlExprMetaAlias :: Maybe Ident -- Alias ident if this is an aliased value/entity
, sqlExprMetaIsReference :: Bool -- Is this SqlExpr a reference to the selected value/entity (supports subqueries)
}
}
-- | Empty 'SqlExprMeta' if you are constructing an 'ERaw' probably use this
-- for your meta
noMeta :: SqlExprMeta
noMeta = SqlExprMeta
noMeta = SqlExprMeta
{ sqlExprMetaCompositeFields = Nothing
, sqlExprMetaAlias = Nothing
, sqlExprMetaIsReference = False
}
-- | Does this meta contain values for composite fields.
-- | Does this meta contain values for composite fields.
-- This field is field out for composite key values
hasCompositeKeyMeta :: SqlExprMeta -> Bool
hasCompositeKeyMeta = Maybe.isJust . sqlExprMetaCompositeFields
hasCompositeKeyMeta = Maybe.isJust . sqlExprMetaCompositeFields
entityAsValue
:: SqlExpr (Entity val)
-> SqlExpr (Value (Entity val))
entityAsValue = coerce
entityAsValue = coerce
entityAsValueMaybe
:: SqlExpr (Maybe (Entity val))
-> SqlExpr (Value (Maybe (Entity val)))
entityAsValueMaybe = coerce
entityAsValueMaybe = coerce
-- | An expression on the SQL backend.
--
-- Raw expression: Contains a 'SqlExprMeta' and a function for
-- building the expr. It recieves a parameter telling it whether
-- Raw expression: Contains a 'SqlExprMeta' and a function for
-- building the expr. It recieves a parameter telling it whether
-- it is in a parenthesized context, and takes information about the SQL
-- connection (mainly for escaping names) and returns both an
-- string ('TLB.Builder') and a list of values to be
-- interpolated by the SQL backend.
data SqlExpr a = ERaw SqlExprMeta (NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue]))
-- | Data type to support from hack
-- | Data type to support from hack
data PreprocessedFrom a = PreprocessedFrom a FromClause
-- | Phantom type used to mark a @INSERT INTO@ query.
@ -2131,7 +2131,7 @@ unsafeSqlCase :: PersistField a => [(SqlExpr (Value Bool), SqlExpr (Value a))] -
unsafeSqlCase when v = ERaw noMeta buildCase
where
buildCase :: NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue])
buildCase p info =
buildCase _ info =
let (elseText, elseVals) = valueToSql v Parens info
(whenText, whenVals) = mapWhen when Parens info
in ( "CASE" <> whenText <> " ELSE " <> elseText <> " END", whenVals <> elseVals)
@ -2163,7 +2163,7 @@ unsafeSqlCase when v = ERaw noMeta buildCase
-- In the example above, we constraint the arguments to be of the
-- same type and constraint the result to be a boolean value.
unsafeSqlBinOp :: TLB.Builder -> SqlExpr (Value a) -> SqlExpr (Value b) -> SqlExpr (Value c)
unsafeSqlBinOp op (ERaw m1 f1) (ERaw m2 f2)
unsafeSqlBinOp op (ERaw m1 f1) (ERaw m2 f2)
| not (hasCompositeKeyMeta m1 || hasCompositeKeyMeta m2) = ERaw noMeta f
where
f p info =
@ -2223,7 +2223,7 @@ unsafeSqlBinOpComposite op sep a b
listify :: SqlExpr (Value x) -> IdentInfo -> ([TLB.Builder], [PersistValue])
listify (ERaw m f)
| Just f <- sqlExprMetaCompositeFields m = flip (,) [] . f
| Just k <- sqlExprMetaCompositeFields m = flip (,) [] . k
| otherwise = deconstruct . f Parens
deconstruct :: (TLB.Builder, [PersistValue]) -> ([TLB.Builder], [PersistValue])
@ -2261,7 +2261,7 @@ unsafeSqlFunction
:: UnsafeSqlFunctionArgument a
=> TLB.Builder -> a -> SqlExpr (Value b)
unsafeSqlFunction name arg =
ERaw noMeta $ \p info ->
ERaw noMeta $ \_ info ->
let (argsTLB, argsVals) =
uncommas' $ map (valueToFunctionArg info) $ toArgList arg
in
@ -2287,7 +2287,7 @@ unsafeSqlFunctionParens
:: UnsafeSqlFunctionArgument a
=> TLB.Builder -> a -> SqlExpr (Value b)
unsafeSqlFunctionParens name arg =
ERaw noMeta $ \p info ->
ERaw noMeta $ \_ info ->
let valueToFunctionArgParens (ERaw _ f) = f Never info
(argsTLB, argsVals) =
uncommas' $ map valueToFunctionArgParens $ toArgList arg
@ -2433,7 +2433,7 @@ veryUnsafeCoerceSqlExprValue = coerce
-- | (Internal) Coerce a value's type from 'SqlExpr (ValueList
-- a)' to 'SqlExpr (Value a)'. Does not work with empty lists.
veryUnsafeCoerceSqlExprValueList :: SqlExpr (ValueList a) -> SqlExpr (Value a)
veryUnsafeCoerceSqlExprValueList = coerce
veryUnsafeCoerceSqlExprValueList = coerce
----------------------------------------------------------------------
@ -2585,14 +2585,14 @@ delete
:: (MonadIO m)
=> SqlQuery ()
-> SqlWriteT m ()
delete = void . deleteCount
delete a = void $ deleteCount a
-- | Same as 'delete', but returns the number of rows affected.
deleteCount
:: (MonadIO m)
=> SqlQuery ()
-> SqlWriteT m Int64
deleteCount = rawEsqueleto DELETE
deleteCount a = rawEsqueleto DELETE a
-- | Execute an @esqueleto@ @UPDATE@ query inside @persistent@'s
-- 'SqlPersistT' monad. Note that currently there are no type
@ -2613,7 +2613,7 @@ update
)
=> (SqlExpr (Entity val) -> SqlQuery ())
-> SqlWriteT m ()
update = void . updateCount
update a = void $ updateCount a
-- | Same as 'update', but returns the number of rows affected.
updateCount
@ -2623,11 +2623,12 @@ updateCount
)
=> (SqlExpr (Entity val) -> SqlQuery ())
-> SqlWriteT m Int64
updateCount = rawEsqueleto UPDATE . from
updateCount a = rawEsqueleto UPDATE $ from a
builderToText :: TLB.Builder -> T.Text
builderToText = TL.toStrict . TLB.toLazyTextWith defaultChunkSize
where
defaultChunkSize :: Int
defaultChunkSize = 1024 - 32
-- | (Internal) Pretty prints a 'SqlQuery' into a SQL query.
@ -2669,7 +2670,7 @@ toRawSql mode (conn, firstIdentState) query =
, makeGroupBy info groupByClause
, makeHaving info havingClause
, makeOrderBy info orderByClauses
, makeLimit info limitClause orderByClauses
, makeLimit info limitClause
, makeLocking lockingClause
]
@ -2890,18 +2891,16 @@ makeOrderByNoNewline info os = first ("ORDER BY " <>) . uncommas' $ concatMap mk
mk :: OrderByClause -> [(TLB.Builder, [PersistValue])]
mk (ERaw _ f) = [f Never info]
orderByType ASC = " ASC"
orderByType DESC = " DESC"
makeOrderBy :: IdentInfo -> [OrderByClause] -> (TLB.Builder, [PersistValue])
makeOrderBy _ [] = mempty
makeOrderBy info is =
let (tlb, vals) = makeOrderByNoNewline info is
in ("\n" <> tlb, vals)
makeLimit :: IdentInfo -> LimitClause -> [OrderByClause] -> (TLB.Builder, [PersistValue])
makeLimit (conn, _) (Limit ml mo) orderByClauses =
makeLimit :: IdentInfo -> LimitClause -> (TLB.Builder, [PersistValue])
makeLimit (conn, _) (Limit ml mo) =
let limitRaw = getConnLimitOffset (v ml, v mo) "\n" conn
v :: Maybe Int64 -> Int
v = maybe 0 fromIntegral
in (TLB.fromText limitRaw, mempty)
@ -2989,27 +2988,27 @@ unescapedColumnNames ent =
-- | You may return an 'Entity' from a 'select' query.
instance PersistEntity a => SqlSelect (SqlExpr (Entity a)) (Entity a) where
sqlSelectCols info expr@(ERaw m f)
| Just baseIdent <- sqlExprMetaAlias m, False <- sqlExprMetaIsReference m =
let process ed = uncommas $
sqlSelectCols info expr@(ERaw m f)
| Just baseIdent <- sqlExprMetaAlias m, False <- sqlExprMetaIsReference m =
let process = uncommas $
map ((name <>) . aliasName) $
unescapedColumnNames ed
aliasName columnName = (fromDBName info columnName) <> " AS " <> aliasedColumnName baseIdent info (unDBName columnName)
name = fst (f Never info) <> "."
ed = entityDef $ getEntityVal $ return expr
in (process ed, mempty)
| Just baseIdent <- sqlExprMetaAlias m, True <- sqlExprMetaIsReference m =
let process ed = uncommas $
in (process, mempty)
| Just baseIdent <- sqlExprMetaAlias m, True <- sqlExprMetaIsReference m =
let process = uncommas $
map ((name <>) . aliasedColumnName baseIdent info . unDBName) $
unescapedColumnNames ed
name = fst (f Never info) <> "."
ed = entityDef $ getEntityVal $ return expr
in (process ed, mempty)
in (process, mempty)
| otherwise =
let process ed =
uncommas
$ map ((name <>) . TLB.fromText)
$ NEL.toList
let process =
uncommas
$ map ((name <>) . TLB.fromText)
$ NEL.toList
$ keyAndEntityColumnNames ed (fst info)
-- 'name' is the biggest difference between 'RawSql' and
-- 'SqlSelect'. We automatically create names for tables
@ -3019,7 +3018,7 @@ instance PersistEntity a => SqlSelect (SqlExpr (Entity a)) (Entity a) where
-- example).
name = fst (f Never info) <> "."
ed = entityDef $ getEntityVal $ return expr
in (process ed, mempty)
in (process, mempty)
sqlSelectColCount = entityColumnCount . entityDef . getEntityVal
sqlSelectProcessRow = parseEntityValues ed
@ -3031,7 +3030,7 @@ getEntityVal = const Proxy
-- | You may return a possibly-@NULL@ 'Entity' from a 'select' query.
instance PersistEntity a => SqlSelect (SqlExpr (Maybe (Entity a))) (Maybe (Entity a)) where
sqlSelectCols info e = sqlSelectCols info (coerce e :: SqlExpr (Entity a))
sqlSelectCols info e = sqlSelectCols info (coerce e :: SqlExpr (Entity a))
sqlSelectColCount = sqlSelectColCount . fromEMaybe
where
fromEMaybe :: Proxy (SqlExpr (Maybe e)) -> Proxy (SqlExpr e)
@ -3564,14 +3563,14 @@ insertSelect
:: (MonadIO m, PersistEntity a)
=> SqlQuery (SqlExpr (Insertion a))
-> SqlWriteT m ()
insertSelect = void . insertSelectCount
insertSelect a = void $ insertSelectCount a
-- | Insert a 'PersistField' for every selected value, return the count afterward
insertSelectCount
:: (MonadIO m, PersistEntity a)
=> SqlQuery (SqlExpr (Insertion a))
-> SqlWriteT m Int64
insertSelectCount = rawEsqueleto INSERT_INTO
insertSelectCount a = rawEsqueleto INSERT_INTO a
-- | Renders an expression into 'Text'. Only useful for creating a textual
-- representation of the clauses passed to an "On" clause.

140
src/Database/Esqueleto/Internal/Language.hs
View File

@ -1,140 +0,0 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# 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(..)
, 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

1
src/Database/Esqueleto/Internal/PersistentImport.hs
View File

@ -138,7 +138,6 @@ module Database.Esqueleto.Internal.PersistentImport
, getEntityId
, getEntityDBName
, getEntityUniques
, getEntityDBName
) where
import Database.Persist.Sql hiding

78
src/Database/Esqueleto/Internal/Sql.hs
View File

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

415
src/Database/Esqueleto/Legacy.hs Normal file
View File

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

8
src/Database/Esqueleto/PostgreSQL.hs
View File

@ -33,14 +33,12 @@ 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 Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Proxy (Proxy(..))
import qualified Data.Text.Internal.Builder as TLB
import Data.Time.Clock (UTCTime)
@ -283,8 +281,8 @@ insertSelectWithConflict
-- violated. The expression takes the current and excluded value to produce
-- the updates.
-> SqlWriteT m ()
insertSelectWithConflict unique query =
void . insertSelectWithConflictCount unique query
insertSelectWithConflict unique query a =
void $ insertSelectWithConflictCount unique query a
-- | Same as 'insertSelectWithConflict' but returns the number of rows affected.
--

3
src/Database/Esqueleto/PostgreSQL/JSON.hs
View File

@ -136,9 +136,8 @@ module Database.Esqueleto.PostgreSQL.JSON
) where
import Data.Text (Text)
import Database.Esqueleto.Internal.Language hiding ((-.), (?.), (||.))
import Database.Esqueleto.Internal.Internal hiding ((-.), (?.), (||.))
import Database.Esqueleto.Internal.PersistentImport
import Database.Esqueleto.Internal.Sql
import Database.Esqueleto.PostgreSQL.JSON.Instances
infixl 6 ->., ->>., #>., #>>.

3
src/Database/Esqueleto/PostgreSQL/JSON/Instances.hs
View File

@ -15,9 +15,8 @@ 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.Sql (SqlExpr)
import Database.Esqueleto.Internal.Internal (SqlExpr, Value, just, val)
import GHC.Generics (Generic)
-- | Newtype wrapper around any type with a JSON representation.

8
test/Common/Test.hs
View File

@ -93,7 +93,7 @@ import qualified Data.Text as Text
import qualified Data.Text.Internal.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import qualified Database.Esqueleto.Internal.ExprParser as P
import qualified Database.Esqueleto.Internal.Sql as EI
import qualified Database.Esqueleto.Internal.Internal as EI
import qualified UnliftIO.Resource as R
-- Test schema
@ -769,7 +769,7 @@ testSelectJoin run = do
insert_ $ Frontcover number ""
articleId <- insert $ Article "title" number
articleMetaE <- insert' (ArticleMetadata articleId)
result <- select . from $ \articleMetadata -> do
result <- select $ from $ \articleMetadata -> do
where_ $ (articleMetadata ^. ArticleMetadataId) ==. (val ((ArticleMetadataKey articleId)))
pure articleMetadata
liftIO $ [articleMetaE] `shouldBe` result
@ -863,7 +863,7 @@ testSelectJoin run = do
it "respects the associativity of joins" $
run $ do
void $ insert p1
ps <- select . from $
ps <- select $ from $
\((p :: SqlExpr (Entity Person))
`LeftOuterJoin`
((_q :: SqlExpr (Entity Person))
@ -1321,7 +1321,7 @@ testSelectDistinct run = do
liftIO $ ret `shouldBe` [ Value t1, Value t2, Value t3 ]
it "works on a simple example (select . distinct)" $
selDistTest (select . distinct)
selDistTest (\a -> select $ distinct a)
it "works on a simple example (distinct (return ()))" $
selDistTest (\act -> select $ distinct (return ()) >> act)

108
test/PostgreSQL/Test.hs
View File

@ -35,7 +35,7 @@ import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime)
import Database.Esqueleto hiding (random_)
import Database.Esqueleto.Experimental hiding (from, on, random_)
import qualified Database.Esqueleto.Experimental as Experimental
import qualified Database.Esqueleto.Internal.Sql as ES
import qualified Database.Esqueleto.Internal.Internal as ES
import Database.Esqueleto.PostgreSQL (random_)
import qualified Database.Esqueleto.PostgreSQL as EP
import Database.Esqueleto.PostgreSQL.JSON hiding ((-.), (?.), (||.))
@ -272,7 +272,7 @@ testArrayAggWith = do
let people = [p1, p2, p3, p4, p5]
mapM_ insert people
[Value (Just ret)] <-
select . from $ \p ->
select $ from $ \p ->
return (EP.arrayAggWith EP.AggModeAll (p ^. PersonName) [])
liftIO $ L.sort ret `shouldBe` L.sort (map personName people)
@ -289,7 +289,7 @@ testArrayAggWith = do
let people = [p1, p2, p3, p4, p5]
mapM_ insert people
[Value (Just ret)] <-
select . from $ \p ->
select $ from $ \p ->
return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge) [])
liftIO $ L.sort ret `shouldBe` [Nothing, Just 17, Just 36]
@ -310,7 +310,7 @@ testArrayAggWith = do
let people = [p1, p2, p3, p4, p5]
mapM_ insert people
[Value (Just ret)] <-
select . from $ \p ->
select $ from $ \p ->
return (EP.arrayAggWith EP.AggModeAll (p ^. PersonName) [])
liftIO $ L.sort ret `shouldBe` L.sort (map personName people)
@ -329,7 +329,7 @@ testArrayAggWith = do
let people = [p1, p2, p3, p4, p5]
mapM_ insert people
[Value (Just ret)] <-
select . from $ \p ->
select $ from $ \p ->
return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge)
[asc $ p ^. PersonAge])
liftIO $ ret `shouldBe` [Just 17, Just 36, Nothing]
@ -354,13 +354,13 @@ testStringAggWith = do
let people = [p1, p2, p3, p4, p5]
mapM_ insert people
[Value (Just ret)] <-
select . from $ \p ->
select $ from $ \p ->
return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ")[])
liftIO $ (L.sort $ words ret) `shouldBe` L.sort (map personName people)
it "works with zero rows" $ run $ do
[Value ret] <-
select . from $ \p ->
select $ from $ \p ->
return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ")[])
liftIO $ ret `shouldBe` Nothing
@ -378,7 +378,7 @@ testStringAggWith = do
let people = [p1, p2, p3 {personName = "John"}, p4, p5]
mapM_ insert people
[Value (Just ret)] <-
select . from $ \p ->
select $ from $ \p ->
return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName) (val " ")
[]
liftIO $ (L.sort $ words ret) `shouldBe`
@ -401,7 +401,7 @@ testStringAggWith = do
let people = [p1, p2, p3, p4, p5]
mapM_ insert people
[Value (Just ret)] <-
select . from $ \p ->
select $ from $ \p ->
return $ EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ")
[desc $ p ^. PersonName]
liftIO $ (words ret)
@ -422,7 +422,7 @@ testStringAggWith = do
let people = [p1, p2, p3 {personName = "John"}, p4, p5]
mapM_ insert people
[Value (Just ret)] <-
select . from $ \p ->
select $ from $ \p ->
return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName) (val " ")
[desc $ p ^. PersonName]
liftIO $ (words ret) `shouldBe`
@ -439,12 +439,12 @@ testAggregateFunctions = do
let people = [p1, p2, p3, p4, p5]
mapM_ insert people
[Value (Just ret)] <-
select . from $ \p -> return (EP.arrayAgg (p ^. PersonName))
select $ from $ \p -> return (EP.arrayAgg (p ^. PersonName))
liftIO $ L.sort ret `shouldBe` L.sort (map personName people)
it "works on zero rows" $ run $ do
[Value ret] <-
select . from $ \p -> return (EP.arrayAgg (p ^. PersonName))
select $ from $ \p -> return (EP.arrayAgg (p ^. PersonName))
liftIO $ ret `shouldBe` Nothing
describe "arrayAggWith" testArrayAggWith
describe "stringAgg" $ do
@ -459,7 +459,7 @@ testAggregateFunctions = do
liftIO $ L.sort (words ret) `shouldBe` L.sort (map personName people)
it "works on zero rows" $ run $ do
[Value ret] <-
select . from $ \p -> return (EP.stringAgg (p ^. PersonName) (val " "))
select $ from $ \p -> return (EP.stringAgg (p ^. PersonName) (val " "))
liftIO $ ret `shouldBe` Nothing
describe "stringAggWith" testStringAggWith
@ -471,7 +471,7 @@ testAggregateFunctions = do
, Person "4" (Just 8) Nothing 2
, Person "5" (Just 9) Nothing 2
]
ret <- select . from $ \(person :: SqlExpr (Entity Person)) -> do
ret <- select $ from $ \(person :: SqlExpr (Entity Person)) -> do
groupBy (person ^. PersonFavNum)
return . EP.arrayRemoveNull . EP.maybeArray . EP.arrayAgg
$ person ^. PersonAge
@ -481,7 +481,7 @@ testAggregateFunctions = do
describe "maybeArray" $ do
it "Coalesces NULL into an empty array" $ run $ do
[Value ret] <-
select . from $ \p ->
select $ from $ \p ->
return (EP.maybeArray $ EP.arrayAgg (p ^. PersonName))
liftIO $ ret `shouldBe` []
@ -1134,19 +1134,22 @@ testFilterWhere =
-- Person "Mitch" Nothing Nothing 5
_ <- insert p5
usersByAge <- (fmap . fmap) (\(Value a, Value b, Value c) -> (a, b, c)) <$> select $ from $ \users -> do
groupBy $ users ^. PersonAge
return
( users ^. PersonAge
-- Nothing: [Rachel { favNum = 2 }, Mitch { favNum = 5 }] = 2
-- Just 36: [John { favNum = 1 } (excluded)] = 0
-- Just 17: [Mike { favNum = 3 }, Livia { favNum = 4 }] = 2
, count (users ^. PersonId) `EP.filterWhere` (users ^. PersonFavNum >=. val 2)
-- Nothing: [Rachel { favNum = 2 } (excluded), Mitch { favNum = 5 } (excluded)] = 0
-- Just 36: [John { favNum = 1 }] = 1
-- Just 17: [Mike { favNum = 3 } (excluded), Livia { favNum = 4 } (excluded)] = 0
, count (users ^. PersonFavNum) `EP.filterWhere` (users ^. PersonFavNum <. val 2)
)
usersByAge <- fmap coerce <$> do
select $ from $ \users -> do
groupBy $ users ^. PersonAge
return
( users ^. PersonAge :: SqlExpr (Value (Maybe Int))
-- Nothing: [Rachel { favNum = 2 }, Mitch { favNum = 5 }] = 2
-- Just 36: [John { favNum = 1 } (excluded)] = 0
-- Just 17: [Mike { favNum = 3 }, Livia { favNum = 4 }] = 2
, count (users ^. PersonId) `EP.filterWhere` (users ^. PersonFavNum >=. val 2)
:: SqlExpr (Value Int)
-- Nothing: [Rachel { favNum = 2 } (excluded), Mitch { favNum = 5 } (excluded)] = 0
-- Just 36: [John { favNum = 1 }] = 1
-- Just 17: [Mike { favNum = 3 } (excluded), Livia { favNum = 4 } (excluded)] = 0
, count (users ^. PersonFavNum) `EP.filterWhere` (users ^. PersonFavNum <. val 2)
:: SqlExpr (Value Int)
)
liftIO $ usersByAge `shouldMatchList`
( [ (Nothing, 2, 0)
@ -1167,19 +1170,20 @@ testFilterWhere =
-- Person "Mitch" Nothing Nothing 5
_ <- insert p5
usersByAge <- (fmap . fmap) (\(Value a, Value b, Value c) -> (a, b, c)) <$> select $ from $ \users -> do
groupBy $ users ^. PersonAge
return
( users ^. PersonAge
-- Nothing: [Rachel { favNum = 2 }, Mitch { favNum = 5 }] = Just 7
-- Just 36: [John { favNum = 1 } (excluded)] = Nothing
-- Just 17: [Mike { favNum = 3 }, Livia { favNum = 4 }] = Just 7
, sum_ (users ^. PersonFavNum) `EP.filterWhere` (users ^. PersonFavNum >=. val 2)
-- Nothing: [Rachel { favNum = 2 } (excluded), Mitch { favNum = 5 } (excluded)] = Nothing
-- Just 36: [John { favNum = 1 }] = Just 1
-- Just 17: [Mike { favNum = 3 } (excluded), Livia { favNum = 4 } (excluded)] = Nothing
, sum_ (users ^. PersonFavNum) `EP.filterWhere` (users ^. PersonFavNum <. val 2)
)
usersByAge <- fmap (\(Value a, Value b, Value c) -> (a, b, c)) <$> do
select $ from $ \users -> do
groupBy $ users ^. PersonAge
return
( users ^. PersonAge
-- Nothing: [Rachel { favNum = 2 }, Mitch { favNum = 5 }] = Just 7
-- Just 36: [John { favNum = 1 } (excluded)] = Nothing
-- Just 17: [Mike { favNum = 3 }, Livia { favNum = 4 }] = Just 7
, sum_ (users ^. PersonFavNum) `EP.filterWhere` (users ^. PersonFavNum >=. val 2)
-- Nothing: [Rachel { favNum = 2 } (excluded), Mitch { favNum = 5 } (excluded)] = Nothing
-- Just 36: [John { favNum = 1 }] = Just 1
-- Just 17: [Mike { favNum = 3 } (excluded), Livia { favNum = 4 } (excluded)] = Nothing
, sum_ (users ^. PersonFavNum) `EP.filterWhere` (users ^. PersonFavNum <. val 2)
)
liftIO $ usersByAge `shouldMatchList`
( [ (Nothing, Just 7, Nothing)
@ -1197,7 +1201,7 @@ testCommonTableExpressions = do
void $ select $ do
limitedLordsCte <-
Experimental.with $ do
lords <- Experimental.from $ Experimental.Table @Lord
lords <- Experimental.from $ Experimental.table @Lord
limit 10
pure lords
lords <- Experimental.from limitedLordsCte
@ -1260,9 +1264,9 @@ testLateralQuery = do
_ <- run $ do
select $ do
l :& c <-
Experimental.from $ Table @Lord
Experimental.from $ table @Lord
`CrossJoin` \lord -> do
deed <- Experimental.from $ Table @Deed
deed <- Experimental.from $ table @Deed
where_ $ lord ^. LordId ==. deed ^. DeedOwnerId
pure $ countRows @Int
pure (l, c)
@ -1271,11 +1275,11 @@ testLateralQuery = do
it "supports INNER JOIN LATERAL" $ do
run $ do
let subquery lord = do
deed <- Experimental.from $ Table @Deed
deed <- Experimental.from $ table @Deed
where_ $ lord ^. LordId ==. deed ^. DeedOwnerId
pure $ countRows @Int
res <- select $ do
l :& c <- Experimental.from $ Table @Lord
l :& c <- Experimental.from $ table @Lord
`InnerJoin` subquery
`Experimental.on` (const $ val True)
pure (l, c)
@ -1287,9 +1291,9 @@ testLateralQuery = do
it "supports LEFT JOIN LATERAL" $ do
run $ do
res <- select $ do
l :& c <- Experimental.from $ Table @Lord
l :& c <- Experimental.from $ table @Lord
`LeftOuterJoin` (\lord -> do
deed <- Experimental.from $ Table @Deed
deed <- Experimental.from $ table @Deed
where_ $ lord ^. LordId ==. deed ^. DeedOwnerId
pure $ countRows @Int)
`Experimental.on` (const $ val True)
@ -1303,9 +1307,9 @@ testLateralQuery = do
it "compile error on RIGHT JOIN LATERAL" $ do
run $ do
res <- select $ do
l :& c <- Experimental.from $ Table @Lord
l :& c <- Experimental.from $ table @Lord
`RightOuterJoin` (\lord -> do
deed <- Experimental.from $ Table @Deed
deed <- Experimental.from $ table @Deed
where_ $ lord ?. LordId ==. just (deed ^. DeedOwnerId)
pure $ countRows @Int)
`Experimental.on` (const $ val True)
@ -1316,9 +1320,9 @@ testLateralQuery = do
it "compile error on FULL OUTER JOIN LATERAL" $ do
run $ do
res <- select $ do
l :& c <- Experimental.from $ Table @Lord
l :& c <- Experimental.from $ table @Lord
`FullOuterJoin` (\lord -> do
deed <- Experimental.from $ Table @Deed
deed <- Experimental.from $ table @Deed
where_ $ lord ?. LordId ==. just (deed ^. DeedOwnerId)
pure $ countRows @Int)
`Experimental.on` (const $ val True)