From 56e4b83e5ca93f027a8afd2858e4d86f393c23b6 Mon Sep 17 00:00:00 2001 From: Ben Levy Date: Sun, 29 Mar 2020 11:40:49 -0500 Subject: [PATCH] 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 Co-authored-by: charukiewicz Co-authored-by: Matt Parsons --- esqueleto.cabal | 1 + src/Database/Esqueleto.hs | 2 +- src/Database/Esqueleto/Experimental.hs | 845 ++++++++++++++++++ src/Database/Esqueleto/Internal/Internal.hs | 287 ++++-- test/Common/Test.hs | 226 ++++- test/new-join-compiler-errors/README.md | 6 + .../bad-errors/Main.hs | 45 + .../new-join-compiler-errors.cabal | 55 ++ test/new-join-compiler-errors/package.yaml | 46 + test/new-join-compiler-errors/src/Lib.hs | 33 + test/new-join-compiler-errors/stack.yaml | 16 + 11 files changed, 1502 insertions(+), 60 deletions(-) create mode 100644 src/Database/Esqueleto/Experimental.hs create mode 100644 test/new-join-compiler-errors/README.md create mode 100644 test/new-join-compiler-errors/bad-errors/Main.hs create mode 100644 test/new-join-compiler-errors/new-join-compiler-errors.cabal create mode 100644 test/new-join-compiler-errors/package.yaml create mode 100644 test/new-join-compiler-errors/src/Lib.hs create mode 100644 test/new-join-compiler-errors/stack.yaml diff --git a/esqueleto.cabal b/esqueleto.cabal index 7dcb29c..2645f28 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -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 diff --git a/src/Database/Esqueleto.hs b/src/Database/Esqueleto.hs index 4b074d9..3268202 100644 --- a/src/Database/Esqueleto.hs +++ b/src/Database/Esqueleto.hs @@ -77,8 +77,8 @@ module Database.Esqueleto , LeftOuterJoin(..) , RightOuterJoin(..) , FullOuterJoin(..) + , JoinKind(..) , OnClauseWithoutMatchingJoinException(..) - -- * SQL backend , SqlQuery , SqlExpr diff --git a/src/Database/Esqueleto/Experimental.hs b/src/Database/Esqueleto/Experimental.hs new file mode 100644 index 0000000..bdec319 --- /dev/null +++ b/src/Database/Esqueleto/Experimental.hs @@ -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) diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index 1a8b717..9a616ca 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -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. -- diff --git a/test/Common/Test.hs b/test/Common/Test.hs index 820c21e..d45a401 100644 --- a/test/Common/Test.hs +++ b/test/Common/Test.hs @@ -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 diff --git a/test/new-join-compiler-errors/README.md b/test/new-join-compiler-errors/README.md new file mode 100644 index 0000000..b04a1cd --- /dev/null +++ b/test/new-join-compiler-errors/README.md @@ -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. diff --git a/test/new-join-compiler-errors/bad-errors/Main.hs b/test/new-join-compiler-errors/bad-errors/Main.hs new file mode 100644 index 0000000..a20a0c9 --- /dev/null +++ b/test/new-join-compiler-errors/bad-errors/Main.hs @@ -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) + diff --git a/test/new-join-compiler-errors/new-join-compiler-errors.cabal b/test/new-join-compiler-errors/new-join-compiler-errors.cabal new file mode 100644 index 0000000..e118ad0 --- /dev/null +++ b/test/new-join-compiler-errors/new-join-compiler-errors.cabal @@ -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 +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 diff --git a/test/new-join-compiler-errors/package.yaml b/test/new-join-compiler-errors/package.yaml new file mode 100644 index 0000000..39a7202 --- /dev/null +++ b/test/new-join-compiler-errors/package.yaml @@ -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 + +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 diff --git a/test/new-join-compiler-errors/src/Lib.hs b/test/new-join-compiler-errors/src/Lib.hs new file mode 100644 index 0000000..3b08a4d --- /dev/null +++ b/test/new-join-compiler-errors/src/Lib.hs @@ -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 +|] + + diff --git a/test/new-join-compiler-errors/stack.yaml b/test/new-join-compiler-errors/stack.yaml new file mode 100644 index 0000000..7c32e5c --- /dev/null +++ b/test/new-join-compiler-errors/stack.yaml @@ -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