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

Autoformatting + Stylish Haskell Config (#218)

Browse Source 
* Add stylish-haskell.yaml, update spacing to 4 in configs

* update travis

* lol

* major formatting stuff

* fix parse error

* fix

* warnings, more tidying up

* Add style guide [ci skip]

* faster build perhaps

* cabbal

* sigh
This commit is contained in:
Matt Parsons 2020-10-29 16:20:52 -06:00 committed by GitHub
parent 4f6b02298c
commit b35713c09f
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
19 changed files with 3060 additions and 2809 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.editorconfig
View File

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

11
.github/PULL_REQUEST_TEMPLATE.md vendored
View File

@ -1,13 +1,14 @@
Before submitting your PR, check that you've:
- [ ] Bumped the version number
- [ ] Documented new APIs with [Haddock markup](https://www.haskell.org/haddock/doc/html/index.html)
- [ ] Added [`@since` declarations](http://haskell-haddock.readthedocs.io/en/latest/markup.html#since) to the Haddock
- [ ] Bumped the version number.
- [ ] Documented new APIs with [Haddock markup](https://www.haskell.org/haddock/doc/html/index.html).
- [ ] Added [`@since` declarations](http://haskell-haddock.readthedocs.io/en/latest/markup.html#since) to the Haddock.
- [ ] Ran `stylish-haskell` and otherwise adhered to the [style guide](https://github.com/bitemyapp/esqueleto/blob/master/style-guide.yaml).
After submitting your PR:
- [ ] Update the Changelog.md file with a link to your PR
- [ ] Check that CI passes (or if it fails, for reasons unrelated to your change, like CI timeouts)
- [ ] Update the Changelog.md file with a link to your PR.
- [ ] Check that CI passes (or if it fails, for reasons unrelated to your change, like CI timeouts).
<!---Thanks so much for contributing! :)

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

@ -35,7 +35,7 @@ jobs:
cabal: ["3.2"]
ghc: ["8.6.5", "8.8.3", "8.10.1"]
env:
CONFIG: "--enable-tests --enable-benchmarks"
CONFIG: "--enable-tests --enable-benchmarks "
steps:
- uses: actions/checkout@v2
- uses: actions/setup-haskell@v1.1.2
@ -69,7 +69,7 @@ jobs:
key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }}
restore-keys: |
${{ runner.os }}-${{ matrix.ghc }}-
- run: cabal v2-build $CONFIG
- run: cabal v2-test $CONFIG
- run: cabal v2-haddock $CONFIG
- run: cabal v2-build --disable-optimization -j $CONFIG
- run: cabal v2-test --disable-optimization -j $CONFIG
- run: cabal v2-haddock -j $CONFIG
- run: cabal v2-sdist

39
.stylish-haskell.yaml Normal file
View File

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

5
.travis.yml
View File

@ -1,7 +1,5 @@
language: c
sudo: false
services:
- mysql
@ -25,8 +23,9 @@ env:
- GHCVER=nightly
jobs:
fast_finish: true
allow_failures:
- GHCVER=nightly
- env: GHCVER=nightly
install:
- export STACK_YAML=stack-$GHCVER.yaml

16
esqueleto.cabal
View File

@ -61,10 +61,18 @@ library
, transformers >=0.2
, unliftio
, unordered-containers >=0.2
if impl(ghc >=8.0)
ghc-options: -Wall -Wno-redundant-constraints
else
ghc-options: -Wall
ghc-options:
-Wall
-Wno-redundant-constraints
-Wincomplete-uni-patterns
-Wincomplete-record-updates
-Wpartial-fields
-Wmissing-home-modules
-Widentities
-Wredundant-constraints
-Wcpp-undef
-Wcpp-undef
-Wmonomorphism-restriction
default-language: Haskell2010
test-suite mysql

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

@ -1,16 +1,15 @@
{-# LANGUAGE CPP
, DataKinds
, FlexibleContexts
, FlexibleInstances
, FunctionalDependencies
, GADTs
, MultiParamTypeClasses
, TypeOperators
, TypeFamilies
, UndecidableInstances
, OverloadedStrings
, PatternSynonyms
#-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-- | This module contains a new way (introduced in 3.3.3.0) of using @FROM@ in
-- Haskell. The old method was a bit finicky and could permit runtime errors,
@ -59,22 +58,103 @@ module Database.Esqueleto.Experimental
, ToAlias(..)
, ToAliasReference(..)
-- * The Normal Stuff
, where_, groupBy, orderBy, rand, asc, desc, limit, offset
, distinct, distinctOn, don, distinctOnOrderBy, having, locking
, sub_select, (^.), (?.)
, val, isNothing, just, nothing, joinV, withNonNull
, countRows, count, countDistinct
, not_, (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.)
, between, (+.), (-.), (/.), (*.)
, random_, round_, ceiling_, floor_
, min_, max_, sum_, avg_, castNum, castNumM
, coalesce, coalesceDefault
, lower_, upper_, trim_, ltrim_, rtrim_, length_, left_, right_
, like, ilike, (%), concat_, (++.), castString
, subList_select, valList, justList
, in_, notIn, exists, notExists
, set, (=.), (+=.), (-=.), (*=.), (/=.)
, case_, toBaseId
, where_
, groupBy
, orderBy
, rand
, asc
, desc
, limit
, offset
, distinct
, distinctOn
, don
, distinctOnOrderBy
, having
, locking
, sub_select
, (^.)
, (?.)
, val
, isNothing
, just
, nothing
, joinV
, withNonNull
, countRows
, count
, countDistinct
, not_
, (==.)
, (>=.)
, (>.)
, (<=.)
, (<.)
, (!=.)
, (&&.)
, (||.)
, between
, (+.)
, (-.)
, (/.)
, (*.)
, random_
, round_
, ceiling_
, floor_
, min_
, max_
, sum_
, avg_
, castNum
, castNumM
, coalesce
, coalesceDefault
, lower_
, upper_
, trim_
, ltrim_
, rtrim_
, length_
, left_
, right_
, like
, ilike
, (%)
, concat_
, (++.)
, castString
, subList_select
, valList
, justList
, in_
, notIn
, exists
, notExists
, set
, (=.)
, (+=.)
, (-=.)
, (*=.)
, (/=.)
, case_
, toBaseId
, subSelect
, subSelectMaybe
, subSelectCount
@ -132,22 +212,20 @@ module Database.Esqueleto.Experimental
-- $reexports
, deleteKey
, module Database.Esqueleto.Internal.PersistentImport
)
where
) where
import qualified Control.Monad.Trans.Writer as W
import qualified Control.Monad.Trans.State as S
import Control.Monad.Trans.Class (lift)
import qualified Control.Monad.Trans.State as S
import qualified Control.Monad.Trans.Writer as W
#if __GLASGOW_HASKELL__ < 804
import Data.Semigroup
#endif
import Data.Proxy (Proxy(..))
import qualified Data.Text.Lazy.Builder as TLB
import Database.Esqueleto.Internal.Internal hiding (From, from, on)
import Database.Esqueleto.Internal.PersistentImport
import Database.Esqueleto.Internal.Internal hiding (from, on, From)
import GHC.TypeLits
-- $setup
--
-- If you're already using "Database.Esqueleto", then you can get
@ -460,14 +538,13 @@ import GHC.TypeLits
data (:&) a b = a :& b
infixl 2 :&
data SqlSetOperation a =
SqlSetUnion (SqlSetOperation a) (SqlSetOperation a)
data SqlSetOperation a
= SqlSetUnion (SqlSetOperation a) (SqlSetOperation a)
| SqlSetUnionAll (SqlSetOperation a) (SqlSetOperation a)
| SqlSetExcept (SqlSetOperation a) (SqlSetOperation a)
| SqlSetIntersect (SqlSetOperation a) (SqlSetOperation a)
| SelectQueryP NeedParens (SqlQuery a)
-- $sql-set-operations
--
-- Data type that represents SQL set operations. This includes
@ -502,32 +579,28 @@ data SqlSetOperation a =
-- @
--
{-# DEPRECATED Union "/Since: 3.4.0.0/ - \
Use the 'union_' function instead of the 'Union' data constructor" #-}
{-# DEPRECATED Union "/Since: 3.4.0.0/ - Use the 'union_' function instead of the 'Union' data constructor" #-}
data Union a b = a `Union` b
-- | @UNION@ SQL set operation. Can be used as an infix function between 'SqlQuery' values.
union_ :: a -> b -> Union a b
union_ = Union
{-# DEPRECATED UnionAll "/Since: 3.4.0.0/ - \
Use the 'unionAll_' function instead of the 'UnionAll' data constructor" #-}
{-# DEPRECATED UnionAll "/Since: 3.4.0.0/ - Use the 'unionAll_' function instead of the 'UnionAll' data constructor" #-}
data UnionAll a b = a `UnionAll` b
-- | @UNION@ @ALL@ SQL set operation. Can be used as an infix function between 'SqlQuery' values.
unionAll_ :: a -> b -> UnionAll a b
unionAll_ = UnionAll
{-# DEPRECATED Except "/Since: 3.4.0.0/ - \
Use the 'except_' function instead of the 'Except' data constructor" #-}
{-# DEPRECATED Except "/Since: 3.4.0.0/ - Use the 'except_' function instead of the 'Except' data constructor" #-}
data Except a b = a `Except` b
-- | @EXCEPT@ SQL set operation. Can be used as an infix function between 'SqlQuery' values.
except_ :: a -> b -> Except a b
except_ = Except
{-# DEPRECATED Intersect "/Since: 3.4.0.0/ - \
Use the 'intersect_' function instead of the 'Intersect' data constructor" #-}
{-# DEPRECATED Intersect "/Since: 3.4.0.0/ - Use the 'intersect_' function instead of the 'Intersect' data constructor" #-}
data Intersect a b = a `Intersect` b
-- | @INTERSECT@ SQL set operation. Can be used as an infix function between 'SqlQuery' values.
@ -539,14 +612,19 @@ class SetOperationT a ~ b => ToSetOperation a b | a -> b where
instance ToSetOperation (SqlSetOperation a) a where
toSetOperation = id
instance ToSetOperation (SqlQuery a) a where
toSetOperation = SelectQueryP Never
instance (ToSetOperation a c, ToSetOperation b c) => ToSetOperation (Union a b) c where
toSetOperation (Union a b) = SqlSetUnion (toSetOperation a) (toSetOperation b)
instance (ToSetOperation a c, ToSetOperation b c) => ToSetOperation (UnionAll a b) c where
toSetOperation (UnionAll a b) = SqlSetUnionAll (toSetOperation a) (toSetOperation b)
instance (ToSetOperation a c, ToSetOperation b c) => ToSetOperation (Except a b) c where
toSetOperation (Except a b) = SqlSetExcept (toSetOperation a) (toSetOperation b)
instance (ToSetOperation a c, ToSetOperation b c) => ToSetOperation (Intersect a b) c where
toSetOperation (Intersect a b) = SqlSetIntersect (toSetOperation a) (toSetOperation b)
@ -558,12 +636,10 @@ type family SetOperationT a where
SetOperationT (SqlQuery a) = a
SetOperationT (SqlSetOperation a) = a
{-# DEPRECATED SelectQuery "/Since: 3.4.0.0/ - \
It is no longer necessary to tag 'SqlQuery' values with @SelectQuery@" #-}
{-# DEPRECATED SelectQuery "/Since: 3.4.0.0/ - It is no longer necessary to tag 'SqlQuery' values with @SelectQuery@" #-}
pattern SelectQuery :: SqlQuery a -> SqlSetOperation a
pattern SelectQuery q = SelectQueryP Never q
-- | Data type that represents the syntax of a 'JOIN' tree. In practice,
-- only the @Table@ constructor is used directly when writing queries. For example,
--
@ -688,6 +764,7 @@ type family ToFromT a where
ToFromT (RightOuterJoin a b) = TypeError (JoinErrorMsg "RightOuterJoin")
ToFromT (FullOuterJoin a b) = TypeError (JoinErrorMsg "FullOuterJoin")
data Lateral
data NotLateral
@ -713,6 +790,7 @@ instance {-# OVERLAPPABLE #-} ToFrom (LeftOuterJoin a b) where
instance {-# OVERLAPPABLE #-} ToFrom (RightOuterJoin a b) where
toFrom = undefined
instance {-# OVERLAPPABLE #-} ToFrom (FullOuterJoin a b) where
toFrom = undefined
instance ( ToAlias a
@ -760,23 +838,32 @@ instance (ToFrom a, ToFromT a ~ a', ToFrom b, ToFromT b ~ b')
=> ToInnerJoin NotLateral a b (a' :& b') where
toInnerJoin _ lhs rhs on' = InnerJoinFrom (toFrom lhs) (toFrom rhs, on')
instance ( ToFrom a
instance
( ToFrom a
, ToFromT a ~ a'
, ToInnerJoin (IsLateral b) a b b'
) => ToFrom (InnerJoin a (b, b' -> SqlExpr (Value Bool))) where
)
=>
ToFrom (InnerJoin a (b, b' -> SqlExpr (Value Bool)))
where
toFrom (InnerJoin lhs (rhs, on')) =
let
toProxy :: b -> Proxy (IsLateral b)
let toProxy :: b -> Proxy (IsLateral b)
toProxy _ = Proxy
in toInnerJoin (toProxy rhs) lhs rhs on'
in
toInnerJoin (toProxy rhs) lhs rhs on'
instance ( ToFrom a
instance
( ToFrom a
, ToFrom b
, ToFromT (CrossJoin a b) ~ (ToFromT a :& ToFromT b)
) => ToFrom (CrossJoin a b) where
)
=>
ToFrom (CrossJoin a b)
where
toFrom (CrossJoin lhs rhs) = CrossJoinFrom (toFrom lhs) (toFrom rhs)
instance {-# OVERLAPPING #-}
( ToFrom a
, ToFromT a ~ a'
, SqlSelect b r
@ -808,15 +895,20 @@ instance ( ToFrom a
) => ToLeftJoin NotLateral a b (a' :& mb) where
toLeftJoin _ lhs rhs on' = LeftJoinFrom (toFrom lhs) (toFrom rhs, on')
instance ( ToLeftJoin (IsLateral b) a b b'
) => ToFrom (LeftOuterJoin a (b, b' -> SqlExpr (Value Bool))) where
instance
( ToLeftJoin (IsLateral b) a b b'
)
=>
ToFrom (LeftOuterJoin a (b, b' -> SqlExpr (Value Bool)))
where
toFrom (LeftOuterJoin lhs (rhs, on')) =
let
toProxy :: b -> Proxy (IsLateral b)
let toProxy :: b -> Proxy (IsLateral b)
toProxy _ = Proxy
in toLeftJoin (toProxy rhs) lhs rhs on'
in
toLeftJoin (toProxy rhs) lhs rhs on'
instance ( ToFrom a
instance
( ToFrom a
, ToFromT a ~ a'
, ToFrom b
, ToFromT b ~ b'
@ -825,18 +917,27 @@ instance ( ToFrom a
, ToMaybe b'
, mb ~ ToMaybeT b'
, ErrorOnLateral b
) => ToFrom (FullOuterJoin a (b, (ma :& mb) -> SqlExpr (Value Bool))) where
toFrom (FullOuterJoin lhs (rhs, on')) = FullJoinFrom (toFrom lhs) (toFrom rhs, on')
)
=>
ToFrom (FullOuterJoin a (b, (ma :& mb) -> SqlExpr (Value Bool)))
where
toFrom (FullOuterJoin lhs (rhs, on')) =
FullJoinFrom (toFrom lhs) (toFrom rhs, on')
instance ( ToFrom a
instance
( ToFrom a
, ToFromT a ~ a'
, ToMaybe a'
, ma ~ ToMaybeT a'
, ToFrom b
, ToFromT b ~ b'
, ErrorOnLateral b
) => ToFrom (RightOuterJoin a (b, (ma :& b') -> SqlExpr (Value Bool))) where
toFrom (RightOuterJoin lhs (rhs, on')) = RightJoinFrom (toFrom lhs) (toFrom rhs, on')
)
=>
ToFrom (RightOuterJoin a (b, (ma :& b') -> SqlExpr (Value Bool)))
where
toFrom (RightOuterJoin lhs (rhs, on')) =
RightJoinFrom (toFrom lhs) (toFrom rhs, on')
type family Nullable a where
Nullable (Maybe a) = a
@ -873,47 +974,68 @@ instance (ToMaybe a, ToMaybe b) => ToMaybe (a :& b) where
instance (ToMaybe a, ToMaybe b) => ToMaybe (a,b) where
toMaybe (a, b) = (toMaybe a, toMaybe b)
instance ( ToMaybe a
instance
( ToMaybe a
, ToMaybe b
, ToMaybe c
) => ToMaybe (a,b,c) where
)
=>
ToMaybe (a,b,c)
where
toMaybe = to3 . toMaybe . from3
instance ( ToMaybe a
instance
( ToMaybe a
, ToMaybe b
, ToMaybe c
, ToMaybe d
) => ToMaybe (a,b,c,d) where
)
=>
ToMaybe (a,b,c,d)
where
toMaybe = to4 . toMaybe . from4
instance ( ToMaybe a
instance
( ToMaybe a
, ToMaybe b
, ToMaybe c
, ToMaybe d
, ToMaybe e
) => ToMaybe (a,b,c,d,e) where
)
=>
ToMaybe (a,b,c,d,e)
where
toMaybe = to5 . toMaybe . from5
instance ( ToMaybe a
instance
( ToMaybe a
, ToMaybe b
, ToMaybe c
, ToMaybe d
, ToMaybe e
, ToMaybe f
) => ToMaybe (a,b,c,d,e,f) where
)
=>
ToMaybe (a,b,c,d,e,f)
where
toMaybe = to6 . toMaybe . from6
instance ( ToMaybe a
instance
( ToMaybe a
, ToMaybe b
, ToMaybe c
, ToMaybe d
, ToMaybe e
, ToMaybe f
, ToMaybe g
) => ToMaybe (a,b,c,d,e,f,g) where
)
=>
ToMaybe (a,b,c,d,e,f,g)
where
toMaybe = to7 . toMaybe . from7
instance ( ToMaybe a
instance
( ToMaybe a
, ToMaybe b
, ToMaybe c
, ToMaybe d
@ -921,7 +1043,10 @@ instance ( ToMaybe a
, ToMaybe f
, ToMaybe g
, ToMaybe h
) => ToMaybe (a,b,c,d,e,f,g,h) where
)
=>
ToMaybe (a,b,c,d,e,f,g,h)
where
toMaybe = to8 . toMaybe . from8
-- | 'FROM' clause, used to bring entities into scope.
@ -1006,12 +1131,10 @@ from parts = do
SqlSetIntersect o1 o2 -> doSetOperation "INTERSECT" info o1 o2
doSetOperation operationText info o1 o2 =
let
(q1, v1) = operationToSql o1 info
let (q1, v1) = operationToSql o1 info
(q2, v2) = operationToSql o2 info
in (q1 <> " " <> operationText <> " " <> q2, v1 <> v2)
runFrom (InnerJoinFrom leftPart (rightPart, on')) = do
(leftVal, leftFrom) <- runFrom leftPart
(rightVal, rightFrom) <- runFrom rightPart
@ -1053,7 +1176,9 @@ from parts = do
let ret = (toMaybe leftVal) :& (toMaybe rightVal)
pure $ (ret, FromJoin leftFrom FullOuterJoinKind rightFrom (Just (on' ret)))
fromSubQuery :: ( SqlSelect a r
fromSubQuery
::
( SqlSelect a r
, ToAlias a
, ToAliasReference a
)
@ -1072,8 +1197,6 @@ fromSubQuery subqueryType subquery = do
ref <- toAliasReference subqueryAlias aliasedValue
pure (ref , FromQuery subqueryAlias (\info -> toRawSql SELECT info aliasedQuery) subqueryType)
-- | @WITH@ clause used to introduce a [Common Table Expression (CTE)](https://en.wikipedia.org/wiki/Hierarchical_and_recursive_queries_in_SQL#Common_table_expression).
-- CTEs are supported in most modern SQL engines and can be useful
-- in performance tuning. In Esqueleto, CTEs should be used as a
@ -1243,7 +1366,6 @@ instance ( ToAlias a
) => ToAlias (a,b,c,d,e,f,g,h) where
toAlias x = to8 <$> (toAlias $ from8 x)
{-# DEPRECATED ToAliasReferenceT "This type alias doesn't do anything. Please delete it. Will be removed in the next release." #-}
type ToAliasReferenceT a = a
@ -1265,6 +1387,7 @@ instance ToAliasReference (SqlExpr (Entity a)) where
instance ToAliasReference (SqlExpr (Maybe (Entity a))) where
toAliasReference s (EMaybe e) = EMaybe <$> toAliasReference s e
instance (ToAliasReference a, ToAliasReference b) => ToAliasReference (a, b) where
toAliasReference ident (a,b) = (,) <$> (toAliasReference ident a) <*> (toAliasReference ident b)
@ -1325,5 +1448,6 @@ class RecursiveCteUnion a where
instance RecursiveCteUnion (a -> b -> Union a b) where
unionKeyword _ = "\nUNION\n"
instance RecursiveCteUnion (a -> b -> UnionAll a b) where
unionKeyword _ = "\nUNION ALL\n"

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

File diff suppressed because it is too large Load Diff

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

@ -1,17 +1,20 @@
{-# LANGUAGE DeriveDataTypeable
, EmptyDataDecls
, FlexibleContexts
, FlexibleInstances
, FunctionalDependencies
, MultiParamTypeClasses
, TypeFamilies
, UndecidableInstances
, GADTs
#-}
{-# 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(..)
@ -41,22 +44,90 @@ module Database.Esqueleto.Internal.Language
, 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, (<#), (<&>)
, 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
@ -65,5 +136,5 @@ module Database.Esqueleto.Internal.Language
, subSelectUnsafe
) where
import Database.Esqueleto.Internal.PersistentImport
import Database.Esqueleto.Internal.Internal
import Database.Esqueleto.Internal.PersistentImport

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

@ -142,9 +142,36 @@ module Database.Esqueleto.Internal.PersistentImport
) where
import Database.Persist.Sql hiding
( BackendSpecificFilter, Filter(..), PersistQuery, SelectOpt(..)
, Update(..), delete, deleteWhereCount, updateWhereCount, selectList
, selectKeysList, deleteCascadeWhere, (=.), (+=.), (-=.), (*=.), (/=.)
, (==.), (!=.), (<.), (>.), (<=.), (>=.), (<-.), (/<-.), (||.)
, listToJSON, mapToJSON, getPersistMap, limitOffsetOrder, selectSource
, update , count )
( BackendSpecificFilter
, Filter(..)
, PersistQuery
, SelectOpt(..)
, Update(..)
, count
, delete
, deleteCascadeWhere
, deleteWhereCount
, getPersistMap
, limitOffsetOrder
, listToJSON
, mapToJSON
, selectKeysList
, selectList
, selectSource
, update
, updateWhereCount
, (!=.)
, (*=.)
, (+=.)
, (-=.)
, (/<-.)
, (/=.)
, (<-.)
, (<.)
, (<=.)
, (=.)
, (==.)
, (>.)
, (>=.)
, (||.)
)

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

@ -1,31 +1,27 @@
{-# LANGUAGE DeriveDataTypeable
, EmptyDataDecls
, FlexibleContexts
, FlexibleInstances
, FunctionalDependencies
, MultiParamTypeClasses
, TypeFamilies
, UndecidableInstances
, GADTs
#-}
{-# LANGUAGE ConstraintKinds
, EmptyDataDecls
, FlexibleContexts
, FlexibleInstances
, FunctionalDependencies
, GADTs
, MultiParamTypeClasses
, OverloadedStrings
, UndecidableInstances
, ScopedTypeVariables
, InstanceSigs
, Rank2Types
, CPP
#-}
{-# 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(..)

6
src/Database/Esqueleto/MySQL.hs
View File

@ -1,14 +1,14 @@
{-# LANGUAGE OverloadedStrings #-}
-- | This module contain MySQL-specific functions.
--
-- /Since: 2.2.8/
-- @since 2.2.8
module Database.Esqueleto.MySQL
( random_
) where
import Database.Esqueleto.Internal.Language hiding (random_)
import Database.Esqueleto.Internal.Internal hiding (random_)
import Database.Esqueleto.Internal.PersistentImport
import Database.Esqueleto.Internal.Sql
-- | (@random()@) Split out into database specific modules
-- because MySQL uses `rand()`.

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

@ -1,11 +1,13 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings
, GADTs, CPP, Rank2Types
, ScopedTypeVariables
#-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | This module contain PostgreSQL-specific functions.
--
-- /Since: 2.2.8/
-- @since: 2.2.8
module Database.Esqueleto.PostgreSQL
( AggMode(..)
, arrayAggDistinct
@ -31,29 +33,24 @@ module Database.Esqueleto.PostgreSQL
#if __GLASGOW_HASKELL__ < 804
import Data.Semigroup
#endif
import qualified Data.Text.Internal.Builder as TLB
import Data.Time.Clock (UTCTime)
import Database.Esqueleto.Internal.Language hiding (random_)
import Database.Esqueleto.Internal.PersistentImport hiding (upsert, upsertBy)
import Database.Esqueleto.Internal.Sql
import Database.Esqueleto.Internal.Internal (EsqueletoError(..), CompositeKeyError(..),
UnexpectedCaseError(..), SetClause, Ident(..),
uncommas, FinalResult(..), toUniqueDef,
KnowResult, renderUpdates, UnexpectedValueError(..))
import Database.Persist.Class (OnlyOneUniqueKey)
import Data.List.NonEmpty ( NonEmpty( (:|) ) )
import Data.Int (Int64)
import Data.Proxy (Proxy(..))
import Control.Arrow ((***), first)
import Control.Arrow (first, (***))
import Control.Exception (throw)
import Control.Monad (void)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.IO.Class (MonadIO(..))
import qualified Control.Monad.Trans.Reader as R
import Data.Int (Int64)
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.Proxy (Proxy(..))
import qualified Data.Text.Internal.Builder as TLB
import Data.Time.Clock (UTCTime)
import Database.Esqueleto.Internal.Internal hiding (random_)
import Database.Esqueleto.Internal.PersistentImport hiding (upsert, upsertBy)
import Database.Persist.Class (OnlyOneUniqueKey)
-- | (@random()@) Split out into database specific modules
-- because MySQL uses `rand()`.
--
-- /Since: 2.6.0/
-- @since 2.6.0
random_ :: (PersistField a, Num a) => SqlExpr (Value a)
random_ = unsafeSqlValue "RANDOM()"
@ -69,7 +66,8 @@ maybeArray ::
maybeArray x = coalesceDefault [x] (emptyArray)
-- | Aggregate mode
data AggMode = AggModeAll -- ^ ALL
data AggMode
= AggModeAll -- ^ ALL
| AggModeDistinct -- ^ DISTINCT
deriving (Show)
@ -77,24 +75,26 @@ data AggMode = AggModeAll -- ^ ALL
--
-- /Do/ /not/ use this function directly, instead define a new function and give
-- it a type (see `unsafeSqlBinOp`)
unsafeSqlAggregateFunction ::
UnsafeSqlFunctionArgument a
unsafeSqlAggregateFunction
:: UnsafeSqlFunctionArgument a
=> TLB.Builder
-> AggMode
-> a
-> [OrderByClause]
-> SqlExpr (Value b)
unsafeSqlAggregateFunction name mode args orderByClauses =
ERaw Never $ \info ->
unsafeSqlAggregateFunction name mode args orderByClauses = ERaw Never $ \info ->
let (orderTLB, orderVals) = makeOrderByNoNewline info orderByClauses
-- Don't add a space if we don't have order by clauses
orderTLBSpace = case orderByClauses of
orderTLBSpace =
case orderByClauses of
[] -> ""
(_:_) -> " "
(argsTLB, argsVals) =
uncommas' $ map (\(ERaw _ f) -> f info) $ toArgList args
aggMode = case mode of
AggModeAll -> "" -- ALL is the default, so we don't need to
aggMode =
case mode of
AggModeAll -> ""
-- ALL is the default, so we don't need to
-- specify it
AggModeDistinct -> "DISTINCT "
in ( name <> parens (aggMode <> argsTLB <> orderTLBSpace <> orderTLB)
@ -103,8 +103,8 @@ unsafeSqlAggregateFunction name mode args orderByClauses =
--- | (@array_agg@) Concatenate input values, including @NULL@s,
--- into an array.
arrayAggWith ::
AggMode
arrayAggWith
:: AggMode
-> SqlExpr (Value a)
-> [OrderByClause]
-> SqlExpr (Value (Maybe [a]))
@ -118,18 +118,17 @@ arrayAgg x = arrayAggWith AggModeAll x []
-- | (@array_agg@) Concatenate distinct input values, including @NULL@s, into
-- an array.
--
-- /Since: 2.5.3/
arrayAggDistinct ::
(PersistField a, PersistField [a])
-- @since 2.5.3
arrayAggDistinct
:: (PersistField a, PersistField [a])
=> SqlExpr (Value a)
-> SqlExpr (Value (Maybe [a]))
arrayAggDistinct x = arrayAggWith AggModeDistinct x []
-- | (@array_remove@) Remove all elements equal to the given value from the
-- array.
--
-- /Since: 2.5.3/
-- @since 2.5.3
arrayRemove :: SqlExpr (Value [a]) -> SqlExpr (Value a) -> SqlExpr (Value [a])
arrayRemove arr elem' = unsafeSqlFunction "array_remove" (arr, elem')
@ -154,7 +153,7 @@ stringAggWith mode expr delim os =
-- | (@string_agg@) Concatenate input values separated by a
-- delimiter.
--
-- /Since: 2.2.8/
-- @since 2.2.8
stringAgg ::
SqlString s
=> SqlExpr (Value s) -- ^ Input values.
@ -165,18 +164,21 @@ stringAgg expr delim = stringAggWith AggModeAll expr delim []
-- | (@chr@) Translate the given integer to a character. (Note the result will
-- depend on the character set of your database.)
--
-- /Since: 2.2.11/
-- @since 2.2.11
chr :: SqlString s => SqlExpr (Value Int) -> SqlExpr (Value s)
chr = unsafeSqlFunction "chr"
now_ :: SqlExpr (Value UTCTime)
now_ = unsafeSqlFunction "NOW" ()
upsert :: (MonadIO m,
PersistEntity record,
OnlyOneUniqueKey record,
PersistRecordBackend record SqlBackend,
IsPersistBackend (PersistEntityBackend record))
upsert
::
( MonadIO m
, PersistEntity record
, OnlyOneUniqueKey record
, PersistRecordBackend record SqlBackend
, IsPersistBackend (PersistEntityBackend record)
)
=> record
-- ^ new record to insert
-> [SqlExpr (Update record)]
@ -187,9 +189,12 @@ upsert record updates = do
uniqueKey <- onlyUnique record
upsertBy uniqueKey record updates
upsertBy :: (MonadIO m,
PersistEntity record,
IsPersistBackend (PersistEntityBackend record))
upsertBy
::
(MonadIO m
, PersistEntity record
, IsPersistBackend (PersistEntityBackend record)
)
=> Unique record
-- ^ uniqueness constraint to find by
-> record
@ -245,29 +250,30 @@ upsertBy uniqueKey record updates = do
-- the conflicting value is updated to the current plus the excluded.
--
-- @since 3.1.3
insertSelectWithConflict :: forall a m val. (
FinalResult a,
KnowResult a ~ (Unique val),
MonadIO m,
PersistEntity val) =>
a
-- ^ Unique constructor or a unique, this is used just to get the name of the postgres constraint, the value(s) is(are) never used, so if you have a unique "MyUnique 0", "MyUnique undefined" would work as well.
insertSelectWithConflict
:: forall a m val
. (FinalResult a, KnowResult a ~ Unique val, MonadIO m, PersistEntity val)
=> a
-- ^ Unique constructor or a unique, this is used just to get the name of
-- the postgres constraint, the value(s) is(are) never used, so if you have
-- a unique "MyUnique 0", "MyUnique undefined" would work as well.
-> SqlQuery (SqlExpr (Insertion val))
-- ^ Insert query.
-> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Update val)])
-- ^ A list of updates to be applied in case of the constraint being violated. The expression takes the current and excluded value to produce the updates.
-- ^ A list of updates to be applied in case of the constraint being
-- violated. The expression takes the current and excluded value to produce
-- the updates.
-> SqlWriteT m ()
insertSelectWithConflict unique query = void . insertSelectWithConflictCount unique query
insertSelectWithConflict unique query =
void . insertSelectWithConflictCount unique query
-- | Same as 'insertSelectWithConflict' but returns the number of rows affected.
--
-- @since 3.1.3
insertSelectWithConflictCount :: forall a val m. (
FinalResult a,
KnowResult a ~ (Unique val),
MonadIO m,
PersistEntity val) =>
a
insertSelectWithConflictCount
:: forall a val m
. (FinalResult a, KnowResult a ~ Unique val, MonadIO m, PersistEntity val)
=> a
-> SqlQuery (SqlExpr (Insertion val))
-> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Update val)])
-> SqlWriteT m Int64
@ -289,7 +295,7 @@ insertSelectWithConflictCount unique query conflictQuery = do
constraint = TLB.fromText . unDBName . uniqueDBName $ uniqueDef
renderedUpdates :: (BackendCompatible SqlBackend backend) => backend -> (TLB.Builder, [PersistValue])
renderedUpdates conn = renderUpdates conn updates
conflict conn = (foldr1 mappend ([
conflict conn = (mconcat ([
TLB.fromText "ON CONFLICT ON CONSTRAINT \"",
constraint,
TLB.fromText "\" DO "

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

@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
{-|
This module contains PostgreSQL-specific JSON functions.
@ -135,17 +136,15 @@ module Database.Esqueleto.PostgreSQL.JSON
) where
import Data.Text (Text)
import Database.Esqueleto.Internal.Language 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 ->., ->>., #>., #>>.
infixl 6 @>., <@., ?., ?|., ?&.
infixl 6 ||., -., --., #-.
-- | /Requires PostgreSQL version >= 9.3/
--
-- This function extracts the jsonb value from a JSON array or object,

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

@ -4,6 +4,8 @@
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# language DerivingStrategies #-}
module Database.Esqueleto.PostgreSQL.JSON.Instances where
import Data.Aeson (FromJSON(..), ToJSON(..), encode, eitherDecodeStrict)
@ -18,15 +20,12 @@ import Database.Esqueleto.Internal.PersistentImport
import Database.Esqueleto.Internal.Sql (SqlExpr)
import GHC.Generics (Generic)
-- | Newtype wrapper around any type with a JSON representation.
--
-- @since 3.1.0
newtype JSONB a = JSONB { unJSONB :: a }
deriving
deriving stock
( Generic
, FromJSON
, ToJSON
, Eq
, Foldable
, Functor
@ -35,6 +34,10 @@ newtype JSONB a = JSONB { unJSONB :: a }
, Show
, Traversable
)
deriving newtype
( FromJSON
, ToJSON
)
-- | 'SqlExpr' of a NULL-able 'JSONB' value. Hence the 'Maybe'.
--
@ -60,7 +63,8 @@ jsonbVal = just . val . JSONB
-- JSONKey "name"
--
-- NOTE: DO NOT USE ANY OF THE 'Num' METHODS ON THIS TYPE!
data JSONAccessor = JSONIndex Int
data JSONAccessor
= JSONIndex Int
| JSONKey Text
deriving (Generic, Eq, Show)

6
src/Database/Esqueleto/SQLite.hs
View File

@ -1,14 +1,14 @@
{-# LANGUAGE OverloadedStrings #-}
-- | This module contain SQLite-specific functions.
--
-- /Since: 2.2.8/
-- @since 2.2.8
module Database.Esqueleto.SQLite
( random_
) where
import Database.Esqueleto.Internal.Language hiding (random_)
import Database.Esqueleto.Internal.Internal hiding (random_)
import Database.Esqueleto.Internal.PersistentImport
import Database.Esqueleto.Internal.Sql
-- | (@random()@) Split out into database specific modules
-- because MySQL uses `rand()`.

9
style-guide.md Normal file
View File

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

354
test/Common/Test.hs
View File

@ -1,26 +1,27 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-unused-binds #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-}
{-# LANGUAGE ConstraintKinds
, CPP, DerivingStrategies, StandaloneDeriving
, TypeApplications
, PartialTypeSignatures
, UndecidableInstances
, EmptyDataDecls
, FlexibleContexts
, FlexibleInstances
, DeriveGeneric
, GADTs
, GeneralizedNewtypeDeriving
, MultiParamTypeClasses
, OverloadedStrings
, QuasiQuotes
, Rank2Types
, TemplateHaskell
, TypeFamilies
, ScopedTypeVariables
, TypeSynonymInstances
#-}
module Common.Test
( tests
, testLocking
@ -60,17 +61,18 @@ module Common.Test
, Key(..)
) where
import Control.Monad (forM_, replicateM, replicateM_, void)
import Control.Monad.Catch (MonadCatch)
import Control.Monad.Reader (ask)
import Data.Either
import Data.Time
import Control.Monad (forM_, replicateM, replicateM_, void)
import Control.Monad.Reader (ask)
import Control.Monad.Catch (MonadCatch)
#if __GLASGOW_HASKELL__ >= 806
import Control.Monad.Fail (MonadFail)
#endif
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Logger (MonadLogger (..), NoLoggingT, runNoLoggingT)
import Control.Monad.Logger (MonadLogger(..), NoLoggingT, runNoLoggingT)
import Control.Monad.Trans.Reader (ReaderT)
import qualified Data.Attoparsec.Text as AP
import Data.Char (toLower, toUpper)
import Data.Monoid ((<>))
import Database.Esqueleto
@ -79,18 +81,17 @@ import qualified Database.Esqueleto.Experimental as Experimental
import Database.Persist.TH
import Test.Hspec
import UnliftIO
import qualified Data.Attoparsec.Text as AP
import Data.Conduit (ConduitT, (.|), runConduit)
import Data.Conduit (ConduitT, runConduit, (.|))
import qualified Data.Conduit.List as CL
import qualified Data.List as L
import qualified Data.Set as S
import qualified Data.Text as Text
import qualified Data.Text.Lazy.Builder as TLB
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 UnliftIO.Resource as R
import qualified Database.Esqueleto.Internal.ExprParser as P
-- Test schema
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
@ -326,18 +327,17 @@ testSelect run = do
testSubSelect :: Run -> Spec
testSubSelect run = do
let
setup :: MonadIO m => SqlPersistT m ()
let setup :: MonadIO m => SqlPersistT m ()
setup = do
_ <- insert $ Numbers 1 2
_ <- insert $ Numbers 2 4
_ <- insert $ Numbers 3 5
_ <- insert $ Numbers 6 7
pure ()
describe "subSelect" $ do
it "is safe for queries that may return multiple results" $ do
let
query =
let query =
from $ \n -> do
orderBy [asc (n ^. NumbersInt)]
pure (n ^. NumbersInt)
@ -360,8 +360,7 @@ testSubSelect run = do
v `shouldBe` [Value 1]
it "is safe for queries that may not return anything" $ do
let
query =
let query =
from $ \n -> do
orderBy [asc (n ^. NumbersInt)]
limit 1
@ -386,8 +385,7 @@ testSubSelect run = do
describe "subSelectList" $ do
it "is safe on empty databases as well as good databases" $ do
let
query =
let query =
from $ \n -> do
where_ $ n ^. NumbersInt `in_` do
subSelectList $
@ -408,11 +406,8 @@ testSubSelect run = do
describe "subSelectMaybe" $ do
it "is equivalent to joinV . subSelect" $ do
let
query
:: ( SqlQuery (SqlExpr (Value (Maybe Int)))
-> SqlExpr (Value (Maybe Int))
)
let query
:: (SqlQuery (SqlExpr (Value (Maybe Int))) -> SqlExpr (Value (Maybe Int)))
-> SqlQuery (SqlExpr (Value (Maybe Int)))
query selector =
from $ \n -> do
@ -497,12 +492,10 @@ testSubSelect run = do
Right xs ->
xs `shouldBe` []
testSelectSource :: Run -> Spec
testSelectSource run = do
describe "selectSource" $ do
it "works for a simple example" $
run $ do
it "works for a simple example" $ run $ do
let query = selectSource $
from $ \person ->
return person
@ -510,8 +503,7 @@ testSelectSource run = do
ret <- runConduit $ query .| CL.consume
liftIO $ ret `shouldBe` [ p1e ]
it "can run a query many times" $
run $ do
it "can run a query many times" $ run $ do
let query = selectSource $
from $ \person ->
return person
@ -524,57 +516,57 @@ testSelectSource run = do
it "works on repro" $ do
let selectPerson :: R.MonadResource m => String -> ConduitT () (Key Person) (SqlPersistT m) ()
selectPerson name = do
let source = selectSource $ from $ \person -> do
let source =
selectSource $ from $ \person -> do
where_ $ person ^. PersonName ==. val name
return $ person ^. PersonId
source .| CL.map unValue
run $ do
p1e <- insert' p1
p2e <- insert' p2
r1 <- runConduit $
selectPerson (personName p1) .| CL.consume
r2 <- runConduit $
selectPerson (personName p2) .| CL.consume
r1 <- runConduit $ selectPerson (personName p1) .| CL.consume
r2 <- runConduit $ selectPerson (personName p2) .| CL.consume
liftIO $ do
r1 `shouldBe` [ entityKey p1e ]
r2 `shouldBe` [ entityKey p2e ]
testSelectFrom :: Run -> Spec
testSelectFrom run = do
describe "select/from" $ do
it "works for a simple example" $
run $ do
it "works for a simple example" $ run $ do
p1e <- insert' p1
ret <- select $
ret <-
select $
from $ \person ->
return person
liftIO $ ret `shouldBe` [ p1e ]
it "works for a simple self-join (one entity)" $
run $ do
it "works for a simple self-join (one entity)" $ run $ do
p1e <- insert' p1
ret <- select $
ret <-
select $
from $ \(person1, person2) ->
return (person1, person2)
liftIO $ ret `shouldBe` [ (p1e, p1e) ]
it "works for a simple self-join (two entities)" $
run $ do
it "works for a simple self-join (two entities)" $ run $ do
p1e <- insert' p1
p2e <- insert' p2
ret <- select $
ret <-
select $
from $ \(person1, person2) ->
return (person1, person2)
liftIO $ ret `shouldSatisfy` sameElementsAs [ (p1e, p1e)
liftIO $
ret
`shouldSatisfy`
sameElementsAs
[ (p1e, p1e)
, (p1e, p2e)
, (p2e, p1e)
, (p2e, p2e) ]
, (p2e, p2e)
]
it "works for a self-join via sub_select" $
run $ do
it "works for a self-join via sub_select" $ run $ do
p1k <- insert p1
p2k <- insert p2
_f1k <- insert (Follow p1k p2k)
@ -589,8 +581,7 @@ testSelectFrom run = do
return followA
liftIO $ length ret `shouldBe` 2
it "works for a self-join via exists" $
run $ do
it "works for a self-join via exists" $ run $ do
p1k <- insert p1
p2k <- insert p2
_f1k <- insert (Follow p1k p2k)
@ -604,8 +595,7 @@ testSelectFrom run = do
liftIO $ length ret `shouldBe` 2
it "works for a simple projection" $
run $ do
it "works for a simple projection" $ run $ do
p1k <- insert p1
p2k <- insert p2
ret <- select $
@ -614,8 +604,7 @@ testSelectFrom run = do
liftIO $ ret `shouldBe` [ (Value p1k, Value (personName p1))
, (Value p2k, Value (personName p2)) ]
it "works for a simple projection with a simple implicit self-join" $
run $ do
it "works for a simple projection with a simple implicit self-join" $ run $ do
_ <- insert p1
_ <- insert p2
ret <- select $
@ -627,31 +616,35 @@ testSelectFrom run = do
, (Value (personName p2), Value (personName p1))
, (Value (personName p2), Value (personName p2)) ]
it "works with many kinds of LIMITs and OFFSETs" $
run $ do
it "works with many kinds of LIMITs and OFFSETs" $ run $ do
[p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4]
let people = from $ \p -> do
let people =
from $ \p -> do
orderBy [asc (p ^. PersonName)]
return p
ret1 <- select $ do
ret1 <-
select $ do
p <- people
limit 2
limit 1
return p
liftIO $ ret1 `shouldBe` [ p1e ]
ret2 <- select $ do
ret2 <-
select $ do
p <- people
limit 1
limit 2
return p
liftIO $ ret2 `shouldBe` [ p1e, p4e ]
ret3 <- select $ do
ret3 <-
select $ do
p <- people
offset 3
offset 2
return p
liftIO $ ret3 `shouldBe` [ p3e, p2e ]
ret4 <- select $ do
ret4 <-
select $ do
p <- people
offset 3
limit 5
@ -661,7 +654,8 @@ testSelectFrom run = do
limit 2
return p
liftIO $ ret4 `shouldBe` [ p4e, p3e ]
ret5 <- select $ do
ret5 <-
select $ do
p <- people
offset 1000
limit 1
@ -670,8 +664,7 @@ testSelectFrom run = do
return p
liftIO $ ret5 `shouldBe` [ p1e, p4e, p3e, p2e ]
it "works with non-id primary key" $
run $ do
it "works with non-id primary key" $ run $ do
let fc = Frontcover number ""
number = 101
Right thePk = keyFromValues [toPersistValue number]
@ -681,8 +674,7 @@ testSelectFrom run = do
ret `shouldBe` fc
fcPk `shouldBe` thePk
it "works when returning a custom non-composite primary key from a query" $
run $ do
it "works when returning a custom non-composite primary key from a query" $ run $ do
let name = "foo"
t = Tag name
Right thePk = keyFromValues [toPersistValue name]
@ -692,15 +684,12 @@ testSelectFrom run = do
ret `shouldBe` thePk
thePk `shouldBe` tagPk
it "works when returning a composite primary key from a query" $
run $ do
it "works when returning a composite primary key from a query" $ run $ do
let p = Point 10 20 ""
thePk <- insert p
[Value ppk] <- select $ from $ \p' -> return (p'^.PointId)
liftIO $ ppk `shouldBe` thePk
testSelectJoin :: Run -> Spec
testSelectJoin run = do
describe "select:JOIN" $ do
@ -883,10 +872,8 @@ testSelectJoin run = do
liftIO $ (entityVal <$> ps) `shouldBe` [p1]
testSelectSubQuery :: Run -> Spec
testSelectSubQuery run = do
describe "select subquery" $ do
it "works" $ do
run $ do
testSelectSubQuery run = describe "select subquery" $ do
it "works" $ run $ do
_ <- insert' p1
let q = do
p <- Experimental.from $ Table @Person
@ -894,8 +881,7 @@ testSelectSubQuery run = do
ret <- select $ Experimental.from q
liftIO $ ret `shouldBe` [ (Value $ personName p1, Value $ personAge p1) ]
it "supports sub-selecting Maybe entities" $ do
run $ do
it "supports sub-selecting Maybe entities" $ run $ do
l1e <- insert' l1
l3e <- insert' l3
l1Deeds <- mapM (\k -> insert' $ Deed k (entityKey l1e)) (map show [1..3 :: Int])
@ -909,8 +895,7 @@ testSelectSubQuery run = do
pure (lords, deeds)
liftIO $ ret `shouldMatchList` ((l3e, Nothing) : l1WithDeeds)
it "lets you order by alias" $ do
run $ do
it "lets you order by alias" $ run $ do
_ <- insert' p1
_ <- insert' p3
let q = do
@ -923,8 +908,7 @@ testSelectSubQuery run = do
ret <- select q
liftIO $ ret `shouldBe` [ Value $ personName p3, Value $ personName p1 ]
it "supports groupBy" $ do
run $ do
it "supports groupBy" $ run $ do
l1k <- insert l1
l3k <- insert l3
mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int])
@ -945,8 +929,7 @@ testSelectSubQuery run = do
liftIO $ ret `shouldMatchList` [ (Value l3k, Value 7)
, (Value l1k, Value 3) ]
it "Can count results of aggregate query" $ do
run $ do
it "Can count results of aggregate query" $ run $ do
l1k <- insert l1
l3k <- insert l3
mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int])
@ -967,8 +950,7 @@ testSelectSubQuery run = do
liftIO $ ret `shouldMatchList` [ (Value 1) ]
it "joins on subqueries" $ do
run $ do
it "joins on subqueries" $ run $ do
l1k <- insert l1
l3k <- insert l3
mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int])
@ -985,8 +967,7 @@ testSelectSubQuery run = do
liftIO $ ret `shouldMatchList` [ (Value l3k, Value 7)
, (Value l1k, Value 3) ]
it "flattens maybe values" $ do
run $ do
it "flattens maybe values" $ run $ do
l1k <- insert l1
l3k <- insert l3
let q = do
@ -1001,8 +982,7 @@ testSelectSubQuery run = do
(ret :: [(Value (Key Lord), Value (Maybe Int))]) <- select q
liftIO $ ret `shouldMatchList` [ (Value l3k, Value (lordDogs l3))
, (Value l1k, Value (lordDogs l1)) ]
it "unions" $ do
run $ do
it "unions" $ run $ do
_ <- insert p1
_ <- insert p2
let q = Experimental.from $
@ -1024,10 +1004,8 @@ testSelectSubQuery run = do
liftIO $ names `shouldMatchList` [ (Value $ personName p1)
, (Value $ personName p2) ]
testSelectWhere :: Run -> Spec
testSelectWhere run = do
describe "select where_" $ do
it "works for a simple example with (==.)" $
run $ do
testSelectWhere run = describe "select where_" $ do
it "works for a simple example with (==.)" $ run $ do
p1e <- insert' p1
_ <- insert' p2
_ <- insert' p3
@ -1037,8 +1015,7 @@ testSelectWhere run = do
return p
liftIO $ ret `shouldBe` [ p1e ]
it "works for a simple example with (==.) and (||.)" $
run $ do
it "works for a simple example with (==.) and (||.)" $ run $ do
p1e <- insert' p1
p2e <- insert' p2
_ <- insert' p3
@ -1048,8 +1025,7 @@ testSelectWhere run = do
return p
liftIO $ ret `shouldBe` [ p1e, p2e ]
it "works for a simple example with (>.) [uses val . Just]" $
run $ do
it "works for a simple example with (>.) [uses val . Just]" $ run $ do
p1e <- insert' p1
_ <- insert' p2
_ <- insert' p3
@ -1059,8 +1035,7 @@ testSelectWhere run = do
return p
liftIO $ ret `shouldBe` [ p1e ]
it "works for a simple example with (>.) and not_ [uses just . val]" $
run $ do
it "works for a simple example with (>.) and not_ [uses just . val]" $ run $ do
_ <- insert' p1
_ <- insert' p2
p3e <- insert' p3
@ -1071,8 +1046,7 @@ testSelectWhere run = do
liftIO $ ret `shouldBe` [ p3e ]
describe "when using between" $ do
it "works for a simple example with [uses just . val]" $
run $ do
it "works for a simple example with [uses just . val]" $ run $ do
p1e <- insert' p1
_ <- insert' p2
_ <- insert' p3
@ -1081,8 +1055,7 @@ testSelectWhere run = do
where_ ((p ^. PersonAge) `between` (just $ val 20, just $ val 40))
return p
liftIO $ ret `shouldBe` [ p1e ]
it "works for a proyected fields value" $
run $ do
it "works for a proyected fields value" $ run $ do
_ <- insert' p1 >> insert' p2 >> insert' p3
ret <-
select $
@ -1093,8 +1066,7 @@ testSelectWhere run = do
(p ^. PersonAge, p ^. PersonWeight)
liftIO $ ret `shouldBe` []
describe "when projecting composite keys" $ do
it "works when using composite keys with val" $
run $ do
it "works when using composite keys with val" $ run $ do
insert_ $ Point 1 2 ""
ret <-
select $
@ -1105,8 +1077,7 @@ testSelectWhere run = do
( val $ PointKey 1 2
, val $ PointKey 5 6 )
liftIO $ ret `shouldBe` [()]
it "works when using ECompositeKey constructor" $
run $ do
it "works when using ECompositeKey constructor" $ run $ do
insert_ $ Point 1 2 ""
ret <-
select $
@ -1118,8 +1089,7 @@ testSelectWhere run = do
, EI.ECompositeKey $ const ["5", "6"] )
liftIO $ ret `shouldBe` []
it "works with avg_" $
run $ do
it "works with avg_" $ run $ do
_ <- insert' p1
_ <- insert' p2
_ <- insert' p3
@ -1145,8 +1115,7 @@ testSelectWhere run = do
return $ joinV $ min_ (p ^. PersonAge)
liftIO $ ret `shouldBe` [ Value $ Just (17 :: Int) ]
it "works with max_" $
run $ do
it "works with max_" $ run $ do
_ <- insert' p1
_ <- insert' p2
_ <- insert' p3
@ -1156,8 +1125,7 @@ testSelectWhere run = do
return $ joinV $ max_ (p ^. PersonAge)
liftIO $ ret `shouldBe` [ Value $ Just (36 :: Int) ]
it "works with lower_" $
run $ do
it "works with lower_" $ run $ do
p1e <- insert' p1
p2e@(Entity _ bob) <- insert' $ Person "bob" (Just 36) Nothing 1
@ -1175,13 +1143,11 @@ testSelectWhere run = do
return p
liftIO $ ret2 `shouldBe` [ p2e ]
it "works with round_" $
run $ do
it "works with round_" $ run $ do
ret <- select $ return $ round_ (val (16.2 :: Double))
liftIO $ ret `shouldBe` [ Value (16 :: Double) ]
it "works with isNothing" $
run $ do
it "works with isNothing" $ run $ do
_ <- insert' p1
p2e <- insert' p2
_ <- insert' p3
@ -1191,8 +1157,7 @@ testSelectWhere run = do
return p
liftIO $ ret `shouldBe` [ p2e ]
it "works with not_ . isNothing" $
run $ do
it "works with not_ . isNothing" $ run $ do
p1e <- insert' p1
_ <- insert' p2
ret <- select $
@ -1223,8 +1188,7 @@ testSelectWhere run = do
, (p4e, f42, p2e)
, (p2e, f21, p1e) ]
it "works for a many-to-many explicit join" $
run $ do
it "works for a many-to-many explicit join" $ run $ do
p1e@(Entity p1k _) <- insert' p1
p2e@(Entity p2k _) <- insert' p2
_ <- insert' p3
@ -1256,8 +1220,7 @@ testSelectWhere run = do
-- we only care that we don't have a SQL error
True `shouldBe` True
it "works for a many-to-many explicit join with LEFT OUTER JOINs" $
run $ do
it "works for a many-to-many explicit join with LEFT OUTER JOINs" $ run $ do
p1e@(Entity p1k _) <- insert' p1
p2e@(Entity p2k _) <- insert' p2
p3e <- insert' p3
@ -1279,8 +1242,7 @@ testSelectWhere run = do
, (p3e, Nothing, Nothing)
, (p2e, Just f21, Just p1e) ]
it "works with a composite primary key" $
run $ do
it "works with a composite primary key" $ run $ do
let p = Point x y ""
x = 10
y = 15
@ -1293,13 +1255,9 @@ testSelectWhere run = do
ret `shouldBe` p
pPk `shouldBe` thePk
testSelectOrderBy :: Run -> Spec
testSelectOrderBy run = do
describe "select/orderBy" $ do
it "works with a single ASC field" $
run $ do
testSelectOrderBy run = describe "select/orderBy" $ do
it "works with a single ASC field" $ run $ do
p1e <- insert' p1
p2e <- insert' p2
p3e <- insert' p3
@ -1309,8 +1267,7 @@ testSelectOrderBy run = do
return p
liftIO $ ret `shouldBe` [ p1e, p3e, p2e ]
it "works with a sub_select" $
run $ do
it "works with a sub_select" $ run $ do
[p1k, p2k, p3k, p4k] <- mapM insert [p1, p2, p3, p4]
[b1k, b2k, b3k, b4k] <- mapM (insert . BlogPost "") [p1k, p2k, p3k, p4k]
ret <- select $
@ -1323,8 +1280,7 @@ testSelectOrderBy run = do
return (b ^. BlogPostId)
liftIO $ ret `shouldBe` (Value <$> [b2k, b3k, b4k, b1k])
it "works on a composite primary key" $
run $ do
it "works on a composite primary key" $ run $ do
let ps = [Point 2 1 "", Point 1 2 ""]
mapM_ insert ps
eps <- select $
@ -1334,10 +1290,8 @@ testSelectOrderBy run = do
liftIO $ map entityVal eps `shouldBe` reverse ps
testAscRandom :: SqlExpr (Value Double) -> Run -> Spec
testAscRandom rand' run =
describe "random_" $
it "asc random_ works" $
run $ do
testAscRandom rand' run = describe "random_" $
it "asc random_ works" $ run $ do
_p1e <- insert' p1
_p2e <- insert' p2
_p3e <- insert' p3
@ -1382,10 +1336,8 @@ testSelectDistinct run = do
testCoasleceDefault :: Run -> Spec
testCoasleceDefault run = do
describe "coalesce/coalesceDefault" $ do
it "works on a simple example" $
run $ do
testCoasleceDefault run = describe "coalesce/coalesceDefault" $ do
it "works on a simple example" $ run $ do
mapM_ insert' [p1, p2, p3, p4, p5]
ret1 <- select $
from $ \p -> do
@ -1409,8 +1361,7 @@ testCoasleceDefault run = do
, Value 5
]
it "works with sub-queries" $
run $ do
it "works with sub-queries" $ run $ do
p1id <- insert p1
p2id <- insert p2
p3id <- insert p3
@ -1432,12 +1383,9 @@ testCoasleceDefault run = do
]
testDelete :: Run -> Spec
testDelete run = do
describe "delete" $
it "works on a simple example" $
run $ do
testDelete run = describe "delete" $ do
it "works on a simple example" $ run $ do
p1e <- insert' p1
p2e <- insert' p2
p3e <- insert' p3
@ -1458,14 +1406,9 @@ testDelete run = do
ret3 <- getAll
liftIO $ (n, ret3) `shouldBe` (2, [])
testUpdate :: Run -> Spec
testUpdate run = do
describe "update" $ do
it "works with a subexpression having COUNT(*)" $
run $ do
testUpdate run = describe "update" $ do
it "works with a subexpression having COUNT(*)" $ run $ do
p1k <- insert p1
p2k <- insert p2
p3k <- insert p3
@ -1503,8 +1446,7 @@ testUpdate run = do
ret `shouldBe` Point newX newY []
-}
it "GROUP BY works with COUNT" $
run $ do
it "GROUP BY works with COUNT" $ run $ do
p1k <- insert p1
p2k <- insert p2
p3k <- insert p3
@ -1521,8 +1463,7 @@ testUpdate run = do
, (Entity p1k p1, Value 3)
, (Entity p3k p3, Value 7) ]
it "GROUP BY works with COUNT and InnerJoin" $
run $ do
it "GROUP BY works with COUNT and InnerJoin" $ run $ do
l1k <- insert l1
l3k <- insert l3
mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int])
@ -1537,8 +1478,7 @@ testUpdate run = do
liftIO $ ret `shouldMatchList` [ (Value l3k, Value 7)
, (Value l1k, Value 3) ]
it "GROUP BY works with nested tuples" $ do
run $ do
it "GROUP BY works with nested tuples" $ run $ do
l1k <- insert l1
l3k <- insert l3
mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int])
@ -1551,8 +1491,8 @@ testUpdate run = do
groupBy ((lord ^. LordId, lord ^. LordDogs), deed ^. DeedContract)
return (lord ^. LordId, count $ deed ^. DeedId)
liftIO $ length ret `shouldBe` 10
it "GROUP BY works with HAVING" $
run $ do
it "GROUP BY works with HAVING" $ run $ do
p1k <- insert p1
_p2k <- insert p2
p3k <- insert p3
@ -1569,7 +1509,6 @@ testUpdate run = do
liftIO $ ret `shouldBe` [ (Entity p1k p1, Value (3 :: Int))
, (Entity p3k p3, Value 7) ]
-- we only care that this compiles. check that SqlWriteT doesn't fail on
-- updates.
testSqlWriteT :: MonadIO m => SqlWriteT m ()
@ -1597,10 +1536,8 @@ testSqlReadT =
return (lord ^. LordId, count $ deed ^. DeedId)
testListOfValues :: Run -> Spec
testListOfValues run = do
describe "lists of values" $ do
it "IN works for valList" $
run $ do
testListOfValues run = describe "lists of values" $ do
it "IN works for valList" $ run $ do
p1k <- insert p1
p2k <- insert p2
_p3k <- insert p3
@ -1611,8 +1548,7 @@ testListOfValues run = do
liftIO $ ret `shouldBe` [ Entity p1k p1
, Entity p2k p2 ]
it "IN works for valList (null list)" $
run $ do
it "IN works for valList (null list)" $ run $ do
_p1k <- insert p1
_p2k <- insert p2
_p3k <- insert p3
@ -1622,8 +1558,7 @@ testListOfValues run = do
return p
liftIO $ ret `shouldBe` []
it "IN works for subList_select" $
run $ do
it "IN works for subList_select" $ run $ do
p1k <- insert p1
_p2k <- insert p2
p3k <- insert p3
@ -1639,8 +1574,7 @@ testListOfValues run = do
return p
liftIO $ L.sort ret `shouldBe` L.sort [Entity p1k p1, Entity p3k p3]
it "NOT IN works for subList_select" $
run $ do
it "NOT IN works for subList_select" $ run $ do
p1k <- insert p1
p2k <- insert p2
p3k <- insert p3
@ -1655,8 +1589,7 @@ testListOfValues run = do
return p
liftIO $ ret `shouldBe` [ Entity p2k p2 ]
it "EXISTS works for subList_select" $
run $ do
it "EXISTS works for subList_select" $ run $ do
p1k <- insert p1
_p2k <- insert p2
p3k <- insert p3
@ -1672,8 +1605,7 @@ testListOfValues run = do
liftIO $ ret `shouldBe` [ Entity p1k p1
, Entity p3k p3 ]
it "EXISTS works for subList_select" $
run $ do
it "EXISTS works for subList_select" $ run $ do
p1k <- insert p1
p2k <- insert p2
p3k <- insert p3
@ -1687,25 +1619,15 @@ testListOfValues run = do
return p
liftIO $ ret `shouldBe` [ Entity p2k p2 ]
testListFields :: Run -> Spec
testListFields run = do
describe "list fields" $ do
testListFields run = describe "list fields" $ do
-- <https://github.com/prowdsponsor/esqueleto/issues/100>
it "can update list fields" $
run $ do
it "can update list fields" $ run $ do
cclist <- insert $ CcList []
update $ \p -> do
set p [ CcListNames =. val ["fred"]]
where_ (p ^. CcListId ==. val cclist)
testInsertsBySelect :: Run -> Spec
testInsertsBySelect run = do
describe "inserts by select" $ do
@ -1943,18 +1865,18 @@ testRenderSql run = do
expr `shouldBe` "? = ?"
describe "EEntity Ident behavior" $ do
let
render :: SqlExpr (Entity val) -> Text.Text
let render :: SqlExpr (Entity val) -> Text.Text
render (EI.EEntity (EI.I ident)) = ident
it "renders sensibly" $ do
results <- run $ do
render _ = error "guess we gotta handle this in the test suite now"
it "renders sensibly" $ run $ do
_ <- insert $ Foo 2
_ <- insert $ Foo 3
_ <- insert $ Person "hello" Nothing Nothing 3
select $
results <- select $
from $ \(a `LeftOuterJoin` b) -> do
on $ a ^. FooName ==. b ^. PersonFavNum
pure (val (render a), val (render b))
liftIO $
head results
`shouldBe`
(Value "Foo", Value "Person")