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

Destroy all GADTs; Removes the From GADT and SqlExpr GADT (#228)

Browse Source 
* Explode the From GADT. Move runFrom into the ToFrom typeclass removing the need for the intermediate structure. Extract the parts of the Experimental module into submodules.

* Reorganize Experimental folder. Move Subquery into core Experimental.From module.

* Cleanup hackage documentation. Make sure stylish ran correctly. Update changelog and bump version

* Update ERaw to change the direction of NeedParens (parent now tells child context). Removed need for composite key constructor

* Get rid of AliasedValue and ValueReference; added sqlExprMetaAlias to SqlExprMeta

* Remove EList and EEmptyList; ERaw is now technically possible in each case since it is generalized to all

* Remove entity specific constructors from SqlExpr

* Remove EOrderBy, EDistinctOn; Change PreprocessedFrom a to just be an independent datatype

* Remove EOrderByRandom, calling distinctOnOrderBy with rand will choke the db but you shouldnt be using rand anyway. distinctOnOrderBy seems dangerous though

* Remove ESet

* Remove EInsert and EInsertFinal

* Make postgres tests pass

* Change aliased val to be legal value by waiting until expr materialization in select clause before adding AS <alias>

* Cleanup ToAliasRefernce; Add isReference meta to value reference even though that info isnt currently used anywhere

* Expose Experimental submodules

* Update changelog

* Create a FromRaw to replace FromSubquery and FromIdent in from clause. Modify Experimental to only use FromRaw.

* Convert all of experimental to use new From type instead of From type class. Make the data constructors second class, functions should be used. Introduce *Lateral functions, using the same type for lateral and non lateral queries was probably a mistake.

* Expose the new functions and fix the mysql test compilation error (type inference was wonky with `Union` replaced with `union_`

* Bump version and add more comments

* ValidOnClause was too restrictive, ToFrom is actually the correct amount of leniency. ValidOnClause would not catch use of on for a cross join but would prevent nested joins

* Unbreak lateral joins by introducing a completely different ValidOnClause constraint

* Fixe error introduced in merge with master

* Dont realias alias references

* Never realias an already aliased Entity or Value

* reindex value references to the latest 'source'
This commit is contained in:
Ben Levy 2021-05-26 13:12:11 -05:00 committed by GitHub
parent e39c62990e
commit ea4ff33b93
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
18 changed files with 1514 additions and 1497 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
changelog.md
View File

@ -1,3 +1,14 @@
3.5.0.0
=======
- @belevy
- [#228](https://github.com/bitemyapp/esqueleto/pull/228)
- Destroy all GADTs; Removes the From GADT and SqlExpr GADT
- From GADT is replaced with a From data type and FromRaw
- SqlExpr is now all defined in terms of ERaw
- Modified ERaw to contain a SqlExprMeta with any extra information
that may be needed
- Experimental top level is now strictly for documentation and all the
implementation details are in Experimental.* modules
3.4.2.2
=======
- @parsonsmatt
@ -31,6 +42,7 @@
- [#232](https://github.com/bitemyapp/esqueleto/pull/232)
- Export the `ValidOnClauseValue` type family
3.4.0.1
=======
- @arthurxavierx

11
esqueleto.cabal
View File

@ -1,7 +1,7 @@
cabal-version: 1.12
name: esqueleto
version: 3.4.2.2
version: 3.5.0.0
synopsis: Type-safe EDSL for SQL queries on persistent backends.
description: @esqueleto@ is a bare bones, type-safe EDSL for SQL queries that works with unmodified @persistent@ SQL backends. Its language closely resembles SQL, so you don't have to learn new concepts, just new syntax, and it's fairly easy to predict the generated SQL and optimize it for your backend. Most kinds of errors committed when writing SQL are caught as compile-time errors---although it is possible to write type-checked @esqueleto@ queries that fail at runtime.
.
@ -38,9 +38,16 @@ library
Database.Esqueleto.PostgreSQL
Database.Esqueleto.PostgreSQL.JSON
Database.Esqueleto.SQLite
Database.Esqueleto.Experimental.From
Database.Esqueleto.Experimental.From.CommonTableExpression
Database.Esqueleto.Experimental.From.Join
Database.Esqueleto.Experimental.From.SqlSetOperation
Database.Esqueleto.Experimental.ToAlias
Database.Esqueleto.Experimental.ToAliasReference
Database.Esqueleto.Experimental.ToMaybe
other-modules:
Database.Esqueleto.Internal.PersistentImport
Database.Esqueleto.PostgreSQL.JSON.Instances
Database.Esqueleto.Internal.PersistentImport
Paths_esqueleto
hs-source-dirs:
src/

7
src/Database/Esqueleto.hs
View File

@ -1,4 +1,7 @@
{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs, RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
-- | The @esqueleto@ EDSL (embedded domain specific language).
-- This module replaces @Database.Persist@, so instead of
-- importing that module you should just import this one:
@ -125,8 +128,8 @@ import Control.Monad.Trans.Reader (ReaderT)
import Data.Int (Int64)
import qualified Data.Map.Strict as Map
import Database.Esqueleto.Internal.Language
import Database.Esqueleto.Internal.Sql
import Database.Esqueleto.Internal.PersistentImport
import Database.Esqueleto.Internal.Sql
import qualified Database.Persist

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

File diff suppressed because it is too large Load Diff

147
src/Database/Esqueleto/Experimental/From.hs Normal file
View File

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

111
src/Database/Esqueleto/Experimental/From/CommonTableExpression.hs Normal file
View File

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

407
src/Database/Esqueleto/Experimental/From/Join.hs Normal file
View File

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

131
src/Database/Esqueleto/Experimental/From/SqlSetOperation.hs Normal file
View File

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

92
src/Database/Esqueleto/Experimental/ToAlias.hs Normal file
View File

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

90
src/Database/Esqueleto/Experimental/ToAliasReference.hs Normal file
View File

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

79
src/Database/Esqueleto/Experimental/ToMaybe.hs Normal file
View File

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

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

File diff suppressed because it is too large Load Diff

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

@ -37,8 +37,8 @@ module Database.Esqueleto.Internal.Sql
-- * The guts
, unsafeSqlCase
, unsafeSqlBinOp
, unsafeSqlBinOpComposite
, unsafeSqlValue
, unsafeSqlEntity
, unsafeSqlCastAs
, unsafeSqlFunction
, unsafeSqlExtractSubField

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

@ -85,18 +85,18 @@ unsafeSqlAggregateFunction
-> a
-> [OrderByClause]
-> SqlExpr (Value b)
unsafeSqlAggregateFunction name mode args orderByClauses = ERaw Never $ \info ->
unsafeSqlAggregateFunction name mode args orderByClauses = ERaw noMeta $ \_ info ->
let (orderTLB, orderVals) = makeOrderByNoNewline info orderByClauses
-- Don't add a space if we don't have order by clauses
orderTLBSpace =
case orderByClauses of
[] -> ""
[] -> ""
(_:_) -> " "
(argsTLB, argsVals) =
uncommas' $ map (\v -> valueToRawSqlParens SqlFunctionError v info) $ toArgList args
uncommas' $ map (\(ERaw _ f) -> f Never info) $ toArgList args
aggMode =
case mode of
AggModeAll -> ""
AggModeAll -> ""
-- ALL is the default, so we don't need to
-- specify it
AggModeDistinct -> "DISTINCT "
@ -184,7 +184,7 @@ upsert
)
=> record
-- ^ new record to insert
-> [SqlExpr (Update record)]
-> [SqlExpr (Entity record) -> SqlExpr Update]
-- ^ updates to perform if the record already exists
-> R.ReaderT SqlBackend m (Entity record)
-- ^ the record in the database after the operation
@ -202,7 +202,7 @@ upsertBy
-- ^ uniqueness constraint to find by
-> record
-- ^ new record to insert
-> [SqlExpr (Update record)]
-> [SqlExpr (Entity record) -> SqlExpr Update]
-- ^ updates to perform if the record already exists
-> R.ReaderT SqlBackend m (Entity record)
-- ^ the record in the database after the operation
@ -278,7 +278,7 @@ insertSelectWithConflict
-- 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)])
-> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Entity val) -> SqlExpr Update])
-- ^ A list of updates to be applied in case of the constraint being
-- violated. The expression takes the current and excluded value to produce
-- the updates.
@ -294,22 +294,22 @@ insertSelectWithConflictCount
. (FinalResult a, KnowResult a ~ Unique val, MonadIO m, PersistEntity val)
=> a
-> SqlQuery (SqlExpr (Insertion val))
-> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Update val)])
-> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Entity val) -> SqlExpr Update])
-> SqlWriteT m Int64
insertSelectWithConflictCount unique query conflictQuery = do
conn <- R.ask
uncurry rawExecuteCount $
combine
(toRawSql INSERT_INTO (conn, initialIdentState) (fmap EInsertFinal query))
(toRawSql INSERT_INTO (conn, initialIdentState) query)
(conflict conn)
where
proxy :: Proxy val
proxy = Proxy
updates = conflictQuery entCurrent entExcluded
combine (tlb1,vals1) (tlb2,vals2) = (builderToText (tlb1 `mappend` tlb2), vals1 ++ vals2)
entExcluded = EEntity $ I "excluded"
entExcluded = unsafeSqlEntity (I "excluded")
tableName = unEntityNameDB . getEntityDBName . entityDef
entCurrent = EEntity $ I (tableName proxy)
entCurrent = unsafeSqlEntity (I (tableName proxy))
uniqueDef = toUniqueDef unique
constraint = TLB.fromText . unConstraintNameDB . uniqueDBName $ uniqueDef
renderedUpdates :: (BackendCompatible SqlBackend backend) => backend -> (TLB.Builder, [PersistValue])
@ -357,13 +357,11 @@ filterWhere
-> SqlExpr (Value Bool)
-- ^ Filter clause
-> SqlExpr (Value a)
filterWhere aggExpr clauseExpr = ERaw Never $ \info ->
filterWhere aggExpr clauseExpr = ERaw noMeta $ \_ info ->
let (aggBuilder, aggValues) = case aggExpr of
ERaw _ aggF -> aggF info
ECompositeKey _ -> throw $ CompositeKeyErr FilterWhereAggError
ERaw _ aggF -> aggF Never info
(clauseBuilder, clauseValues) = case clauseExpr of
ERaw _ clauseF -> clauseF info
ECompositeKey _ -> throw $ CompositeKeyErr FilterWhereClauseError
ERaw _ clauseF -> clauseF Never info
in ( aggBuilder <> " FILTER (WHERE " <> clauseBuilder <> ")"
, aggValues <> clauseValues
)

1
stack-8.10.yaml
View File

@ -6,7 +6,6 @@ packages:
extra-deps:
- lift-type-0.1.0.1
- attoparsec-0.14.1
- persistent-2.13.0.0
- persistent-sqlite-2.13.0.0
- persistent-mysql-2.13.0.0

62
test/Common/Test.hs
View File

@ -1,6 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE EmptyDataDecls #-}
@ -387,7 +387,7 @@ testSubSelect run = do
v `shouldBe` [Value 1]
describe "subSelectList" $ do
it "is safe on empty databases as well as good databases" $ do
it "is safe on empty databases as well as good databases" $ run $ do
let query =
from $ \n -> do
where_ $ n ^. NumbersInt `in_` do
@ -396,16 +396,15 @@ testSubSelect run = do
where_ $ n' ^. NumbersInt >=. val 3
pure (n' ^. NumbersInt)
pure n
empty <- select query
empty <- run $ do
select query
full <- run $ do
full <- do
setup
select query
empty `shouldBe` []
full `shouldSatisfy` (not . null)
liftIO $ do
empty `shouldBe` []
full `shouldSatisfy` (not . null)
describe "subSelectMaybe" $ do
it "is equivalent to joinV . subSelect" $ do
@ -890,12 +889,14 @@ testSelectSubQuery run = describe "select subquery" $ do
l1Deeds <- mapM (\k -> insert' $ Deed k (entityKey l1e)) (map show [1..3 :: Int])
let l1WithDeeds = do d <- l1Deeds
pure (l1e, Just d)
ret <- select $ Experimental.from $ do
(lords :& deeds) <-
Experimental.from $ Table @Lord
`LeftOuterJoin` Table @Deed
`Experimental.on` (\(l :& d) -> just (l ^. LordId) ==. d ?. DeedOwnerId)
pure (lords, deeds)
let q = Experimental.from $ do
(lords :& deeds) <-
Experimental.from $ Table @Lord
`LeftOuterJoin` Table @Deed
`Experimental.on` (\(l :& d) -> just (l ^. LordId) ==. d ?. DeedOwnerId)
pure (lords, deeds)
ret <- select q
liftIO $ ret `shouldMatchList` ((l3e, Nothing) : l1WithDeeds)
it "lets you order by alias" $ run $ do
@ -1080,17 +1081,6 @@ testSelectWhere run = describe "select where_" $ do
( val $ PointKey 1 2
, val $ PointKey 5 6 )
liftIO $ ret `shouldBe` [()]
it "works when using ECompositeKey constructor" $ run $ do
insert_ $ Point 1 2 ""
ret <-
select $
from $ \p -> do
where_ $
p ^. PointId
`between`
( EI.ECompositeKey $ const ["3", "4"]
, EI.ECompositeKey $ const ["5", "6"] )
liftIO $ ret `shouldBe` []
it "works with avg_" $ run $ do
_ <- insert' p1
@ -1868,9 +1858,10 @@ testRenderSql run = do
(c, expr) <- run $ do
conn <- ask
let Right c = P.mkEscapeChar conn
let user = EI.unsafeSqlEntity (EI.I "user")
blogPost = EI.unsafeSqlEntity (EI.I "blog_post")
pure $ (,) c $ EI.renderExpr conn $
EI.EEntity (EI.I "user") ^. PersonId
==. EI.EEntity (EI.I "blog_post") ^. BlogPostAuthorId
user ^. PersonId ==. blogPost ^. BlogPostAuthorId
expr
`shouldBe`
Text.intercalate (Text.singleton c) ["", "user", ".", "id", ""]
@ -1882,23 +1873,6 @@ testRenderSql run = do
expr <- run $ ask >>= \c -> pure $ EI.renderExpr c (val (PersonKey 0) ==. val (PersonKey 1))
expr `shouldBe` "? = ?"
describe "EEntity Ident behavior" $ do
let render :: SqlExpr (Entity val) -> Text.Text
render (EI.EEntity (EI.I ident)) = ident
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
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")
describe "ExprParser" $ do
let parse parser = AP.parseOnly (parser '#')
describe "parseEscapedChars" $ do

3
test/MySQL/Test.hs
View File

@ -24,6 +24,7 @@ import Database.Persist.MySQL
, defaultConnectInfo
, withMySQLConn
)
import System.Environment
import Test.Hspec
@ -190,7 +191,7 @@ testMysqlUnionWithLimits = do
pure $ foo ^. FooName
ret <- select $ Experimental.from $ SelectQuery q1 `Union` SelectQuery q2
ret <- select $ Experimental.from $ q1 `union_` q2
liftIO $ ret `shouldMatchList` [Value 1, Value 2, Value 4, Value 5]

21
test/SQLite/Test.hs
View File

@ -1,21 +1,20 @@
{-# LANGUAGE ScopedTypeVariables
, FlexibleContexts
, RankNTypes
, TypeFamilies
, OverloadedStrings
#-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Main (main) where
import Control.Monad (void)
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Logger (runStderrLoggingT, runNoLoggingT)
import Control.Monad.Logger (runNoLoggingT, runStderrLoggingT)
import Control.Monad.Trans.Reader (ReaderT)
import Database.Persist.Sqlite (withSqliteConn)
import Database.Sqlite (SqliteException)
import qualified Control.Monad.Trans.Resource as R
import Database.Esqueleto hiding (random_)
import Database.Esqueleto.SQLite (random_)
import qualified Control.Monad.Trans.Resource as R
import Database.Persist.Sqlite (withSqliteConn)
import Database.Sqlite (SqliteException)
import Test.Hspec
import Common.Test
@ -169,7 +168,7 @@ main = do
describe "Test SQLite locking" $ do
testLocking withConn
fdescribe "SQLite specific tests" $ do
describe "SQLite specific tests" $ do
testAscRandom random_ run
testRandomMath run
testSqliteRandom