New syntax for Joins (Subquery + Union/Intersect/...) (#172)
* It works? * Add multiple return values back in * Allow order by alias * Support groupBy and count, Returning value from a fromQuery now will make it into an alias * Eliminate Alias type, TODO: finish implementing all the functions on Value for the alias constructors * Add entity support to subqueries * Cleanup duplication; Cleanup warnings and finish implementing all the cases for aliased values and entities. * Cleanup fromQuery and add comments * Modify EValueReference to support aliased entity fields instead of having to use opaque ERaw in field access * Implement SQL Set Operations * Add test to show novel use of fromQuery * Cleanup unsafe case statements * Add type annotations to helper queries to satisfy the typechecker on older GHC * New syntax for joins, using placeholder names with ' in them to avoid name conflict with existing join types. New api properly enforces Maybe on outer joins and requires an on clause for all joins in their construction. * Add some more test queries using the new syntax * Add test to verify that delete works with the new syntax * Add cross join and implicit cross join using comma examples to test code for new from syntax * Comment out use of CrossJoin in common tests since postgres cant handle it with the current implementation of the CrossJoin kind * Add typeclass machinery to support the use of the old Join data types used in the existing from clause * Fix bug with CrossJoin and add on_ syntax sugar * move new from syntax into Database.Esqueleto.Experimental * Merge subqueries and unions with the new join syntax, they all seem to play nicely together * Cleanup somehow copies of ToAlias ended up staying in Internal and a swp file made it in to the branch. * Fix compilation errors * Swith tuple to using a TypeOperator * Make operator only 2 characters * added up to 8-tuple instances for ToMaybe, ToAlias, and ToAliasReference * Add compiler error tests for new syntax to support making better errors * Use closed data families to allow for catching missing on statements in joins. * Convert ToAliasReferenceT to be a closed type family matching the other classes in the Experimental module * added Esqueleto.Experimental documentation: added introduction and several examples of old vs. new syntax * added more usage examples to module introduction; added documentation to SqlSetOperation, From, on, from, and (:&) * Update (^.) to only treat natural keys with more than one component as ECompositeKey. Fixes #176. * Update article metadata test to ensure the correct response was being returned instead of just check if an exception was thrown * Add article metadata to cleanDB before deleting all articles to fix foreign key constraint errors * Bump version number and add changelog entry * Fix issue with ToMaybeT for Values, Maybe was going in the wrong place compared to the rest of the library. Add test to prove that Left joining into a subquery that returns a maybe flattens the maybe properly to avoid needing to call joinV. * Fix common test for postgres, needed to add dogCounts to the group by since postgres is strict on only agregates for non grouped columns; I really need to set up a local postgresql * Revert ToFromT changes. Only accept functions that return a SqlExpr (Value Bool) in ToFromT * escaped use of '@' in TypeApplications in documentation * Add more specific type signature to `on` per parsonsmatt review suggestion. Improves type inference significantly. Co-Authored-By: Matt Parsons <parsonsmatt@gmail.com> Co-authored-by: charukiewicz <c.charukiewicz@gmail.com> Co-authored-by: Matt Parsons <parsonsmatt@gmail.com>
This commit is contained in:
Ben Levy
GitHub
parent
9a762e9f20
commit
56e4b83e5c
@ -29,6 +29,7 @@ source-repository head
|
||||
library
|
||||
exposed-modules:
|
||||
Database.Esqueleto
|
||||
Database.Esqueleto.Experimental
|
||||
Database.Esqueleto.Internal.Language
|
||||
Database.Esqueleto.Internal.Sql
|
||||
Database.Esqueleto.Internal.Internal
|
||||
|
||||
@ -77,8 +77,8 @@ module Database.Esqueleto
|
||||
, LeftOuterJoin(..)
|
||||
, RightOuterJoin(..)
|
||||
, FullOuterJoin(..)
|
||||
, JoinKind(..)
|
||||
, OnClauseWithoutMatchingJoinException(..)
|
||||
|
||||
-- * SQL backend
|
||||
, SqlQuery
|
||||
, SqlExpr
|
||||
|
||||
845
src/Database/Esqueleto/Experimental.hs
Normal file
845
src/Database/Esqueleto/Experimental.hs
Normal file
@ -0,0 +1,845 @@
|
||||
{-# LANGUAGE CPP
|
||||
, DataKinds
|
||||
, FlexibleContexts
|
||||
, FlexibleInstances
|
||||
, FunctionalDependencies
|
||||
, GADTs
|
||||
, MultiParamTypeClasses
|
||||
, TypeOperators
|
||||
, TypeFamilies
|
||||
, UndecidableInstances
|
||||
, OverloadedStrings
|
||||
#-}
|
||||
|
||||
module Database.Esqueleto.Experimental
|
||||
( -- * Setup
|
||||
-- $setup
|
||||
|
||||
-- * Introduction
|
||||
-- $introduction
|
||||
|
||||
-- * A New Syntax
|
||||
-- $new-syntax
|
||||
|
||||
-- * Documentation
|
||||
|
||||
SqlSetOperation(..)
|
||||
, From(..)
|
||||
, on
|
||||
, from
|
||||
, (:&)(..)
|
||||
-- * Internals
|
||||
, ToFrom(..)
|
||||
, ToFromT
|
||||
, ToMaybe(..)
|
||||
, ToMaybeT
|
||||
, ToAlias(..)
|
||||
, ToAliasT
|
||||
, ToAliasReference(..)
|
||||
, ToAliasReferenceT
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Control.Monad.Trans.Writer as W
|
||||
import qualified Control.Monad.Trans.State as S
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
#if __GLASGOW_HASKELL__ < 804
|
||||
import Data.Semigroup
|
||||
#endif
|
||||
import Data.Proxy (Proxy(..))
|
||||
import Database.Esqueleto.Internal.PersistentImport
|
||||
import Database.Esqueleto.Internal.Internal
|
||||
( SqlExpr(..)
|
||||
, InnerJoin(..)
|
||||
, CrossJoin(..)
|
||||
, LeftOuterJoin(..)
|
||||
, RightOuterJoin(..)
|
||||
, FullOuterJoin(..)
|
||||
, FromClause(..)
|
||||
, SqlQuery(..)
|
||||
, SideData(..)
|
||||
, Value(..)
|
||||
, JoinKind(..)
|
||||
, newIdentFor
|
||||
, SqlSelect(..)
|
||||
, Mode(..)
|
||||
, toRawSql
|
||||
, Ident(..)
|
||||
, to3, to4, to5, to6, to7, to8
|
||||
, from3, from4, from5, from6, from7, from8
|
||||
, veryUnsafeCoerceSqlExprValue
|
||||
)
|
||||
import GHC.TypeLits
|
||||
|
||||
-- $setup
|
||||
--
|
||||
-- If you're already using "Database.Esqueleto", then you can get
|
||||
-- started using this module just by changing your imports slightly,
|
||||
-- as well as enabling the [TypeApplications](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#extension-TypeApplications) extension.
|
||||
--
|
||||
-- @
|
||||
-- {-\# LANGUAGE TypeApplications \#-}
|
||||
--
|
||||
-- ...
|
||||
--
|
||||
-- import Database.Esqueleto hiding (on, from)
|
||||
-- import Database.Esqueleto.Experimental
|
||||
-- @
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
-- $introduction
|
||||
--
|
||||
-- This module is fully backwards-compatible extension to the @esqueleto@
|
||||
-- EDSL that expands subquery functionality and enables
|
||||
-- [SQL set operations](https://en.wikipedia.org/wiki/Set_operations_(SQL\))
|
||||
-- to be written directly in Haskell. Specifically, this enables:
|
||||
--
|
||||
-- * Subqueries in 'JOIN' statements
|
||||
-- * 'UNION'
|
||||
-- * 'UNION' 'ALL'
|
||||
-- * 'INTERSECT'
|
||||
-- * 'EXCEPT'
|
||||
--
|
||||
-- As a consequence of this, several classes of runtime errors are now
|
||||
-- caught at compile time. This includes missing 'on' clauses and improper
|
||||
-- handling of @Maybe@ values in outer joins.
|
||||
--
|
||||
-- This module can be used in conjunction with the main "Database.Esqueleto"
|
||||
-- module, but doing so requires qualified imports to avoid ambiguous
|
||||
-- definitions of 'on' and 'from', which are defined in both modules.
|
||||
--
|
||||
-- Below we will give an overview of how to use this module and the
|
||||
-- features it enables.
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
-- $new-syntax
|
||||
--
|
||||
-- This module introduces a new syntax that serves to enable the aforementioned
|
||||
-- features. This new syntax also changes how joins written in the @esqueleto@
|
||||
-- EDSL to more closely resemble the underlying SQL.
|
||||
--
|
||||
-- For our examples, we'll use a schema similar to the one in the Getting Started
|
||||
-- section of "Database.Esqueleto":
|
||||
--
|
||||
-- @
|
||||
-- share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persist|
|
||||
-- Person
|
||||
-- name String
|
||||
-- age Int Maybe
|
||||
-- deriving Eq Show
|
||||
-- BlogPost
|
||||
-- title String
|
||||
-- authorId PersonId
|
||||
-- deriving Eq Show
|
||||
-- Follow
|
||||
-- follower PersonId
|
||||
-- followed PersonId
|
||||
-- deriving Eq Show
|
||||
-- |]
|
||||
-- @
|
||||
--
|
||||
-- === Example 1: Simple select
|
||||
--
|
||||
-- Let's select all people who are named \"John\".
|
||||
--
|
||||
-- ==== "Database.Esqueleto":
|
||||
--
|
||||
-- @
|
||||
-- select $
|
||||
-- from $ \\people -> do
|
||||
-- where_ (people ^. PersonName ==. val \"John\")
|
||||
-- pure people
|
||||
-- @
|
||||
--
|
||||
-- ==== "Database.Esqueleto.Experimental":
|
||||
--
|
||||
-- @
|
||||
-- select $ do
|
||||
-- people <- from $ Table \@Person
|
||||
-- where_ (people ^. PersonName ==. val \"John\")
|
||||
-- pure people
|
||||
-- @
|
||||
--
|
||||
--
|
||||
-- === Example 2: Select with join
|
||||
--
|
||||
-- Let's select all people and their blog posts who are over
|
||||
-- the age of 18.
|
||||
--
|
||||
-- ==== "Database.Esqueleto":
|
||||
--
|
||||
-- @
|
||||
-- select $
|
||||
-- from $ \\(people \`LeftOuterJoin\` blogPosts) -> do
|
||||
-- on (people ^. PersonId ==. blogPosts ?. BlogPostAuthorId)
|
||||
-- where_ (people ^. PersonAge >. val 18)
|
||||
-- pure (people, blogPosts)
|
||||
-- @
|
||||
--
|
||||
-- ==== "Database.Esqueleto.Experimental":
|
||||
--
|
||||
-- Here we use the ':&' operator to pattern match against the joined tables.
|
||||
--
|
||||
-- @
|
||||
-- select $ do
|
||||
-- (people :& blogPosts) <-
|
||||
-- from $ Table \@Person
|
||||
-- \`LeftOuterJoin\` Table \@BlogPost
|
||||
-- \`on\` (\\(people :& blogPosts) ->
|
||||
-- people ^. PersonId ==. blogPosts ?. BlogPostAuthorId)
|
||||
-- where_ (people ^. PersonAge >. val 18)
|
||||
-- pure (people, blogPosts)
|
||||
-- @
|
||||
--
|
||||
-- === Example 3: Select with multi-table join
|
||||
--
|
||||
-- Let's select all people who follow a person named \"John\", including
|
||||
-- the name of each follower.
|
||||
--
|
||||
-- ==== "Database.Esqueleto":
|
||||
--
|
||||
-- @
|
||||
-- select $
|
||||
-- from $ \\(
|
||||
-- people1
|
||||
-- \`InnerJoin\` followers
|
||||
-- \`InnerJoin\` people2
|
||||
-- ) -> do
|
||||
-- on (people1 ^. PersonId ==. followers ^. FollowFollowed)
|
||||
-- on (followers ^. FollowFollower ==. people2 ^. PersonId)
|
||||
-- where_ (people1 ^. PersonName ==. val \"John\")
|
||||
-- pure (followers, people2)
|
||||
-- @
|
||||
--
|
||||
-- ==== "Database.Esqueleto.Experimental":
|
||||
--
|
||||
-- In this version, with each successive 'on' clause, only the tables
|
||||
-- we have already joined into are in scope, so we must pattern match
|
||||
-- accordingly. In this case, in the second 'InnerJoin', we do not use
|
||||
-- the first `Person` reference, so we use @_@ as a placeholder to
|
||||
-- ignore it. This prevents a possible runtime error where a table
|
||||
-- is referenced before it appears in the sequence of 'JOIN's.
|
||||
--
|
||||
-- @
|
||||
-- select $ do
|
||||
-- (people1 :& followers :& people2) <-
|
||||
-- from $ Table \@Person
|
||||
-- \`InnerJoin` Table \@Follow
|
||||
-- \`on\` (\\(people1 :& followers) ->
|
||||
-- people1 ^. PersonId ==. followers ^. FollowFollowed)
|
||||
-- \`InnerJoin` Table \@Person
|
||||
-- \`on\` (\\(_ :& followers :& people2) ->
|
||||
-- followers ^. FollowFollower ==. people2 ^. PersonId)
|
||||
-- where_ (people1 ^. PersonName ==. val \"John\")
|
||||
-- pure (followers, people2)
|
||||
-- @
|
||||
--
|
||||
-- === Example 4: Counting results of a subquery
|
||||
--
|
||||
-- Let's count the number of people who have posted at least 10 posts
|
||||
--
|
||||
-- ==== "Database.Esqueleto":
|
||||
--
|
||||
-- @
|
||||
-- select $ pure $ subSelectCount $
|
||||
-- from $ \\(
|
||||
-- people
|
||||
-- \`InnerJoin\` blogPosts
|
||||
-- ) -> do
|
||||
-- on (people ^. PersonId ==. blogPosts ^. BlogPostAuthorId)
|
||||
-- groupBy (people ^. PersonId)
|
||||
-- having ((count $ blogPosts ^. BlogPostId) >. val 10)
|
||||
-- pure people
|
||||
-- @
|
||||
--
|
||||
-- ==== "Database.Esqueleto.Experimental":
|
||||
--
|
||||
-- @
|
||||
-- select $ do
|
||||
-- peopleWithPosts <-
|
||||
-- from $ SelectQuery $ do
|
||||
-- (people :& blogPosts) <-
|
||||
-- from $ Table \@Person
|
||||
-- \`InnerJoin\` Table \@BlogPost
|
||||
-- \`on\` (\\(p :& bP) ->
|
||||
-- p ^. PersonId ==. bP ^. BlogPostAuthorId)
|
||||
-- groupBy (people ^. PersonId)
|
||||
-- having ((count $ blogPosts ^. BlogPostId) >. val 10)
|
||||
-- pure people
|
||||
-- pure $ count (peopleWithPosts ^. PersonId)
|
||||
-- @
|
||||
--
|
||||
-- We now have the ability to refactor this
|
||||
--
|
||||
-- === Example 5: Sorting the results of a UNION with limits
|
||||
--
|
||||
-- Out of all of the posts created by a person and the people they follow,
|
||||
-- generate a list of the first 25 posts, sorted alphabetically.
|
||||
--
|
||||
-- ==== "Database.Esqueleto":
|
||||
--
|
||||
-- Since 'UNION' is not supported, this requires using `Database.Esqueleto.rawSql`. (Not shown)
|
||||
--
|
||||
-- ==== "Database.Esqueleto.Experimental":
|
||||
--
|
||||
-- Since this module supports all set operations (see `SqlSetOperation`), we can use
|
||||
-- `Union` to write this query.
|
||||
--
|
||||
-- @
|
||||
-- select $ do
|
||||
-- (authors, blogPosts) <- from $
|
||||
-- (SelectQuery $ do
|
||||
-- (author :& blogPost) <-
|
||||
-- from $ Table \@Person
|
||||
-- \`InnerJoin\` Table \@BlogPost
|
||||
-- \`on\` (\\(a :& bP) ->
|
||||
-- a ^. PersonId ==. bP ^. BlogPostAuthorId)
|
||||
-- where_ (author ^. PersonId ==. val currentPersonId)
|
||||
-- pure (author, blogPost)
|
||||
-- )
|
||||
-- \`Union\`
|
||||
-- (SelectQuery $ do
|
||||
-- (follow :& blogPost :& author) <-
|
||||
-- from $ Table \@Follow
|
||||
-- \`InnerJoin\` Table \@BlogPost
|
||||
-- \`on\` (\\(f :& bP) ->
|
||||
-- f ^. FollowFollowed ==. bP ^. BlogPostAuthorId)
|
||||
-- \`InnerJoin\` Table \@Person
|
||||
-- \`on\` (\\(_ :& bP :& a) ->
|
||||
-- bP ^. BlogPostAuthorId ==. a ^. PersonId)
|
||||
-- where_ (follow ^. FollowFollower ==. val currentPersonId)
|
||||
-- pure (author, blogPost)
|
||||
-- )
|
||||
-- orderBy [ asc (blogPosts ^. BlogPostTitle) ]
|
||||
-- limit 25
|
||||
-- pure (authors, blogPosts)
|
||||
-- @
|
||||
|
||||
-- | 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 :&
|
||||
|
||||
-- | Data type that represents SQL set operations. This includes
|
||||
-- 'UNION', 'UNION' 'ALL', 'EXCEPT', and 'INTERSECT'. This data
|
||||
-- type is defined as a binary tree, with @SelectQuery@ on the leaves.
|
||||
--
|
||||
-- Each constructor corresponding to the aforementioned set operations
|
||||
-- can be used as an infix function in a @from@ to help with readability
|
||||
-- and lead to code that closely resembles the underlying SQL. For example,
|
||||
--
|
||||
-- @
|
||||
-- select $ from $
|
||||
-- (SelectQuery ...)
|
||||
-- \`Union\`
|
||||
-- (SelectQuery ...)
|
||||
-- @
|
||||
--
|
||||
-- is translated into
|
||||
--
|
||||
-- @
|
||||
-- SELECT * FROM (
|
||||
-- (SELECT * FROM ...)
|
||||
-- UNION
|
||||
-- (SELECT * FROM ...)
|
||||
-- )
|
||||
-- @
|
||||
--
|
||||
-- @SelectQuery@ can be used without any of the set operations to construct
|
||||
-- a subquery. This can be used in 'JOIN' trees. For example,
|
||||
--
|
||||
-- @
|
||||
-- select $ from $
|
||||
-- Table \@SomeTable
|
||||
-- \`InnerJoin\` (SelectQuery ...)
|
||||
-- \`on\` ...
|
||||
-- @
|
||||
--
|
||||
-- is translated into
|
||||
--
|
||||
-- @
|
||||
-- SELECT *
|
||||
-- FROM SomeTable
|
||||
-- INNER JOIN (SELECT * FROM ...)
|
||||
-- ON ...
|
||||
-- @
|
||||
data SqlSetOperation a =
|
||||
Union (SqlSetOperation a) (SqlSetOperation a)
|
||||
| UnionAll (SqlSetOperation a) (SqlSetOperation a)
|
||||
| Except (SqlSetOperation a) (SqlSetOperation a)
|
||||
| Intersect (SqlSetOperation a) (SqlSetOperation a)
|
||||
| SelectQuery (SqlQuery a)
|
||||
|
||||
-- | Data type that represents the syntax of a 'JOIN' tree. In practice,
|
||||
-- only the @Table@ constructor is used directly when writing queries. For example,
|
||||
--
|
||||
-- @
|
||||
-- select $ from $ Table \@People
|
||||
-- @
|
||||
data From a where
|
||||
Table :: PersistEntity ent => From (SqlExpr (Entity ent))
|
||||
SubQuery :: (SqlSelect a' r, SqlSelect a'' r', ToAlias a, a' ~ ToAliasT a, ToAliasReference a', ToAliasReferenceT a' ~ a'')
|
||||
=> SqlQuery a
|
||||
-> From a''
|
||||
SqlSetOperation :: (SqlSelect a' r, ToAlias a, a' ~ ToAliasT a, ToAliasReference a', ToAliasReferenceT a' ~ a'')
|
||||
=> SqlSetOperation a
|
||||
-> From a''
|
||||
InnerJoinFrom :: From a
|
||||
-> (From b, (a :& b) -> SqlExpr (Value Bool))
|
||||
-> From (a :& b)
|
||||
CrossJoinFrom :: From a
|
||||
-> From b
|
||||
-> From (a :& b)
|
||||
LeftJoinFrom :: ToMaybe b
|
||||
=> From a
|
||||
-> (From b, (a :& ToMaybeT b) -> SqlExpr (Value Bool))
|
||||
-> From (a :& ToMaybeT b)
|
||||
RightJoinFrom :: ToMaybe a
|
||||
=> From a
|
||||
-> (From b, (ToMaybeT a :& b) -> SqlExpr (Value Bool))
|
||||
-> From (ToMaybeT a :& b)
|
||||
FullJoinFrom :: (ToMaybe a, ToMaybe b )
|
||||
=> From a
|
||||
-> (From b, (ToMaybeT a :& ToMaybeT b) -> SqlExpr (Value Bool))
|
||||
-> From (ToMaybeT a :& ToMaybeT 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 :: ToFrom a => a -> (b -> SqlExpr (Value Bool)) -> (a, b -> SqlExpr (Value Bool))
|
||||
on = (,)
|
||||
infix 9 `on`
|
||||
|
||||
type JoinErrorMsg jk = 'Text "Missing on statement for " ':<>: 'Text jk
|
||||
|
||||
type family ToFromT a where
|
||||
ToFromT (From a) = a
|
||||
ToFromT (SqlSetOperation a) = ToAliasReferenceT (ToAliasT a)
|
||||
ToFromT (LeftOuterJoin a (b, c -> SqlExpr (Value Bool))) = c
|
||||
ToFromT (FullOuterJoin a (b, c -> SqlExpr (Value Bool))) = c
|
||||
ToFromT (RightOuterJoin a (b, c -> SqlExpr (Value Bool))) = c
|
||||
ToFromT (InnerJoin a (b, c -> SqlExpr (Value Bool))) = c
|
||||
ToFromT (CrossJoin a b) = (ToFromT a :& ToFromT b)
|
||||
ToFromT (InnerJoin a b) = TypeError (JoinErrorMsg "InnerJoin")
|
||||
ToFromT (LeftOuterJoin a b) = TypeError (JoinErrorMsg "LeftOuterJoin")
|
||||
ToFromT (RightOuterJoin a b) = TypeError (JoinErrorMsg "RightOuterJoin")
|
||||
ToFromT (FullOuterJoin a b) = TypeError (JoinErrorMsg "FullOuterJoin")
|
||||
|
||||
{-- Type class magic to allow the use of the `InnerJoin` family of data constructors in from --}
|
||||
class ToFrom a where
|
||||
toFrom :: a -> From (ToFromT a)
|
||||
|
||||
instance ToFrom (From a) where
|
||||
toFrom = id
|
||||
|
||||
instance {-# OVERLAPPABLE #-} ToFrom (InnerJoin a b) where
|
||||
toFrom = undefined
|
||||
instance {-# OVERLAPPABLE #-} ToFrom (LeftOuterJoin a b) where
|
||||
toFrom = undefined
|
||||
instance {-# OVERLAPPABLE #-} ToFrom (RightOuterJoin a b) where
|
||||
toFrom = undefined
|
||||
instance {-# OVERLAPPABLE #-} ToFrom (FullOuterJoin a b) where
|
||||
toFrom = undefined
|
||||
|
||||
instance (SqlSelect a' r,SqlSelect a'' r', ToAlias a, a' ~ ToAliasT a, ToAliasReference a', ToAliasReferenceT a' ~ a'') => ToFrom (SqlSetOperation a) where
|
||||
-- If someone uses just a plain SelectQuery it should behave like a normal subquery
|
||||
toFrom (SelectQuery q) = SubQuery q
|
||||
-- Otherwise use the SqlSetOperation
|
||||
toFrom q = SqlSetOperation q
|
||||
|
||||
instance (ToFrom a, ToFromT a ~ a', ToFrom b, ToFromT b ~ b', ToMaybe b', mb ~ ToMaybeT b')
|
||||
=> ToFrom (LeftOuterJoin a (b, (a' :& mb) -> SqlExpr (Value Bool))) where
|
||||
toFrom (LeftOuterJoin lhs (rhs, on')) = LeftJoinFrom (toFrom lhs) (toFrom rhs, on')
|
||||
|
||||
instance (ToFrom a, ToFromT a ~ a', ToFrom b, ToFromT b ~ b', ToMaybe a', ma ~ ToMaybeT a', ToMaybe b', mb ~ ToMaybeT b')
|
||||
=> ToFrom (FullOuterJoin a (b, (ma :& mb) -> SqlExpr (Value Bool))) where
|
||||
toFrom (FullOuterJoin lhs (rhs, on')) = FullJoinFrom (toFrom lhs) (toFrom rhs, on')
|
||||
|
||||
instance (ToFrom a, ToFromT a ~ a', ToFrom b, ToFromT b ~ b', ToMaybe a', ma ~ ToMaybeT a')
|
||||
=> ToFrom (RightOuterJoin a (b, (ma :& b') -> SqlExpr (Value Bool))) where
|
||||
toFrom (RightOuterJoin lhs (rhs, on')) = RightJoinFrom (toFrom lhs) (toFrom rhs, on')
|
||||
|
||||
instance (ToFrom a, ToFromT a ~ a', ToFrom b, ToFromT b ~ b') => ToFrom (InnerJoin a (b, (a' :& b') -> SqlExpr (Value Bool))) where
|
||||
toFrom (InnerJoin lhs (rhs, on')) = InnerJoinFrom (toFrom lhs) (toFrom rhs, on')
|
||||
|
||||
instance (ToFrom a, ToFrom b) => ToFrom (CrossJoin a b) where
|
||||
toFrom (CrossJoin lhs rhs) = CrossJoinFrom (toFrom lhs) (toFrom rhs)
|
||||
|
||||
type family Nullable a where
|
||||
Nullable (Maybe a) = a
|
||||
Nullable a = a
|
||||
|
||||
type family ToMaybeT a where
|
||||
ToMaybeT (SqlExpr (Maybe a)) = SqlExpr (Maybe a)
|
||||
ToMaybeT (SqlExpr (Entity a)) = SqlExpr (Maybe (Entity a))
|
||||
ToMaybeT (SqlExpr (Value a)) = SqlExpr (Value (Maybe (Nullable a)))
|
||||
ToMaybeT (a :& b) = (ToMaybeT a :& ToMaybeT b)
|
||||
ToMaybeT (a, b) = (ToMaybeT a, ToMaybeT b)
|
||||
ToMaybeT (a, b, c) = (ToMaybeT a, ToMaybeT b, ToMaybeT c)
|
||||
ToMaybeT (a, b, c, d) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d)
|
||||
ToMaybeT (a, b, c, d, e) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d, ToMaybeT e)
|
||||
ToMaybeT (a, b, c, d, e, f) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d, ToMaybeT e, ToMaybeT f)
|
||||
ToMaybeT (a, b, c, d, e, f, g) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d, ToMaybeT e, ToMaybeT f, ToMaybeT g)
|
||||
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)
|
||||
|
||||
class ToMaybe a where
|
||||
toMaybe :: a -> ToMaybeT a
|
||||
|
||||
instance ToMaybe (SqlExpr (Maybe a)) where
|
||||
toMaybe = id
|
||||
|
||||
instance ToMaybe (SqlExpr (Entity a)) where
|
||||
toMaybe = EMaybe
|
||||
|
||||
instance ToMaybe (SqlExpr (Value a)) where
|
||||
toMaybe = veryUnsafeCoerceSqlExprValue
|
||||
|
||||
instance (ToMaybe a, ToMaybe b) => ToMaybe (a :& b) where
|
||||
toMaybe (a :& b) = (toMaybe a :& toMaybe b)
|
||||
|
||||
instance (ToMaybe a, ToMaybe b) => ToMaybe (a,b) where
|
||||
toMaybe (a, b) = (toMaybe a, toMaybe b)
|
||||
|
||||
instance ( ToMaybe a
|
||||
, ToMaybe b
|
||||
, ToMaybe c
|
||||
) => ToMaybe (a,b,c) where
|
||||
toMaybe = to3 . toMaybe . from3
|
||||
|
||||
instance ( ToMaybe a
|
||||
, ToMaybe b
|
||||
, ToMaybe c
|
||||
, ToMaybe d
|
||||
) => ToMaybe (a,b,c,d) where
|
||||
toMaybe = to4 . toMaybe . from4
|
||||
|
||||
instance ( ToMaybe a
|
||||
, ToMaybe b
|
||||
, ToMaybe c
|
||||
, ToMaybe d
|
||||
, ToMaybe e
|
||||
) => ToMaybe (a,b,c,d,e) where
|
||||
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
|
||||
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
|
||||
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
|
||||
toMaybe = to8 . toMaybe . from8
|
||||
|
||||
-- | 'FROM' clause, used to bring entities into scope.
|
||||
--
|
||||
-- Internally, this function uses the `From` datatype and the
|
||||
-- `ToFrom` typeclass. 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 `ToFrom`. This implementation eliminates certain
|
||||
-- types of runtime errors by preventing the construction of
|
||||
-- invalid SQL (e.g. illegal nested-@from@).
|
||||
from :: ToFrom a => a -> SqlQuery (ToFromT a)
|
||||
from parts = do
|
||||
(a, clause) <- runFrom $ toFrom parts
|
||||
Q $ W.tell mempty{sdFromClause=[clause]}
|
||||
pure a
|
||||
where
|
||||
runFrom :: From a -> SqlQuery (a, FromClause)
|
||||
runFrom e@Table = do
|
||||
let ed = entityDef $ getVal e
|
||||
ident <- newIdentFor (entityDB ed)
|
||||
let entity = EEntity ident
|
||||
pure $ (entity, FromStart ident ed)
|
||||
where
|
||||
getVal :: PersistEntity ent => From (SqlExpr (Entity ent)) -> Proxy ent
|
||||
getVal = const Proxy
|
||||
runFrom (SubQuery subquery) = 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 , FromQuery subqueryAlias (\info -> toRawSql SELECT info aliasedQuery))
|
||||
|
||||
runFrom (SqlSetOperation operation) = do
|
||||
(aliasedOperation, ret) <- aliasQueries operation
|
||||
ident <- newIdentFor (DBName "u")
|
||||
ref <- toAliasReference ident ret
|
||||
pure (ref, FromQuery ident $ operationToSql aliasedOperation)
|
||||
|
||||
where
|
||||
aliasQueries o =
|
||||
case o of
|
||||
SelectQuery q -> do
|
||||
(ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ q
|
||||
prevState <- Q $ lift S.get
|
||||
aliasedRet <- toAlias ret
|
||||
Q $ lift $ S.put prevState
|
||||
pure (SelectQuery $ Q $ W.WriterT $ pure (aliasedRet, sideData), aliasedRet)
|
||||
Union o1 o2 -> do
|
||||
(o1', ret) <- aliasQueries o1
|
||||
(o2', _ ) <- aliasQueries o2
|
||||
pure (Union o1' o2', ret)
|
||||
UnionAll o1 o2 -> do
|
||||
(o1', ret) <- aliasQueries o1
|
||||
(o2', _ ) <- aliasQueries o2
|
||||
pure (UnionAll o1' o2', ret)
|
||||
Except o1 o2 -> do
|
||||
(o1', ret) <- aliasQueries o1
|
||||
(o2', _ ) <- aliasQueries o2
|
||||
pure (Except o1' o2', ret)
|
||||
Intersect o1 o2 -> do
|
||||
(o1', ret) <- aliasQueries o1
|
||||
(o2', _ ) <- aliasQueries o2
|
||||
pure (Intersect o1' o2', ret)
|
||||
|
||||
operationToSql o info =
|
||||
case o of
|
||||
SelectQuery q -> toRawSql SELECT info q
|
||||
Union o1 o2 -> doSetOperation "UNION" info o1 o2
|
||||
UnionAll o1 o2 -> doSetOperation "UNION ALL" info o1 o2
|
||||
Except o1 o2 -> doSetOperation "EXCEPT" info o1 o2
|
||||
Intersect o1 o2 -> doSetOperation "INTERSECT" info o1 o2
|
||||
|
||||
doSetOperation operationText info o1 o2 =
|
||||
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
|
||||
let ret = leftVal :& rightVal
|
||||
pure $ (ret, FromJoin leftFrom InnerJoinKind rightFrom (Just (on' ret)))
|
||||
runFrom (CrossJoinFrom leftPart rightPart) = do
|
||||
(leftVal, leftFrom) <- runFrom leftPart
|
||||
(rightVal, rightFrom) <- runFrom rightPart
|
||||
let ret = leftVal :& rightVal
|
||||
pure $ (ret, FromJoin leftFrom CrossJoinKind rightFrom Nothing)
|
||||
runFrom (LeftJoinFrom leftPart (rightPart, on')) = do
|
||||
(leftVal, leftFrom) <- runFrom leftPart
|
||||
(rightVal, rightFrom) <- runFrom rightPart
|
||||
let ret = leftVal :& (toMaybe rightVal)
|
||||
pure $ (ret, FromJoin leftFrom LeftOuterJoinKind rightFrom (Just (on' ret)))
|
||||
runFrom (RightJoinFrom leftPart (rightPart, on')) = do
|
||||
(leftVal, leftFrom) <- runFrom leftPart
|
||||
(rightVal, rightFrom) <- runFrom rightPart
|
||||
let ret = (toMaybe leftVal) :& rightVal
|
||||
pure $ (ret, FromJoin leftFrom RightOuterJoinKind rightFrom (Just (on' ret)))
|
||||
runFrom (FullJoinFrom leftPart (rightPart, on')) = do
|
||||
(leftVal, leftFrom) <- runFrom leftPart
|
||||
(rightVal, rightFrom) <- runFrom rightPart
|
||||
let ret = (toMaybe leftVal) :& (toMaybe rightVal)
|
||||
pure $ (ret, FromJoin leftFrom FullOuterJoinKind rightFrom (Just (on' ret)))
|
||||
|
||||
type family ToAliasT a where
|
||||
ToAliasT (SqlExpr (Value a)) = SqlExpr (Value a)
|
||||
ToAliasT (SqlExpr (Entity a)) = SqlExpr (Entity a)
|
||||
ToAliasT (a, b) = (ToAliasT a, ToAliasT b)
|
||||
ToAliasT (a, b, c) = (ToAliasT a, ToAliasT b, ToAliasT c)
|
||||
ToAliasT (a, b, c, d) = (ToAliasT a, ToAliasT b, ToAliasT c, ToAliasT d)
|
||||
ToAliasT (a, b, c, d, e) = (ToAliasT a, ToAliasT b, ToAliasT c, ToAliasT d, ToAliasT e)
|
||||
ToAliasT (a, b, c, d, e, f) = (ToAliasT a, ToAliasT b, ToAliasT c, ToAliasT d, ToAliasT e, ToAliasT f)
|
||||
ToAliasT (a, b, c, d, e, f, g) = (ToAliasT a, ToAliasT b, ToAliasT c, ToAliasT d, ToAliasT e, ToAliasT f, ToAliasT g)
|
||||
ToAliasT (a, b, c, d, e, f, g, h) = (ToAliasT a, ToAliasT b, ToAliasT c, ToAliasT d, ToAliasT e, ToAliasT f, ToAliasT g, ToAliasT h)
|
||||
|
||||
-- Tedious tuple magic
|
||||
class ToAlias a where
|
||||
toAlias :: a -> SqlQuery (ToAliasT a)
|
||||
|
||||
instance ToAlias (SqlExpr (Value a)) where
|
||||
toAlias v@(EAliasedValue _ _) = pure v
|
||||
toAlias v = do
|
||||
ident <- newIdentFor (DBName "v")
|
||||
pure $ EAliasedValue ident v
|
||||
|
||||
instance ToAlias (SqlExpr (Entity a)) where
|
||||
toAlias v@(EAliasedEntityReference _ _) = pure v
|
||||
toAlias v@(EAliasedEntity _ _) = pure v
|
||||
toAlias (EEntity tableIdent) = do
|
||||
ident <- newIdentFor (DBName "v")
|
||||
pure $ EAliasedEntity ident tableIdent
|
||||
|
||||
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)
|
||||
|
||||
|
||||
type family ToAliasReferenceT a where
|
||||
ToAliasReferenceT (SqlExpr (Value a)) = SqlExpr (Value a)
|
||||
ToAliasReferenceT (SqlExpr (Entity a)) = SqlExpr (Entity a)
|
||||
ToAliasReferenceT (a,b) = (ToAliasReferenceT a, ToAliasReferenceT b)
|
||||
ToAliasReferenceT (a,b,c) = (ToAliasReferenceT a, ToAliasReferenceT b, ToAliasReferenceT c)
|
||||
ToAliasReferenceT (a, b, c, d) = (ToAliasReferenceT a, ToAliasReferenceT b, ToAliasReferenceT c, ToAliasReferenceT d)
|
||||
ToAliasReferenceT (a, b, c, d, e) = (ToAliasReferenceT a, ToAliasReferenceT b, ToAliasReferenceT c, ToAliasReferenceT d, ToAliasReferenceT e)
|
||||
ToAliasReferenceT (a, b, c, d, e, f) = (ToAliasReferenceT a, ToAliasReferenceT b, ToAliasReferenceT c, ToAliasReferenceT d, ToAliasReferenceT e, ToAliasReferenceT f)
|
||||
ToAliasReferenceT (a, b, c, d, e, f, g) = (ToAliasReferenceT a, ToAliasReferenceT b, ToAliasReferenceT c, ToAliasReferenceT d, ToAliasReferenceT e, ToAliasReferenceT f, ToAliasReferenceT g)
|
||||
ToAliasReferenceT (a, b, c, d, e, f, g, h) = (ToAliasReferenceT a, ToAliasReferenceT b, ToAliasReferenceT c, ToAliasReferenceT d, ToAliasReferenceT e, ToAliasReferenceT f, ToAliasReferenceT g, ToAliasReferenceT h)
|
||||
|
||||
-- more tedious tuple magic
|
||||
class ToAliasReference a where
|
||||
toAliasReference :: Ident -> a -> SqlQuery (ToAliasReferenceT a)
|
||||
|
||||
instance ToAliasReference (SqlExpr (Value a)) where
|
||||
toAliasReference aliasSource (EAliasedValue aliasIdent _) = pure $ EValueReference aliasSource (\_ -> aliasIdent)
|
||||
toAliasReference _ v@(ERaw _ _) = toAlias v
|
||||
toAliasReference _ v@(ECompositeKey _) = toAlias v
|
||||
toAliasReference _ v@(EValueReference _ _) = pure v
|
||||
|
||||
instance ToAliasReference (SqlExpr (Entity a)) where
|
||||
toAliasReference aliasSource (EAliasedEntity ident _) = pure $ EAliasedEntityReference aliasSource ident
|
||||
toAliasReference _ e@(EEntity _) = toAlias e
|
||||
toAliasReference _ e@(EAliasedEntityReference _ _) = pure e
|
||||
|
||||
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)
|
||||
@ -521,9 +521,21 @@ subSelectUnsafe = sub SELECT
|
||||
=> SqlExpr (Entity val)
|
||||
-> EntityField val typ
|
||||
-> SqlExpr (Value typ)
|
||||
EEntity ident ^. field
|
||||
(EAliasedEntityReference source base) ^. field =
|
||||
EValueReference source (aliasedEntityColumnIdent base fieldDef)
|
||||
where
|
||||
fieldDef =
|
||||
if isIdField field then
|
||||
-- TODO what about composite natural keys in a join this will ignore them
|
||||
head $ entityKeyFields ed
|
||||
else
|
||||
persistFieldDef field
|
||||
|
||||
ed = entityDef $ getEntityVal (Proxy :: Proxy (SqlExpr (Entity val)))
|
||||
|
||||
e ^. field
|
||||
| isIdField field = idFieldValue
|
||||
| otherwise = ERaw Never $ \info -> (dot info $ persistFieldDef field, [])
|
||||
| otherwise = ERaw Never $ \info -> (dot info $ persistFieldDef field, [])
|
||||
where
|
||||
idFieldValue =
|
||||
case entityKeyFields ed of
|
||||
@ -533,9 +545,20 @@ EEntity ident ^. field
|
||||
idFields ->
|
||||
ECompositeKey $ \info -> dot info <$> idFields
|
||||
|
||||
dot info x = useIdent info ident <> "." <> fromDBName info (fieldDB x)
|
||||
ed = entityDef $ getEntityVal (Proxy :: Proxy (SqlExpr (Entity val)))
|
||||
Just pdef = entityPrimary ed
|
||||
|
||||
ed = entityDef $ getEntityVal (Proxy :: Proxy (SqlExpr (Entity val)))
|
||||
|
||||
dot info fieldDef =
|
||||
useIdent info sourceIdent <> "." <> fieldIdent
|
||||
where
|
||||
sourceIdent =
|
||||
case e of
|
||||
EEntity ident -> ident
|
||||
EAliasedEntity baseI _ -> baseI
|
||||
fieldIdent =
|
||||
case e of
|
||||
EEntity _ -> fromDBName info (fieldDB fieldDef)
|
||||
EAliasedEntity baseI _ -> useIdent info $ aliasedEntityColumnIdent baseI fieldDef info
|
||||
|
||||
-- | Project an SqlExpression that may be null, guarding against null cases.
|
||||
withNonNull :: PersistField typ
|
||||
@ -557,15 +580,24 @@ val v = ERaw Never $ const ("?", [toPersistValue v])
|
||||
|
||||
-- | @IS NULL@ comparison.
|
||||
isNothing :: PersistField typ => SqlExpr (Value (Maybe typ)) -> SqlExpr (Value Bool)
|
||||
isNothing (ERaw p f) = ERaw Parens $ first ((<> " IS NULL") . parensM p) . f
|
||||
isNothing (ECompositeKey f) = ERaw Parens $ flip (,) [] . (intersperseB " AND " . map (<> " IS NULL")) . f
|
||||
isNothing v =
|
||||
case v of
|
||||
ERaw p f -> isNullExpr $ first (parensM p) . f
|
||||
EAliasedValue i _ -> isNullExpr $ aliasedValueIdentToRawSql i
|
||||
EValueReference i i' -> isNullExpr $ valueReferenceToRawSql i i'
|
||||
ECompositeKey f -> ERaw Parens $ flip (,) [] . (intersperseB " AND " . map (<> " IS NULL")) . f
|
||||
where
|
||||
isNullExpr :: (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value Bool)
|
||||
isNullExpr g = ERaw Parens $ first ((<> " IS NULL")) . g
|
||||
|
||||
-- | Analogous to 'Just', promotes a value of type @typ@ into
|
||||
-- one of type @Maybe typ@. It should hold that @'val' . Just
|
||||
-- === just . 'val'@.
|
||||
just :: SqlExpr (Value typ) -> SqlExpr (Value (Maybe typ))
|
||||
just (ERaw p f) = ERaw p f
|
||||
just (ECompositeKey f) = ECompositeKey f
|
||||
just (ERaw p f) = ERaw p f
|
||||
just (ECompositeKey f) = ECompositeKey f
|
||||
just (EAliasedValue i v) = EAliasedValue i (just v)
|
||||
just (EValueReference i i') = EValueReference i i'
|
||||
|
||||
-- | @NULL@ value.
|
||||
nothing :: SqlExpr (Value (Maybe typ))
|
||||
@ -574,8 +606,22 @@ nothing = unsafeSqlValue "NULL"
|
||||
-- | Join nested 'Maybe's in a 'Value' into one. This is useful when
|
||||
-- calling aggregate functions on nullable fields.
|
||||
joinV :: SqlExpr (Value (Maybe (Maybe typ))) -> SqlExpr (Value (Maybe typ))
|
||||
joinV (ERaw p f) = ERaw p f
|
||||
joinV (ECompositeKey f) = ECompositeKey f
|
||||
joinV (ERaw p f) = ERaw p f
|
||||
joinV (ECompositeKey f) = ECompositeKey f
|
||||
joinV (EAliasedValue i v) = EAliasedValue i (joinV v)
|
||||
joinV (EValueReference i i') = EValueReference i i'
|
||||
|
||||
|
||||
countHelper :: Num a => TLB.Builder -> TLB.Builder -> SqlExpr (Value typ) -> SqlExpr (Value a)
|
||||
countHelper open close v =
|
||||
case v of
|
||||
ERaw _ f -> countRawSql f
|
||||
EAliasedValue i _ -> countRawSql $ aliasedValueIdentToRawSql i
|
||||
EValueReference i i' -> countRawSql $ valueReferenceToRawSql i i'
|
||||
ECompositeKey _ -> countRows
|
||||
where
|
||||
countRawSql :: (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value a)
|
||||
countRawSql x = ERaw Never $ first (\b -> "COUNT" <> open <> parens b <> close) . x
|
||||
|
||||
-- | @COUNT(*)@ value.
|
||||
countRows :: Num a => SqlExpr (Value a)
|
||||
@ -592,10 +638,16 @@ countDistinct :: Num a => SqlExpr (Value typ) -> SqlExpr (Value a)
|
||||
countDistinct = countHelper "(DISTINCT " ")"
|
||||
|
||||
not_ :: SqlExpr (Value Bool) -> SqlExpr (Value Bool)
|
||||
not_ (ERaw p f) = ERaw Never $ \info -> let (b, vals) = f info
|
||||
in ("NOT " <> parensM p b, vals)
|
||||
not_ (ECompositeKey _) = throw (CompositeKeyErr NotError)
|
||||
|
||||
not_ v = ERaw Never (\info -> first ("NOT " <>) $ x info)
|
||||
where
|
||||
x info =
|
||||
case v of
|
||||
ERaw p f ->
|
||||
let (b, vals) = f info
|
||||
in (parensM p b, vals)
|
||||
ECompositeKey _ -> throw (CompositeKeyErr NotError)
|
||||
EAliasedValue i _ -> aliasedValueIdentToRawSql i info
|
||||
EValueReference i i' -> valueReferenceToRawSql i i' info
|
||||
|
||||
(==.) :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool)
|
||||
(==.) = unsafeSqlBinOpComposite " = " " AND "
|
||||
@ -879,15 +931,23 @@ field /=. expr = setAux field (\ent -> ent ^. field /. expr)
|
||||
(<#) :: (a -> b) -> SqlExpr (Value a) -> SqlExpr (Insertion b)
|
||||
(<#) _ (ERaw _ f) = EInsert Proxy f
|
||||
(<#) _ (ECompositeKey _) = throw (CompositeKeyErr ToInsertionError)
|
||||
(<#) _ (EAliasedValue i _) = EInsert Proxy $ aliasedValueIdentToRawSql i
|
||||
(<#) _ (EValueReference i i') = EInsert Proxy $ valueReferenceToRawSql i i'
|
||||
|
||||
|
||||
-- | Apply extra @SqlExpr Value@ arguments to a 'PersistField' constructor
|
||||
(<&>) :: SqlExpr (Insertion (a -> b)) -> SqlExpr (Value a) -> SqlExpr (Insertion b)
|
||||
(EInsert _ f) <&> (ERaw _ g) = EInsert Proxy $ \x ->
|
||||
(EInsert _ f) <&> v = EInsert Proxy $ \x ->
|
||||
let (fb, fv) = f x
|
||||
(gb, gv) = g x
|
||||
in (fb <> ", " <> gb, fv ++ gv)
|
||||
(EInsert _ _) <&> (ECompositeKey _) = throw (CompositeKeyErr CombineInsertionError)
|
||||
where
|
||||
g =
|
||||
case v of
|
||||
ERaw _ f' -> f'
|
||||
EAliasedValue i _ -> aliasedValueIdentToRawSql i
|
||||
EValueReference i i' -> valueReferenceToRawSql i i'
|
||||
ECompositeKey _ -> throw (CompositeKeyErr CombineInsertionError)
|
||||
|
||||
-- | @CASE@ statement. For example:
|
||||
--
|
||||
@ -1003,6 +1063,7 @@ then_ = ()
|
||||
else_ :: expr a -> expr a
|
||||
else_ = id
|
||||
|
||||
|
||||
-- | A single value (as opposed to a whole entity). You may use
|
||||
-- @('^.')@ or @('?.')@ to get a 'Value' from an 'Entity'.
|
||||
newtype Value a = Value { unValue :: a } deriving (Eq, Ord, Show, Typeable)
|
||||
@ -1142,8 +1203,11 @@ renderUpdates :: (BackendCompatible SqlBackend backend) =>
|
||||
renderUpdates conn = uncommas' . concatMap renderUpdate
|
||||
where
|
||||
mk :: SqlExpr (Value ()) -> [(TLB.Builder, [PersistValue])]
|
||||
mk (ERaw _ f) = [f info]
|
||||
mk (ECompositeKey _) = throw (CompositeKeyErr MakeSetError) -- FIXME
|
||||
mk (ERaw _ f) = [f info]
|
||||
mk (ECompositeKey _) = throw (CompositeKeyErr MakeSetError) -- FIXME
|
||||
mk (EAliasedValue i _) = [aliasedValueIdentToRawSql i info]
|
||||
mk (EValueReference i i') = [valueReferenceToRawSql i i' info]
|
||||
|
||||
renderUpdate :: SqlExpr (Update val) -> [(TLB.Builder, [PersistValue])]
|
||||
renderUpdate (ESet f) = mk (f undefined) -- second parameter of f is always unused
|
||||
info = (projectBackend conn, initialIdentState)
|
||||
@ -1198,6 +1262,7 @@ class IsJoinKind join where
|
||||
-- | (Internal) Reify a @JoinKind@ from a @JOIN@. This
|
||||
-- function is non-strict.
|
||||
reifyJoinKind :: join a b -> JoinKind
|
||||
|
||||
instance IsJoinKind InnerJoin where
|
||||
smartJoin a b = a `InnerJoin` b
|
||||
reifyJoinKind _ = InnerJoinKind
|
||||
@ -1222,11 +1287,12 @@ data OnClauseWithoutMatchingJoinException =
|
||||
deriving (Eq, Ord, Show, Typeable)
|
||||
instance Exception OnClauseWithoutMatchingJoinException where
|
||||
|
||||
|
||||
-- | (Internal) Phantom type used to process 'from' (see 'fromStart').
|
||||
data PreprocessedFrom a
|
||||
|
||||
|
||||
|
||||
|
||||
-- | Phantom type used by 'orderBy', 'asc' and 'desc'.
|
||||
data OrderBy
|
||||
|
||||
@ -1496,13 +1562,14 @@ instance ( FromPreprocess a
|
||||
-- | Exception data type for @esqueleto@ internal errors
|
||||
data EsqueletoError =
|
||||
CompositeKeyErr CompositeKeyError
|
||||
| AliasedValueErr UnexpectedValueError
|
||||
| UnexpectedCaseErr UnexpectedCaseError
|
||||
| SqlBinOpCompositeErr SqlBinOpCompositeError
|
||||
deriving (Show)
|
||||
|
||||
instance Exception EsqueletoError
|
||||
|
||||
data CompositeKeyError =
|
||||
data UnexpectedValueError =
|
||||
NotError
|
||||
| ToInsertionError
|
||||
| CombineInsertionError
|
||||
@ -1516,6 +1583,8 @@ data CompositeKeyError =
|
||||
| MakeHavingError
|
||||
deriving (Show)
|
||||
|
||||
type CompositeKeyError = UnexpectedValueError
|
||||
|
||||
data UnexpectedCaseError =
|
||||
EmptySqlExprValueList
|
||||
| MakeFromError
|
||||
@ -1524,6 +1593,7 @@ data UnexpectedCaseError =
|
||||
| NewIdentForError
|
||||
| UnsafeSqlCaseError
|
||||
| OperationNotSupported
|
||||
| NotImplemented
|
||||
deriving (Show)
|
||||
|
||||
data SqlBinOpCompositeError =
|
||||
@ -1599,12 +1669,14 @@ data FromClause =
|
||||
FromStart Ident EntityDef
|
||||
| FromJoin FromClause JoinKind FromClause (Maybe (SqlExpr (Value Bool)))
|
||||
| OnClause (SqlExpr (Value Bool))
|
||||
| FromQuery Ident (IdentInfo -> (TLB.Builder, [PersistValue]))
|
||||
|
||||
collectIdents :: FromClause -> Set Ident
|
||||
collectIdents fc = case fc of
|
||||
FromStart i _ -> Set.singleton i
|
||||
FromJoin lhs _ rhs _ -> collectIdents lhs <> collectIdents rhs
|
||||
OnClause _ -> mempty
|
||||
FromQuery _ _ -> mempty
|
||||
|
||||
instance Show FromClause where
|
||||
show fc = case fc of
|
||||
@ -1626,6 +1698,8 @@ instance Show FromClause where
|
||||
]
|
||||
OnClause expr ->
|
||||
"(OnClause " <> render' expr <> ")"
|
||||
FromQuery ident _->
|
||||
"(FromQuery " <> show ident <> ")"
|
||||
|
||||
|
||||
where
|
||||
@ -1684,10 +1758,12 @@ collectOnClauses sqlBackend = go Set.empty []
|
||||
findRightmostIdent (FromStart i _) = Just i
|
||||
findRightmostIdent (FromJoin _ _ r _) = findRightmostIdent r
|
||||
findRightmostIdent (OnClause {}) = Nothing
|
||||
findRightmostIdent (FromQuery _ _) = Nothing
|
||||
|
||||
findLeftmostIdent (FromStart i _) = Just i
|
||||
findLeftmostIdent (FromJoin l _ _ _) = findLeftmostIdent l
|
||||
findLeftmostIdent (OnClause {}) = Nothing
|
||||
findLeftmostIdent (FromQuery _ _) = Nothing
|
||||
|
||||
tryMatch
|
||||
:: Set Ident
|
||||
@ -1853,6 +1929,10 @@ useIdent info (I ident) = fromDBName info $ DBName ident
|
||||
data SqlExpr a where
|
||||
-- An entity, created by 'from' (cf. 'fromStart').
|
||||
EEntity :: Ident -> SqlExpr (Entity val)
|
||||
-- Base Table
|
||||
EAliasedEntity :: Ident -> Ident -> SqlExpr (Entity val)
|
||||
-- Source Base
|
||||
EAliasedEntityReference :: Ident -> Ident -> SqlExpr (Entity val)
|
||||
|
||||
-- Just a tag stating that something is nullable.
|
||||
EMaybe :: SqlExpr a -> SqlExpr (Maybe a)
|
||||
@ -1864,6 +1944,13 @@ data SqlExpr a where
|
||||
-- interpolated by the SQL backend.
|
||||
ERaw :: NeedParens -> (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value a)
|
||||
|
||||
|
||||
-- A raw expression with an alias
|
||||
EAliasedValue :: Ident -> SqlExpr (Value a) -> SqlExpr (Value a)
|
||||
|
||||
-- A reference to an aliased field in a table or subquery
|
||||
EValueReference :: Ident -> (IdentInfo -> Ident) -> SqlExpr (Value a)
|
||||
|
||||
-- A composite key.
|
||||
--
|
||||
-- Persistent uses the same 'PersistList' constructor for both
|
||||
@ -1912,6 +1999,7 @@ data SqlExpr a where
|
||||
|
||||
-- A 'SqlExpr' accepted only by 'orderBy'.
|
||||
EOrderBy :: OrderByType -> SqlExpr (Value a) -> SqlExpr OrderBy
|
||||
|
||||
EOrderRandom :: SqlExpr OrderBy
|
||||
|
||||
-- A 'SqlExpr' accepted only by 'distinctOn'.
|
||||
@ -1970,9 +2058,6 @@ ifNotEmptyList :: SqlExpr (ValueList a) -> Bool -> SqlExpr (Value Bool) -> SqlEx
|
||||
ifNotEmptyList EEmptyList b _ = val b
|
||||
ifNotEmptyList (EList _) _ x = x
|
||||
|
||||
countHelper :: Num a => TLB.Builder -> TLB.Builder -> SqlExpr (Value typ) -> SqlExpr (Value a)
|
||||
countHelper open close (ERaw _ f) = ERaw Never $ first (\b -> "COUNT" <> open <> parens b <> close) . f
|
||||
countHelper _ _ (ECompositeKey _) = countRows -- Assumes no NULLs on a PK
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
@ -1982,26 +2067,31 @@ countHelper _ _ (ECompositeKey _) = countRows -- Assumes no NULLs on a PK
|
||||
--
|
||||
-- Since: 2.1.1
|
||||
unsafeSqlCase :: PersistField a => [(SqlExpr (Value Bool), SqlExpr (Value a))] -> SqlExpr (Value a) -> SqlExpr (Value a)
|
||||
unsafeSqlCase when (ERaw p1 f1) = ERaw Never buildCase
|
||||
unsafeSqlCase when v = ERaw Never buildCase
|
||||
where
|
||||
buildCase :: IdentInfo -> (TLB.Builder, [PersistValue])
|
||||
buildCase info =
|
||||
let (b1, vals1) = f1 info
|
||||
(b2, vals2) = mapWhen when info
|
||||
in ( "CASE" <> b2 <> " ELSE " <> parensM p1 b1 <> " END", vals2 <> vals1)
|
||||
let (elseText, elseVals) = valueToSql v info
|
||||
(whenText, whenVals) = mapWhen when info
|
||||
in ( "CASE" <> whenText <> " ELSE " <> elseText <> " END", whenVals <> elseVals)
|
||||
|
||||
mapWhen :: [(SqlExpr (Value Bool), SqlExpr (Value a))] -> IdentInfo -> (TLB.Builder, [PersistValue])
|
||||
mapWhen [] _ = throw (UnexpectedCaseErr UnsafeSqlCaseError)
|
||||
mapWhen when' info = foldl (foldHelp info) (mempty, mempty) when'
|
||||
|
||||
foldHelp :: IdentInfo -> (TLB.Builder, [PersistValue]) -> (SqlExpr (Value Bool), SqlExpr (Value a)) -> (TLB.Builder, [PersistValue])
|
||||
foldHelp info (b0, vals0) (ERaw p1' f1', ERaw p2 f2) =
|
||||
let (b1, vals1) = f1' info
|
||||
(b2, vals2) = f2 info
|
||||
in ( b0 <> " WHEN " <> parensM p1' b1 <> " THEN " <> parensM p2 b2, vals0 <> vals1 <> vals2 )
|
||||
foldHelp _ _ _ = throw (CompositeKeyErr FoldHelpError)
|
||||
unsafeSqlCase _ (ECompositeKey _) = throw (CompositeKeyErr SqlCaseError)
|
||||
foldHelp _ _ (ECompositeKey _, _) = throw (CompositeKeyErr FoldHelpError)
|
||||
foldHelp _ _ (_, ECompositeKey _) = throw (CompositeKeyErr FoldHelpError)
|
||||
foldHelp info (b0, vals0) (v1, v2) =
|
||||
let (b1, vals1) = valueToSql v1 info
|
||||
(b2, vals2) = valueToSql v2 info
|
||||
in ( b0 <> " WHEN " <> b1 <> " THEN " <> b2, vals0 <> vals1 <> vals2 )
|
||||
|
||||
valueToSql :: SqlExpr (Value a) -> IdentInfo -> (TLB.Builder, [PersistValue])
|
||||
valueToSql (ERaw p f) = (first (parensM p)) . f
|
||||
valueToSql (ECompositeKey _) = throw (CompositeKeyErr SqlCaseError)
|
||||
valueToSql (EAliasedValue i _) = aliasedValueIdentToRawSql i
|
||||
valueToSql (EValueReference i i') = valueReferenceToRawSql i i'
|
||||
|
||||
-- | (Internal) Create a custom binary operator. You /should/
|
||||
-- /not/ use this function directly since its type is very
|
||||
@ -2032,9 +2122,15 @@ unsafeSqlBinOp op a b = unsafeSqlBinOp op (construct a) (construct b)
|
||||
in build (parensM p b1, vals)
|
||||
construct (ECompositeKey f) =
|
||||
ERaw Parens $ \info -> (uncommas $ f info, mempty)
|
||||
construct (EAliasedValue i _) =
|
||||
ERaw Never $ aliasedValueIdentToRawSql i
|
||||
construct (EValueReference i i') =
|
||||
ERaw Never $ valueReferenceToRawSql i i'
|
||||
{-# INLINE unsafeSqlBinOp #-}
|
||||
|
||||
|
||||
|
||||
|
||||
-- | Similar to 'unsafeSqlBinOp', but may also be applied to
|
||||
-- composite keys. Uses the operator given as the second
|
||||
-- argument whenever applied to composite keys.
|
||||
@ -2063,8 +2159,10 @@ unsafeSqlBinOpComposite op _ a@(ERaw _ _) b@(ERaw _ _) = unsafeSqlBinOp op a b
|
||||
unsafeSqlBinOpComposite op sep a b = ERaw Parens $ compose (listify a) (listify b)
|
||||
where
|
||||
listify :: SqlExpr (Value x) -> IdentInfo -> ([TLB.Builder], [PersistValue])
|
||||
listify (ECompositeKey f) = flip (,) [] . f
|
||||
listify (ERaw _ f) = deconstruct . f
|
||||
listify (ECompositeKey f) = flip (,) [] . f
|
||||
listify (ERaw _ f) = deconstruct . f
|
||||
listify (EAliasedValue i _) = deconstruct . (aliasedValueIdentToRawSql i)
|
||||
listify (EValueReference i i') = deconstruct . (valueReferenceToRawSql i i')
|
||||
|
||||
deconstruct :: (TLB.Builder, [PersistValue]) -> ([TLB.Builder], [PersistValue])
|
||||
deconstruct ("?", [PersistList vals]) = (replicate (length vals) "?", vals)
|
||||
@ -2123,12 +2221,16 @@ unsafeSqlFunctionParens name arg =
|
||||
-- | (Internal) An explicit SQL type cast using CAST(value as type).
|
||||
-- See 'unsafeSqlBinOp' for warnings.
|
||||
unsafeSqlCastAs :: T.Text -> SqlExpr (Value a) -> SqlExpr (Value b)
|
||||
unsafeSqlCastAs t (ERaw p f) =
|
||||
ERaw Never $ \info ->
|
||||
let (b, v) = f info
|
||||
in ("CAST" <> parens ( parensM p b <> " AS " <> TLB.fromText t), v )
|
||||
unsafeSqlCastAs _ (ECompositeKey _) = throw (CompositeKeyErr SqlCastAsError)
|
||||
|
||||
unsafeSqlCastAs t v = ERaw Never ((first (\value -> "CAST" <> parens (value <> " AS " <> TLB.fromText t))) . valueToText)
|
||||
where
|
||||
valueToText info =
|
||||
case v of
|
||||
(ERaw p f) ->
|
||||
let (b, vals) = f info
|
||||
in (parensM p b, vals)
|
||||
EAliasedValue i _ -> aliasedValueIdentToRawSql i info
|
||||
EValueReference i i' -> valueReferenceToRawSql i i' info
|
||||
ECompositeKey _ -> throw (CompositeKeyErr SqlCastAsError)
|
||||
-- | (Internal) This class allows 'unsafeSqlFunction' to work with different
|
||||
-- numbers of arguments; specifically it allows providing arguments to a sql
|
||||
-- function via an n-tuple of @SqlExpr (Value _)@ values, which are not all
|
||||
@ -2234,8 +2336,10 @@ instance ( UnsafeSqlFunctionArgument a
|
||||
-- 'SqlExpr (Value b)'. You should /not/ use this function
|
||||
-- unless you know what you're doing!
|
||||
veryUnsafeCoerceSqlExprValue :: SqlExpr (Value a) -> SqlExpr (Value b)
|
||||
veryUnsafeCoerceSqlExprValue (ERaw p f) = ERaw p f
|
||||
veryUnsafeCoerceSqlExprValue (ECompositeKey f) = ECompositeKey f
|
||||
veryUnsafeCoerceSqlExprValue (ERaw p f) = ERaw p f
|
||||
veryUnsafeCoerceSqlExprValue (ECompositeKey f) = ECompositeKey f
|
||||
veryUnsafeCoerceSqlExprValue (EAliasedValue i v) = EAliasedValue i (veryUnsafeCoerceSqlExprValue v)
|
||||
veryUnsafeCoerceSqlExprValue (EValueReference i i') = EValueReference i i'
|
||||
|
||||
|
||||
-- | (Internal) Coerce a value's type from 'SqlExpr (ValueList
|
||||
@ -2636,6 +2740,9 @@ makeFrom info mode fs = ret
|
||||
, maybe mempty makeOnClause monClause
|
||||
]
|
||||
mk _ (OnClause _) = throw (UnexpectedCaseErr MakeFromError)
|
||||
mk _ (FromQuery ident f) =
|
||||
let (queryText, queryVals) = f info
|
||||
in ((parens queryText) <> " AS " <> useIdent info ident, queryVals)
|
||||
|
||||
base ident@(I identText) def =
|
||||
let db@(DBName dbText) = entityDB def
|
||||
@ -2652,25 +2759,36 @@ makeFrom info mode fs = ret
|
||||
|
||||
makeOnClause (ERaw _ f) = first (" ON " <>) (f info)
|
||||
makeOnClause (ECompositeKey _) = throw (CompositeKeyErr MakeOnClauseError)
|
||||
makeOnClause (EAliasedValue _ _) = throw (AliasedValueErr MakeOnClauseError)
|
||||
makeOnClause (EValueReference _ _) = throw (AliasedValueErr MakeOnClauseError)
|
||||
|
||||
mkExc :: SqlExpr (Value Bool) -> OnClauseWithoutMatchingJoinException
|
||||
mkExc (ERaw _ f) =
|
||||
OnClauseWithoutMatchingJoinException $
|
||||
TL.unpack $ TLB.toLazyText $ fst (f info)
|
||||
mkExc (ECompositeKey _) = throw (CompositeKeyErr MakeExcError)
|
||||
mkExc (EAliasedValue _ _) = throw (AliasedValueErr MakeExcError)
|
||||
mkExc (EValueReference _ _) = throw (AliasedValueErr MakeExcError)
|
||||
|
||||
makeSet :: IdentInfo -> [SetClause] -> (TLB.Builder, [PersistValue])
|
||||
makeSet _ [] = mempty
|
||||
makeSet info os = first ("\nSET " <>) . uncommas' $ concatMap mk os
|
||||
where
|
||||
mk (SetClause (ERaw _ f)) = [f info]
|
||||
mk (SetClause (ECompositeKey _)) = throw (CompositeKeyErr MakeSetError) -- FIXME
|
||||
mk (SetClause (ERaw _ f)) = [f info]
|
||||
mk (SetClause (ECompositeKey _)) = throw (CompositeKeyErr MakeSetError) -- FIXME
|
||||
mk (SetClause (EAliasedValue i _)) = [aliasedValueIdentToRawSql i info]
|
||||
mk (SetClause (EValueReference i i')) = [valueReferenceToRawSql i i' info]
|
||||
|
||||
makeWhere :: IdentInfo -> WhereClause -> (TLB.Builder, [PersistValue])
|
||||
makeWhere _ NoWhere = mempty
|
||||
makeWhere info (Where (ERaw _ f)) = first ("\nWHERE " <>) (f info)
|
||||
makeWhere _ (Where (ECompositeKey _)) = throw (CompositeKeyErr MakeWhereError)
|
||||
|
||||
makeWhere _ NoWhere = mempty
|
||||
makeWhere info (Where v) = first ("\nWHERE " <>) $ x info
|
||||
where
|
||||
x =
|
||||
case v of
|
||||
ERaw _ f -> f
|
||||
EAliasedValue i _ -> aliasedValueIdentToRawSql i
|
||||
EValueReference i i' -> valueReferenceToRawSql i i'
|
||||
ECompositeKey _ -> throw (CompositeKeyErr MakeWhereError)
|
||||
|
||||
makeGroupBy :: IdentInfo -> GroupByClause -> (TLB.Builder, [PersistValue])
|
||||
makeGroupBy _ (GroupBy []) = (mempty, [])
|
||||
@ -2682,11 +2800,19 @@ makeGroupBy info (GroupBy fields) = first ("\nGROUP BY " <>) build
|
||||
match :: SomeValue -> (TLB.Builder, [PersistValue])
|
||||
match (SomeValue (ERaw _ f)) = f info
|
||||
match (SomeValue (ECompositeKey f)) = (mconcat $ f info, mempty)
|
||||
match (SomeValue (EAliasedValue i _)) = aliasedValueIdentToRawSql i info
|
||||
match (SomeValue (EValueReference i i')) = valueReferenceToRawSql i i' info
|
||||
|
||||
makeHaving :: IdentInfo -> WhereClause -> (TLB.Builder, [PersistValue])
|
||||
makeHaving _ NoWhere = mempty
|
||||
makeHaving info (Where (ERaw _ f)) = first ("\nHAVING " <>) (f info)
|
||||
makeHaving _ (Where (ECompositeKey _)) = throw (CompositeKeyErr MakeHavingError)
|
||||
makeHaving _ NoWhere = mempty
|
||||
makeHaving info (Where v) = first ("\nHAVING " <>) $ x info
|
||||
where
|
||||
x =
|
||||
case v of
|
||||
ERaw _ f -> f
|
||||
EAliasedValue i _ -> aliasedValueIdentToRawSql i
|
||||
EValueReference i i' -> valueReferenceToRawSql i i'
|
||||
ECompositeKey _ -> throw (CompositeKeyErr MakeHavingError)
|
||||
|
||||
-- makeHaving, makeWhere and makeOrderBy
|
||||
makeOrderByNoNewline ::
|
||||
@ -2695,12 +2821,19 @@ makeOrderByNoNewline _ [] = mempty
|
||||
makeOrderByNoNewline info os = first ("ORDER BY " <>) . uncommas' $ concatMap mk os
|
||||
where
|
||||
mk :: OrderByClause -> [(TLB.Builder, [PersistValue])]
|
||||
mk (EOrderBy t (ERaw p f)) = [first ((<> orderByType t) . parensM p) (f info)]
|
||||
mk (EOrderBy t (ECompositeKey f)) =
|
||||
let fs = f info
|
||||
vals = repeat []
|
||||
in zip (map (<> orderByType t) fs) vals
|
||||
mk (EOrderBy t v) =
|
||||
let x = case v of
|
||||
ERaw p f -> (first (parensM p)) . f
|
||||
EAliasedValue i _ -> aliasedValueIdentToRawSql i
|
||||
EValueReference i i' -> valueReferenceToRawSql i i'
|
||||
ECompositeKey _ -> undefined -- defined above
|
||||
in [ first (<> orderByType t) $ x info ]
|
||||
mk EOrderRandom = [first (<> "RANDOM()") mempty]
|
||||
|
||||
orderByType ASC = " ASC"
|
||||
orderByType DESC = " DESC"
|
||||
|
||||
@ -2733,6 +2866,21 @@ makeLocking = flip (,) [] . maybe mempty toTLB . Monoid.getLast
|
||||
parens :: TLB.Builder -> TLB.Builder
|
||||
parens b = "(" <> (b <> ")")
|
||||
|
||||
aliasedValueIdentToRawSql :: Ident -> IdentInfo -> (TLB.Builder, [PersistValue])
|
||||
aliasedValueIdentToRawSql i info =
|
||||
(useIdent info i, mempty)
|
||||
|
||||
valueReferenceToRawSql :: Ident -> (IdentInfo -> Ident) -> IdentInfo -> (TLB.Builder, [PersistValue])
|
||||
valueReferenceToRawSql sourceIdent columnIdentF info =
|
||||
(useIdent info sourceIdent <> "." <> useIdent info (columnIdentF info), mempty)
|
||||
|
||||
aliasedEntityColumnIdent :: Ident -> FieldDef -> IdentInfo -> Ident
|
||||
aliasedEntityColumnIdent (I baseIdent) field info =
|
||||
I (baseIdent <> "_" <> (builderToText $ fromDBName info $ fieldDB field))
|
||||
|
||||
aliasedColumnName :: Ident -> IdentInfo -> T.Text -> TLB.Builder
|
||||
aliasedColumnName (I baseIdent) info columnName =
|
||||
useIdent info (I (baseIdent <> "_" <> columnName))
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
@ -2798,10 +2946,28 @@ instance PersistEntity a => SqlSelect (SqlExpr (Entity a)) (Entity a) where
|
||||
name = useIdent info ident <> "."
|
||||
ret = let ed = entityDef $ getEntityVal $ return expr
|
||||
in (process ed, mempty)
|
||||
sqlSelectCols info expr@(EAliasedEntity aliasIdent tableIdent) = ret
|
||||
where
|
||||
process ed = uncommas $
|
||||
map ((name <>) . aliasName) $
|
||||
entityColumnNames ed (fst info)
|
||||
aliasName columnName = (TLB.fromText columnName) <> " AS " <> aliasedColumnName aliasIdent info columnName
|
||||
name = useIdent info tableIdent <> "."
|
||||
ret = let ed = entityDef $ getEntityVal $ return expr
|
||||
in (process ed, mempty)
|
||||
sqlSelectCols info expr@(EAliasedEntityReference sourceIdent baseIdent) = ret
|
||||
where
|
||||
process ed = uncommas $
|
||||
map ((name <>) . aliasedColumnName baseIdent info) $
|
||||
entityColumnNames ed (fst info)
|
||||
name = useIdent info sourceIdent <> "."
|
||||
ret = let ed = entityDef $ getEntityVal $ return expr
|
||||
in (process ed, mempty)
|
||||
sqlSelectColCount = entityColumnCount . entityDef . getEntityVal
|
||||
sqlSelectProcessRow = parseEntityValues ed
|
||||
where ed = entityDef $ getEntityVal (Proxy :: Proxy (SqlExpr (Entity a)))
|
||||
|
||||
|
||||
getEntityVal :: Proxy (SqlExpr (Entity a)) -> Proxy a
|
||||
getEntityVal = const Proxy
|
||||
|
||||
@ -2826,7 +2992,6 @@ instance PersistField a => SqlSelect (SqlExpr (Value a)) (Value a) where
|
||||
sqlSelectProcessRow [pv] = Value <$> fromPersistValue pv
|
||||
sqlSelectProcessRow pvs = Value <$> fromPersistValue (PersistList pvs)
|
||||
|
||||
|
||||
-- | Materialize a @SqlExpr (Value a)@.
|
||||
materializeExpr :: IdentInfo -> SqlExpr (Value a) -> (TLB.Builder, [PersistValue])
|
||||
materializeExpr info (ERaw p f) =
|
||||
@ -2835,7 +3000,11 @@ materializeExpr info (ERaw p f) =
|
||||
materializeExpr info (ECompositeKey f) =
|
||||
let bs = f info
|
||||
in (uncommas $ map (parensM Parens) bs, [])
|
||||
|
||||
materializeExpr info (EAliasedValue ident x) =
|
||||
let (b, vals) = materializeExpr info x
|
||||
in (b <> " AS " <> (useIdent info ident), vals)
|
||||
materializeExpr info (EValueReference sourceIdent columnIdent) =
|
||||
valueReferenceToRawSql sourceIdent columnIdent info
|
||||
|
||||
-- | You may return tuples (up to 16-tuples) and tuples of tuples
|
||||
-- from a 'select' query.
|
||||
@ -3375,7 +3544,11 @@ renderExpr sqlBackend e =
|
||||
. mconcat
|
||||
. mkInfo
|
||||
$ (sqlBackend, initialIdentState)
|
||||
|
||||
EAliasedValue i _ ->
|
||||
builderToText $ useIdent (sqlBackend, initialIdentState) i
|
||||
EValueReference i i' ->
|
||||
let (builder, _) = valueReferenceToRawSql i i' (sqlBackend, initialIdentState)
|
||||
in (builderToText builder)
|
||||
-- | An exception thrown by 'RenderExpr' - it's not designed to handle composite
|
||||
-- keys, and will blow up if you give it one.
|
||||
--
|
||||
|
||||
@ -70,6 +70,8 @@ import Control.Monad.Trans.Reader (ReaderT)
|
||||
import Data.Char (toLower, toUpper)
|
||||
import Data.Monoid ((<>))
|
||||
import Database.Esqueleto
|
||||
import Database.Esqueleto.Experimental hiding (from, on)
|
||||
import qualified Database.Esqueleto.Experimental as Experimental
|
||||
import Database.Persist.TH
|
||||
import Test.Hspec
|
||||
import UnliftIO
|
||||
@ -139,13 +141,13 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
|
||||
county String maxlen=100
|
||||
dogs Int Maybe
|
||||
Primary county
|
||||
deriving Show
|
||||
deriving Eq Show
|
||||
|
||||
Deed
|
||||
contract String maxlen=100
|
||||
ownerId LordId maxlen=100
|
||||
Primary contract
|
||||
deriving Show
|
||||
deriving Eq Show
|
||||
|
||||
Follow
|
||||
follower PersonId
|
||||
@ -854,6 +856,133 @@ testSelectJoin run = do
|
||||
return p
|
||||
liftIO $ (entityVal <$> ps) `shouldBe` [p1]
|
||||
|
||||
testSelectSubQuery :: Run -> Spec
|
||||
testSelectSubQuery run = do
|
||||
describe "select subquery" $ do
|
||||
it "works" $ do
|
||||
run $ do
|
||||
_ <- insert' p1
|
||||
let q = do
|
||||
p <- Experimental.from $ Table @Person
|
||||
return ( p ^. PersonName, p ^. PersonAge)
|
||||
ret <- select $ Experimental.from $ SelectQuery q
|
||||
liftIO $ ret `shouldBe` [ (Value $ personName p1, Value $ personAge p1) ]
|
||||
|
||||
it "lets you order by alias" $ do
|
||||
run $ do
|
||||
_ <- insert' p1
|
||||
_ <- insert' p3
|
||||
let q = do
|
||||
(name, age) <-
|
||||
Experimental.from $ SubQuery $ do
|
||||
p <- Experimental.from $ Table @Person
|
||||
return ( p ^. PersonName, p ^. PersonAge)
|
||||
orderBy [ asc age ]
|
||||
pure name
|
||||
ret <- select q
|
||||
liftIO $ ret `shouldBe` [ Value $ personName p3, Value $ personName p1 ]
|
||||
|
||||
it "supports groupBy" $ do
|
||||
run $ do
|
||||
l1k <- insert l1
|
||||
l3k <- insert l3
|
||||
mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int])
|
||||
|
||||
mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int])
|
||||
let q = do
|
||||
(lord :& deed) <- Experimental.from $ Table @Lord
|
||||
`InnerJoin` Table @Deed
|
||||
`Experimental.on` (\(lord :& deed) ->
|
||||
lord ^. LordId ==. deed ^. DeedOwnerId)
|
||||
return (lord ^. LordId, deed ^. DeedId)
|
||||
q' = do
|
||||
(lordId, deedId) <- Experimental.from $ SubQuery q
|
||||
groupBy (lordId)
|
||||
return (lordId, count deedId)
|
||||
(ret :: [(Value (Key Lord), Value Int)]) <- select q'
|
||||
|
||||
liftIO $ ret `shouldMatchList` [ (Value l3k, Value 7)
|
||||
, (Value l1k, Value 3) ]
|
||||
|
||||
it "Can count results of aggregate query" $ do
|
||||
run $ do
|
||||
l1k <- insert l1
|
||||
l3k <- insert l3
|
||||
mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int])
|
||||
|
||||
mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int])
|
||||
let q = do
|
||||
(lord :& deed) <- Experimental.from $ Table @Lord
|
||||
`InnerJoin` Table @Deed
|
||||
`Experimental.on` (\(lord :& deed) ->
|
||||
lord ^. LordId ==. deed ^. DeedOwnerId)
|
||||
groupBy (lord ^. LordId)
|
||||
return (lord ^. LordId, count (deed ^. DeedId))
|
||||
|
||||
(ret :: [(Value Int)]) <- select $ do
|
||||
(lordId, deedCount) <- Experimental.from $ SubQuery q
|
||||
where_ $ deedCount >. val (3 :: Int)
|
||||
return (count lordId)
|
||||
|
||||
liftIO $ ret `shouldMatchList` [ (Value 1) ]
|
||||
|
||||
it "joins on subqueries" $ do
|
||||
run $ do
|
||||
l1k <- insert l1
|
||||
l3k <- insert l3
|
||||
mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int])
|
||||
|
||||
mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int])
|
||||
let q = do
|
||||
(lord :& deed) <- Experimental.from $ Table @Lord
|
||||
`InnerJoin` (SelectQuery $ Experimental.from $ Table @Deed)
|
||||
`Experimental.on` (\(lord :& deed) ->
|
||||
lord ^. LordId ==. deed ^. DeedOwnerId)
|
||||
groupBy (lord ^. LordId)
|
||||
return (lord ^. LordId, count (deed ^. DeedId))
|
||||
(ret :: [(Value (Key Lord), Value Int)]) <- select q
|
||||
liftIO $ ret `shouldMatchList` [ (Value l3k, Value 7)
|
||||
, (Value l1k, Value 3) ]
|
||||
|
||||
it "flattens maybe values" $ do
|
||||
run $ do
|
||||
l1k <- insert l1
|
||||
l3k <- insert l3
|
||||
let q = do
|
||||
(lord :& (_, dogCounts)) <- Experimental.from $ Table @Lord
|
||||
`LeftOuterJoin` (SelectQuery $ do
|
||||
lord <- Experimental.from $ Table @Lord
|
||||
pure (lord ^. LordId, lord ^. LordDogs)
|
||||
)
|
||||
`Experimental.on` (\(lord :& (lordId, _)) ->
|
||||
just (lord ^. LordId) ==. lordId)
|
||||
groupBy (lord ^. LordId, dogCounts)
|
||||
return (lord ^. LordId, dogCounts)
|
||||
(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
|
||||
_ <- insert p1
|
||||
_ <- insert p2
|
||||
let q = Experimental.from $
|
||||
(SelectQuery $ do
|
||||
p <- Experimental.from $ Table @Person
|
||||
where_ $ not_ $ isNothing $ p ^. PersonAge
|
||||
return (p ^. PersonName))
|
||||
`Union`
|
||||
(SelectQuery $ do
|
||||
p <- Experimental.from $ Table @Person
|
||||
where_ $ isNothing $ p ^. PersonAge
|
||||
return (p ^. PersonName))
|
||||
`Union`
|
||||
(SelectQuery $ do
|
||||
p <- Experimental.from $ Table @Person
|
||||
where_ $ isNothing $ p ^. PersonAge
|
||||
return (p ^. PersonName))
|
||||
names <- select q
|
||||
liftIO $ names `shouldMatchList` [ (Value $ personName p1)
|
||||
, (Value $ personName p2) ]
|
||||
testSelectWhere :: Run -> Spec
|
||||
testSelectWhere run = do
|
||||
describe "select where_" $ do
|
||||
@ -2272,6 +2401,97 @@ testOnClauseOrder run = describe "On Clause Ordering" $ do
|
||||
on $ baz ^. BazId ==. shoop ^. ShoopBaz
|
||||
pure (f ^. FooName)
|
||||
|
||||
testExperimentalFrom :: Run -> Spec
|
||||
testExperimentalFrom run = do
|
||||
describe "Experimental From" $ do
|
||||
it "supports basic table queries" $ do
|
||||
run $ do
|
||||
p1e <- insert' p1
|
||||
_ <- insert' p2
|
||||
p3e <- insert' p3
|
||||
peopleWithAges <- select $ do
|
||||
people <- Experimental.from $ Table @Person
|
||||
where_ $ not_ $ isNothing $ people ^. PersonAge
|
||||
return people
|
||||
liftIO $ peopleWithAges `shouldMatchList` [p1e, p3e]
|
||||
|
||||
it "supports inner joins" $ do
|
||||
run $ do
|
||||
l1e <- insert' l1
|
||||
_ <- insert l2
|
||||
d1e <- insert' $ Deed "1" (entityKey l1e)
|
||||
d2e <- insert' $ Deed "2" (entityKey l1e)
|
||||
lordDeeds <- select $ do
|
||||
(lords :& deeds) <-
|
||||
Experimental.from $ Table @Lord
|
||||
`InnerJoin` Table @Deed
|
||||
`Experimental.on` (\(l :& d) -> l ^. LordId ==. d ^. DeedOwnerId)
|
||||
pure (lords, deeds)
|
||||
liftIO $ lordDeeds `shouldMatchList` [ (l1e, d1e)
|
||||
, (l1e, d2e)
|
||||
]
|
||||
|
||||
it "supports outer joins" $ do
|
||||
run $ do
|
||||
l1e <- insert' l1
|
||||
l2e <- insert' l2
|
||||
d1e <- insert' $ Deed "1" (entityKey l1e)
|
||||
d2e <- insert' $ Deed "2" (entityKey l1e)
|
||||
lordDeeds <- select $ do
|
||||
(lords :& deeds) <-
|
||||
Experimental.from $ Table @Lord
|
||||
`LeftOuterJoin` Table @Deed
|
||||
`Experimental.on` (\(l :& d) -> just (l ^. LordId) ==. d ?. DeedOwnerId)
|
||||
|
||||
pure (lords, deeds)
|
||||
liftIO $ lordDeeds `shouldMatchList` [ (l1e, Just d1e)
|
||||
, (l1e, Just d2e)
|
||||
, (l2e, Nothing)
|
||||
]
|
||||
it "supports delete" $ do
|
||||
run $ do
|
||||
insert_ l1
|
||||
insert_ l2
|
||||
insert_ l3
|
||||
delete $ void $ Experimental.from $ Table @Lord
|
||||
lords <- select $ Experimental.from $ Table @Lord
|
||||
liftIO $ lords `shouldMatchList` []
|
||||
|
||||
it "supports implicit cross joins" $ do
|
||||
run $ do
|
||||
l1e <- insert' l1
|
||||
l2e <- insert' l2
|
||||
ret <- select $ do
|
||||
lords1 <- Experimental.from $ Table @Lord
|
||||
lords2 <- Experimental.from $ Table @Lord
|
||||
pure (lords1, lords2)
|
||||
ret2 <- select $ do
|
||||
(lords1 :& lords2) <- Experimental.from $ Table @Lord `CrossJoin` Table @Lord
|
||||
pure (lords1,lords2)
|
||||
liftIO $ ret `shouldMatchList` ret2
|
||||
liftIO $ ret `shouldMatchList` [ (l1e, l1e)
|
||||
, (l1e, l2e)
|
||||
, (l2e, l1e)
|
||||
, (l2e, l2e)
|
||||
]
|
||||
|
||||
|
||||
it "compiles" $ do
|
||||
run $ void $ do
|
||||
let q = do
|
||||
(persons :& profiles :& posts) <-
|
||||
Experimental.from $ Table @Person
|
||||
`InnerJoin` Table @Profile
|
||||
`Experimental.on` (\(people :& profiles) ->
|
||||
people ^. PersonId ==. profiles ^. ProfilePerson)
|
||||
`LeftOuterJoin` Table @BlogPost
|
||||
`Experimental.on` (\(people :& _ :& posts) ->
|
||||
just (people ^. PersonId) ==. posts ?. BlogPostAuthorId)
|
||||
pure (persons, posts, profiles)
|
||||
--error . show =<< renderQuerySelect q
|
||||
pure ()
|
||||
|
||||
|
||||
listsEqualOn :: (Show a1, Eq a1) => [a2] -> [a2] -> (a2 -> a1) -> Expectation
|
||||
listsEqualOn a b f = map f a `shouldBe` map f b
|
||||
|
||||
@ -2283,6 +2503,7 @@ tests run = do
|
||||
testSelectSource run
|
||||
testSelectFrom run
|
||||
testSelectJoin run
|
||||
testSelectSubQuery run
|
||||
testSelectWhere run
|
||||
testSelectOrderBy run
|
||||
testSelectDistinct run
|
||||
@ -2297,6 +2518,7 @@ tests run = do
|
||||
testCountingRows run
|
||||
testRenderSql run
|
||||
testOnClauseOrder run
|
||||
testExperimentalFrom run
|
||||
|
||||
|
||||
insert' :: ( Functor m
|
||||
|
||||
6
test/new-join-compiler-errors/README.md
Normal file
6
test/new-join-compiler-errors/README.md
Normal file
@ -0,0 +1,6 @@
|
||||
# expected-compile-failures
|
||||
|
||||
This subdirectory contains a stack project for expected compilation failures. To
|
||||
add a new "test case", create a new `executable` stanza in the `package.yaml`
|
||||
file. The Travis CI test script ([`test.sh`](test.sh)) will attempt to compile
|
||||
the executable and will exit with an error if it successfully compiled.
|
||||
45
test/new-join-compiler-errors/bad-errors/Main.hs
Normal file
45
test/new-join-compiler-errors/bad-errors/Main.hs
Normal file
@ -0,0 +1,45 @@
|
||||
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
module Main where
|
||||
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
import Database.Esqueleto hiding (from,on)
|
||||
import Database.Esqueleto.Experimental
|
||||
import Database.Esqueleto.Internal.Language (Insertion)
|
||||
import Database.Persist.Sql (SqlWriteT)
|
||||
import Database.Persist.TH (mkDeleteCascade,
|
||||
mkMigrate, mkPersist,
|
||||
persistLowerCase, share,
|
||||
sqlSettings)
|
||||
|
||||
import Lib
|
||||
|
||||
main :: IO ()
|
||||
main = pure ()
|
||||
|
||||
-- Missing on condition leads to an unintelligeable error and points to the wrong spot
|
||||
missingOnConditionShouldFail :: MonadIO m => SqlPersistT m [(Entity Person, Entity BlogPost)]
|
||||
missingOnConditionShouldFail = select $ do
|
||||
(people :& blogPosts) <-
|
||||
from $ Table @Person
|
||||
`LeftOuterJoin` Table @BlogPost
|
||||
pure (people, blogPosts)
|
||||
|
||||
-- Mismatched union when one part is returning a different shape than the other
|
||||
mismatchedUnion :: MonadIO m => SqlPersistT m [(Value String, Value (Maybe Int))]
|
||||
mismatchedUnion = select . from $
|
||||
(SelectQuery $ do
|
||||
people <- from $ Table @Person
|
||||
pure (people ^. PersonName, people ^. PersonAge))
|
||||
`Union`
|
||||
(SelectQuery $ do
|
||||
people <- from $ Table @Person
|
||||
pure (people ^. PersonName))
|
||||
|
||||
incorrectNumberOfOnElements = select . from $
|
||||
Table @Person
|
||||
`LeftOuterJoin` Table @Follow
|
||||
`on` (\(people :& follows) -> just (people ^. PersonId) ==. follows ?. FollowFollowed)
|
||||
`LeftOuterJoin` Table @Person
|
||||
`on` (\(follows :& followers) -> followers ?. PersonId ==. follows ?. FollowFollower)
|
||||
|
||||
55
test/new-join-compiler-errors/new-join-compiler-errors.cabal
Normal file
55
test/new-join-compiler-errors/new-join-compiler-errors.cabal
Normal file
@ -0,0 +1,55 @@
|
||||
cabal-version: 1.12
|
||||
|
||||
-- This file has been generated from package.yaml by hpack version 0.31.2.
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: 2bf9103f4701fb3c063743dbb88970ee68ecbeaeb87eea96ca21096da1264968
|
||||
|
||||
name: new-join-compiler-errors
|
||||
version: 0.1.0.0
|
||||
description: Please see the README on GitHub at <https://github.com/bitemyapp/esqueleto/test/new-join-compiler-errors#readme>
|
||||
homepage: https://github.com/bitemyapp/esqueleto#readme
|
||||
bug-reports: https://github.com/bitemyapp/esqueleto/issues
|
||||
author: Ben Levy
|
||||
maintainer: benjaminlevy007@gmail.com
|
||||
copyright: 2020 Ben Levy
|
||||
license: BSD3
|
||||
build-type: Simple
|
||||
extra-source-files:
|
||||
README.md
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: https://github.com/bitemyapp/esqueleto
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
Lib
|
||||
other-modules:
|
||||
Paths_new_join_compiler_errors
|
||||
hs-source-dirs:
|
||||
src
|
||||
default-extensions: FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses NoMonomorphismRestriction OverloadedStrings QuasiQuotes ScopedTypeVariables StandaloneDeriving TemplateHaskell TypeFamilies
|
||||
build-depends:
|
||||
base >=4.7 && <5
|
||||
, esqueleto
|
||||
, persistent
|
||||
, persistent-template
|
||||
default-language: Haskell2010
|
||||
|
||||
executable bad-errors
|
||||
main-is: Main.hs
|
||||
other-modules:
|
||||
Paths_new_join_compiler_errors
|
||||
hs-source-dirs:
|
||||
bad-errors
|
||||
default-extensions: FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses NoMonomorphismRestriction OverloadedStrings QuasiQuotes ScopedTypeVariables StandaloneDeriving TemplateHaskell TypeFamilies
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||
build-depends:
|
||||
base >=4.7 && <5
|
||||
, esqueleto
|
||||
, new-join-compiler-errors
|
||||
, persistent
|
||||
, persistent-template
|
||||
default-language: Haskell2010
|
||||
46
test/new-join-compiler-errors/package.yaml
Normal file
46
test/new-join-compiler-errors/package.yaml
Normal file
@ -0,0 +1,46 @@
|
||||
name: new-join-compiler-errors
|
||||
version: 0.1.0.0
|
||||
github: bitemyapp/esqueleto
|
||||
license: BSD3
|
||||
author: Ben Levy
|
||||
maintainer: benjaminlevy007@gmail.com
|
||||
copyright: 2020 Ben Levy
|
||||
|
||||
extra-source-files:
|
||||
- README.md
|
||||
|
||||
description: Please see the README on GitHub at <https://github.com/bitemyapp/esqueleto/test/new-join-compiler-errors#readme>
|
||||
|
||||
dependencies:
|
||||
- base >= 4.7 && < 5
|
||||
- esqueleto
|
||||
- persistent
|
||||
- persistent-template
|
||||
|
||||
default-extensions:
|
||||
- FlexibleContexts
|
||||
- FlexibleInstances
|
||||
- GADTs
|
||||
- GeneralizedNewtypeDeriving
|
||||
- MultiParamTypeClasses
|
||||
- NoMonomorphismRestriction
|
||||
- OverloadedStrings
|
||||
- QuasiQuotes
|
||||
- ScopedTypeVariables
|
||||
- StandaloneDeriving
|
||||
- TemplateHaskell
|
||||
- TypeFamilies
|
||||
|
||||
library:
|
||||
source-dirs: src
|
||||
|
||||
executables:
|
||||
bad-errors:
|
||||
main: Main.hs
|
||||
source-dirs: bad-errors
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -rtsopts
|
||||
- -with-rtsopts=-N
|
||||
dependencies:
|
||||
- new-join-compiler-errors
|
||||
33
test/new-join-compiler-errors/src/Lib.hs
Normal file
33
test/new-join-compiler-errors/src/Lib.hs
Normal file
@ -0,0 +1,33 @@
|
||||
{-# LANGUAGE UndecidableInstances, DerivingStrategies #-}
|
||||
module Lib where
|
||||
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
import Database.Persist
|
||||
import Database.Persist.Sql (SqlReadT)
|
||||
import Database.Esqueleto (SqlExpr, SqlQuery, from,
|
||||
val, (<#), insertSelect, (<&>), (^.))
|
||||
import Database.Esqueleto.Internal.Language (Insertion)
|
||||
import Database.Persist.TH (mkDeleteCascade,
|
||||
mkMigrate, mkPersist,
|
||||
persistLowerCase, share,
|
||||
sqlSettings)
|
||||
|
||||
share [ mkPersist sqlSettings
|
||||
, mkDeleteCascade sqlSettings
|
||||
, mkMigrate "migrateAll"] [persistLowerCase|
|
||||
Person
|
||||
name String
|
||||
age Int Maybe
|
||||
born Int Maybe
|
||||
deriving Eq Show
|
||||
BlogPost
|
||||
title String
|
||||
authorId PersonId
|
||||
deriving Eq Show
|
||||
Follow
|
||||
follower PersonId
|
||||
followed PersonId
|
||||
deriving Eq Show
|
||||
|]
|
||||
|
||||
|
||||
16
test/new-join-compiler-errors/stack.yaml
Normal file
16
test/new-join-compiler-errors/stack.yaml
Normal file
@ -0,0 +1,16 @@
|
||||
resolver: lts-13.6
|
||||
|
||||
packages:
|
||||
- .
|
||||
- ../../../esqueleto
|
||||
|
||||
extra-deps:
|
||||
- aeson-1.4.1.0
|
||||
- persistent-2.10.0
|
||||
- persistent-mysql-2.10.0
|
||||
- persistent-postgresql-2.10.0
|
||||
- persistent-sqlite-2.10.0
|
||||
- persistent-template-2.7.0
|
||||
- postgresql-libpq-0.9.4.2
|
||||
- postgresql-simple-0.6.1
|
||||
- transformers-0.5.5.2
|
||||
Loading…
Reference in New Issue
Block a user