From dd8814e67807af8b0d447bcc599f00958ddeb779 Mon Sep 17 00:00:00 2001 From: belevy Date: Thu, 11 Feb 2021 11:43:16 -0600 Subject: [PATCH] Convert all of experimental to use new From type instead of From type class. Make the data constructors second class, functions should be used. Introduce *Lateral functions, using the same type for lateral and non lateral queries was probably a mistake. --- src/Database/Esqueleto/Experimental.hs | 2 +- src/Database/Esqueleto/Experimental/From.hs | 143 +++---- .../From/CommonTableExpression.hs | 54 +-- .../Esqueleto/Experimental/From/Join.hs | 360 ++++++++++-------- .../Experimental/From/SqlSetOperation.hs | 265 ++++--------- 5 files changed, 375 insertions(+), 449 deletions(-) diff --git a/src/Database/Esqueleto/Experimental.hs b/src/Database/Esqueleto/Experimental.hs index 3b83f40..fcf2ec6 100644 --- a/src/Database/Esqueleto/Experimental.hs +++ b/src/Database/Esqueleto/Experimental.hs @@ -47,7 +47,7 @@ module Database.Esqueleto.Experimental , ToAliasT , ToAliasReference(..) , ToAliasReferenceT - , ToSetOperation(..) + , ToSqlSetOperation(..) , ValidOnClauseValue -- * The Normal Stuff diff --git a/src/Database/Esqueleto/Experimental/From.hs b/src/Database/Esqueleto/Experimental/From.hs index d8e5c8c..74e7fe0 100644 --- a/src/Database/Esqueleto/Experimental/From.hs +++ b/src/Database/Esqueleto/Experimental/From.hs @@ -1,28 +1,32 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module Database.Esqueleto.Experimental.From where -import qualified Control.Monad.Trans.Writer as W -import Data.Proxy -import qualified Data.Text.Lazy.Builder as TLB -import Database.Esqueleto.Experimental.ToAlias -import Database.Esqueleto.Experimental.ToAliasReference -import Database.Esqueleto.Internal.Internal hiding - (From (..), - from, on) -import Database.Esqueleto.Internal.PersistentImport +import Control.Arrow (first) +import Control.Monad (ap) +import qualified Control.Monad.Trans.Writer as W +import Data.Proxy +import qualified Data.Text.Lazy.Builder as TLB +import Database.Esqueleto.Experimental.ToAlias +import Database.Esqueleto.Experimental.ToAliasReference +import Database.Esqueleto.Internal.Internal hiding (From(..), from, on) +import Database.Esqueleto.Internal.PersistentImport -- | 'FROM' clause, used to bring entities into scope. -- @@ -33,16 +37,20 @@ import Database.Esqueleto.Internal.PersistentImport -- instances of `From`. This implementation eliminates certain -- types of runtime errors by preventing the construction of -- invalid SQL (e.g. illegal nested-@from@). -from :: From a => a -> SqlQuery (FromT a) -from parts = do - (a, clause) <- runFrom parts - Q $ W.tell mempty{sdFromClause=[FromRaw clause]} +from :: ToFrom a a' => a -> SqlQuery a' +from f = do + (a, clause) <- unFrom (toFrom f) + Q $ W.tell mempty{sdFromClause=[FromRaw $ clause]} pure a type RawFn = NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue]) -class From a where - type FromT a - runFrom :: a -> SqlQuery (FromT a, RawFn) +newtype From a = From + { unFrom :: SqlQuery (a, RawFn)} + +class ToFrom a r | a -> r where + toFrom :: a -> From r +instance ToFrom (From a) a where + toFrom = id -- | Data type for bringing a Table into scope in a JOIN tree -- @@ -50,63 +58,35 @@ class From a where -- select $ from $ Table \@People -- @ data Table a = Table +instance PersistEntity ent => ToFrom (Table ent) (SqlExpr (Entity ent)) where + toFrom _ = table -instance PersistEntity a => From (Table a) where - type FromT (Table a) = SqlExpr (Entity a) - runFrom e@Table = do - let ed = entityDef $ getVal e - ident <- newIdentFor (entityDB ed) - let entity = unsafeSqlEntity ident - pure $ ( entity, \p -> base p ident ed ) - where - getVal :: Table ent -> Proxy ent - getVal = const Proxy - - base _ ident@(I identText) def info = - let db@(DBName dbText) = entityDB def - in ( fromDBName info db <> - if dbText == identText - then mempty - else " AS " <> useIdent info ident - , mempty - ) +table :: forall ent. PersistEntity ent => From (SqlExpr (Entity ent)) +table = From $ do + let ed = entityDef (Proxy @ent) + ident <- newIdentFor (entityDB ed) + let entity = unsafeSqlEntity ident + pure $ ( entity, const $ base ident ed ) + where + base ident@(I identText) def info = + let db@(DBName dbText) = entityDB def + in ( fromDBName info db <> + if dbText == identText + then mempty + else " AS " <> useIdent info ident + , mempty + ) {-# DEPRECATED SubQuery "/Since: 3.4.0.0/ - It is no longer necessary to tag 'SqlQuery' values with @SubQuery@" #-} newtype SubQuery a = SubQuery a +instance (SqlSelect a r, ToAlias a, ToAliasReference a) => ToFrom (SubQuery (SqlQuery a)) a where + toFrom (SubQuery q) = selectQuery q +instance (SqlSelect a r, ToAlias a, ToAliasReference a) => ToFrom (SqlQuery a) a where + toFrom = selectQuery -instance - ( ToAlias a - , ToAliasReference a - , SqlSelect a r - ) - => - From (SqlQuery a) - where - type FromT (SqlQuery a) = a - runFrom subquery = - fromSubQuery NormalSubQuery subquery - -instance - ( ToAlias a - , ToAliasReference a - , SqlSelect a r - ) - => - From (SubQuery (SqlQuery a)) - where - type FromT (SubQuery (SqlQuery a)) = a - runFrom (SubQuery subquery) = - fromSubQuery NormalSubQuery subquery - -fromSubQuery - :: - ( SqlSelect a r - , ToAlias a - , ToAliasReference a - ) - => SubQueryType -> SqlQuery a -> SqlQuery (a, RawFn) -fromSubQuery subqueryType subquery = do +selectQuery :: (SqlSelect a r, ToAlias a, ToAliasReference a) => SqlQuery a -> From a +selectQuery subquery = From $ do -- We want to update the IdentState without writing the query to side data (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ subquery aliasedValue <- toAlias ret @@ -121,13 +101,8 @@ fromSubQuery subqueryType subquery = do pure (ref, \_ info -> let (queryText,queryVals) = toRawSql SELECT info aliasedQuery - lateralKeyword = - case subqueryType of - NormalSubQuery -> "" - LateralSubQuery -> "LATERAL " in - ( lateralKeyword <> (parens queryText) <> " AS " <> useIdent info subqueryAlias + ( (parens queryText) <> " AS " <> useIdent info subqueryAlias , queryVals ) ) - diff --git a/src/Database/Esqueleto/Experimental/From/CommonTableExpression.hs b/src/Database/Esqueleto/Experimental/From/CommonTableExpression.hs index 8f5ff20..cd5a68c 100644 --- a/src/Database/Esqueleto/Experimental/From/CommonTableExpression.hs +++ b/src/Database/Esqueleto/Experimental/From/CommonTableExpression.hs @@ -1,26 +1,18 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} module Database.Esqueleto.Experimental.From.CommonTableExpression where -import qualified Control.Monad.Trans.Writer as W -import qualified Data.Text.Lazy.Builder as TLB -import Database.Esqueleto.Experimental.From -import Database.Esqueleto.Experimental.From.SqlSetOperation -import Database.Esqueleto.Experimental.ToAlias -import Database.Esqueleto.Experimental.ToAliasReference -import Database.Esqueleto.Internal.Internal hiding - (From (..), - from, on) -import Database.Esqueleto.Internal.PersistentImport (DBName (..)) - -data CommonTableExpression ref = CommonTableExpression Ident ref -instance From (CommonTableExpression ref) where - type FromT (CommonTableExpression ref) = ref - runFrom (CommonTableExpression ident ref) = - pure (ref, (\_ info -> (useIdent info ident, mempty))) +import qualified Control.Monad.Trans.Writer as W +import qualified Data.Text.Lazy.Builder as TLB +import Database.Esqueleto.Experimental.From +import Database.Esqueleto.Experimental.From.SqlSetOperation +import Database.Esqueleto.Experimental.ToAlias +import Database.Esqueleto.Experimental.ToAliasReference +import Database.Esqueleto.Internal.Internal hiding (From(..), from, on) +import Database.Esqueleto.Internal.PersistentImport (DBName(..)) -- | @WITH@ clause used to introduce a [Common Table Expression (CTE)](https://en.wikipedia.org/wiki/Hierarchical_and_recursive_queries_in_SQL#Common_table_expression). -- CTEs are supported in most modern SQL engines and can be useful @@ -46,7 +38,7 @@ instance From (CommonTableExpression ref) where with :: ( ToAlias a , ToAliasReference a , SqlSelect a r - ) => SqlQuery a -> SqlQuery (CommonTableExpression a) + ) => SqlQuery a -> SqlQuery (From a) with query = do (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ query aliasedValue <- toAlias ret @@ -55,7 +47,7 @@ with query = do let clause = CommonTableExpressionClause NormalCommonTableExpression ident (\info -> toRawSql SELECT info aliasedQuery) Q $ W.tell mempty{sdCteClause = [clause]} ref <- toAliasReference ident aliasedValue - pure $ CommonTableExpression ident ref + pure $ From $ pure (ref, (\_ info -> (useIdent info ident, mempty))) -- | @WITH@ @RECURSIVE@ allows one to make a recursive subquery, which can -- reference itself. Like @WITH@, this is supported in most modern SQL engines. @@ -92,33 +84,29 @@ with query = do withRecursive :: ( ToAlias a , ToAliasReference a , SqlSelect a r - , RecursiveCteUnion unionKind ) => SqlQuery a - -> unionKind - -> (CommonTableExpression a -> SqlQuery a) - -> SqlQuery (CommonTableExpression a) + -> UnionKind + -> (From a -> SqlQuery a) + -> SqlQuery (From a) withRecursive baseCase unionKind recursiveCase = do (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ baseCase aliasedValue <- toAlias ret let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData) ident <- newIdentFor (DBName "cte") ref <- toAliasReference ident aliasedValue - let refFrom = CommonTableExpression ident ref + let refFrom = From (pure (ref, (\_ info -> (useIdent info ident, mempty)))) let recursiveQuery = recursiveCase refFrom let clause = CommonTableExpressionClause RecursiveCommonTableExpression ident (\info -> (toRawSql SELECT info aliasedQuery) - <> (unionKeyword unionKind, mempty) + <> ("\n" <> (unUnionKind unionKind) <> "\n", mempty) <> (toRawSql SELECT info recursiveQuery) ) Q $ W.tell mempty{sdCteClause = [clause]} pure refFrom -class RecursiveCteUnion a where - unionKeyword :: a -> TLB.Builder - -instance RecursiveCteUnion (a -> b -> Union a b) where - unionKeyword _ = "\nUNION\n" - -instance RecursiveCteUnion (a -> b -> UnionAll a b) where - unionKeyword _ = "\nUNION ALL\n" +newtype UnionKind = UnionKind { unUnionKind :: TLB.Builder } +instance Union_ UnionKind where + union_ = UnionKind "UNION" +instance UnionAll_ UnionKind where + unionAll_ = UnionKind "UNION ALL" diff --git a/src/Database/Esqueleto/Experimental/From/Join.hs b/src/Database/Esqueleto/Experimental/From/Join.hs index 67b8aa3..6b16823 100644 --- a/src/Database/Esqueleto/Experimental/From/Join.hs +++ b/src/Database/Esqueleto/Experimental/From/Join.hs @@ -1,7 +1,11 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -12,13 +16,16 @@ module Database.Esqueleto.Experimental.From.Join import Data.Bifunctor (first) import Data.Kind (Constraint) import Data.Proxy +import qualified Data.Text.Lazy.Builder as TLB import Database.Esqueleto.Experimental.From import Database.Esqueleto.Experimental.From.SqlSetOperation import Database.Esqueleto.Experimental.ToAlias import Database.Esqueleto.Experimental.ToAliasReference import Database.Esqueleto.Experimental.ToMaybe -import Database.Esqueleto.Internal.Internal hiding (From(..), from, on) -import Database.Esqueleto.Internal.PersistentImport (Entity(..)) +import Database.Esqueleto.Internal.Internal hiding + (From(..), from, fromJoin, on) +import Database.Esqueleto.Internal.PersistentImport + (Entity(..), EntityField, PersistEntity, PersistField) import GHC.TypeLits -- | A left-precedence pair. Pronounced \"and\". Used to represent expressions @@ -35,6 +42,10 @@ import GHC.TypeLits data (:&) a b = a :& b infixl 2 :& +instance (ToMaybe a, ToMaybe b) => ToMaybe (a :& b) where + type ToMaybeT (a :& b) = (ToMaybeT a :& ToMaybeT b) + toMaybe (a :& b) = (toMaybe a :& toMaybe b) + -- | Constraint for `on`. Ensures that only types that require an `on` can be used on -- the left hand side. This was previously reusing the From class which was actually -- a bit too lenient as it allowed to much. @@ -46,6 +57,7 @@ type family ValidOnClauseValue a :: Constraint where ValidOnClauseValue (SqlQuery a) = () ValidOnClauseValue (SqlSetOperation a) = () ValidOnClauseValue (a -> SqlQuery b) = () + ValidOnClauseValue (From a) = () ValidOnClauseValue _ = TypeError ('Text "Illegal use of ON") -- | An @ON@ clause that describes how two tables are related. This should be @@ -62,183 +74,233 @@ on :: ValidOnClauseValue a => a -> (b -> SqlExpr (Value Bool)) -> (a, b -> SqlEx on = (,) infix 9 `on` -data Lateral -data NotLateral - -type family IsLateral a where - IsLateral (a -> SqlQuery b) = Lateral - IsLateral a = NotLateral - type family ErrorOnLateral a :: Constraint where ErrorOnLateral (a -> SqlQuery b) = TypeError ('Text "LATERAL can only be used for INNER, LEFT, and CROSS join kinds.") ErrorOnLateral _ = () --- Type class magic to allow the use of the `InnerJoin` family of data constructors in from -type family FromOnClause a where - FromOnClause (a, b -> SqlExpr (Value Bool)) = b - FromOnClause a = TypeError ('Text "Missing ON clause") - -instance {-# OVERLAPPABLE #-} From (InnerJoin a b) where - type FromT (InnerJoin a b) = FromOnClause b - runFrom = undefined -instance {-# OVERLAPPABLE #-} From (LeftOuterJoin a b) where - type FromT (LeftOuterJoin a b) = FromOnClause b - runFrom = undefined -instance {-# OVERLAPPABLE #-} From (RightOuterJoin a b) where - type FromT (RightOuterJoin a b) = FromOnClause b - runFrom = undefined -instance {-# OVERLAPPABLE #-} From (FullOuterJoin a b) where - type FromT (FullOuterJoin a b) = FromOnClause b - runFrom = undefined - -class FromInnerJoin lateral lhs rhs res where - runFromInnerJoin :: Proxy lateral -> lhs -> rhs -> (res -> SqlExpr (Value Bool)) -> SqlQuery (res, RawFn) - -fromJoin_ :: RawFn -> JoinKind -> RawFn -> Maybe (SqlExpr (Value Bool)) -> RawFn -fromJoin_ lhs kind rhs monClause = +fromJoin :: TLB.Builder -> RawFn -> RawFn -> Maybe (SqlExpr (Value Bool)) -> RawFn +fromJoin joinKind lhs rhs monClause = \paren info -> first (parensM paren) $ mconcat [ lhs Never info - , (fromKind kind, mempty) + , (joinKind, mempty) , rhs Parens info , maybe mempty (makeOnClause info) monClause ] where - fromKind InnerJoinKind = " INNER JOIN " - fromKind CrossJoinKind = " CROSS JOIN " - fromKind LeftOuterJoinKind = " LEFT OUTER JOIN " - fromKind RightOuterJoinKind = " RIGHT OUTER JOIN " - fromKind FullOuterJoinKind = " FULL OUTER JOIN " - makeOnClause info (ERaw _ f) = first (" ON " <>) (f Never info) -instance ( SqlSelect b r - , ToAlias b - , ToAliasReference b - , From a - , FromT a ~ a' - ) => FromInnerJoin Lateral a (a' -> SqlQuery b) (a' :& b) where - runFromInnerJoin _ leftPart q on' = do - (leftVal, leftFrom) <- runFrom leftPart - (rightVal, rightFrom) <- fromSubQuery LateralSubQuery (q leftVal) - let ret = leftVal :& rightVal - pure $ (ret, fromJoin_ leftFrom InnerJoinKind rightFrom (Just (on' ret))) +type family HasOnClause actual expected :: Constraint where + HasOnClause (a, b -> SqlExpr (Value Bool)) c = () -- Let the compiler handle the type mismatch + HasOnClause a expected = + TypeError ( 'Text "Missing ON clause for join with" + ':$$: 'ShowType a + ':$$: 'Text "" + ':$$: 'Text "Expected: " + ':$$: 'ShowType a + ':$$: 'Text "`on` " ':<>: 'ShowType (expected -> SqlExpr (Value Bool)) + ':$$: 'Text "" + ) -instance (From a, FromT a ~ a', From b, FromT b ~ b') - => FromInnerJoin NotLateral a b (a' :& b') where - runFromInnerJoin _ 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))) -instance (FromInnerJoin (IsLateral b) a b b') => From (InnerJoin a (b, b' -> SqlExpr (Value Bool))) where - type FromT (InnerJoin a (b, b' -> SqlExpr (Value Bool))) = FromOnClause (b, b' -> SqlExpr(Value Bool)) - runFrom (InnerJoin lhs (rhs, on')) = runFromInnerJoin (toProxy rhs) lhs rhs on' - where - toProxy :: b -> Proxy (IsLateral b) - toProxy _ = Proxy +innerJoin :: ( ToFrom a a' + , ToFrom b b' + , HasOnClause rhs (a' :& b') + , rhs ~ (b, (a' :& b') -> SqlExpr (Value Bool)) + ) => a -> rhs -> From (a' :& b') +innerJoin lhs (rhs, on') = From $ do + (leftVal, leftFrom) <- unFrom (toFrom lhs) + (rightVal, rightFrom) <- unFrom (toFrom rhs) + let ret = leftVal :& rightVal + pure $ (ret, fromJoin " INNER JOIN " leftFrom rightFrom (Just $ on' ret)) -type family FromCrossJoin a b where - FromCrossJoin a (b -> SqlQuery c) = FromT a :& c - FromCrossJoin a b = FromT a :& FromT b -instance ( From a - , From b - , FromT (CrossJoin a b) ~ (FromT a :& FromT b) - ) => From (CrossJoin a b) where - type FromT (CrossJoin a b) = FromCrossJoin a b - runFrom (CrossJoin leftPart rightPart) = do - (leftVal, leftFrom) <- runFrom leftPart - (rightVal, rightFrom) <- runFrom rightPart - let ret = leftVal :& rightVal - pure $ (ret, fromJoin_ leftFrom CrossJoinKind rightFrom Nothing) +innerJoinLateral :: ( ToFrom a a' + , HasOnClause rhs (a' :& b) + , SqlSelect b r + , ToAlias b + , ToAliasReference b + , rhs ~ (a' -> SqlQuery b, (a' :& b) -> SqlExpr (Value Bool)) + ) + => a -> rhs -> From (a' :& b) +innerJoinLateral lhs (rhsFn, on') = From $ do + (leftVal, leftFrom) <- unFrom (toFrom lhs) + (rightVal, rightFrom) <- unFrom (selectQuery (rhsFn leftVal)) + let ret = leftVal :& rightVal + pure $ (ret, fromJoin " INNER JOIN LATERAL " leftFrom rightFrom (Just $ on' ret)) -instance {-# OVERLAPPING #-} - ( From a - , FromT a ~ a' +crossJoin :: ( ToFrom a a' + , ToFrom b b' + ) => a -> b -> From (a' :& b') +crossJoin lhs rhs = From $ do + (leftVal, leftFrom) <- unFrom (toFrom lhs) + (rightVal, rightFrom) <- unFrom (toFrom rhs) + let ret = leftVal :& rightVal + pure $ (ret, fromJoin " CROSS JOIN " leftFrom rightFrom Nothing) + +crossJoinLateral :: ( ToFrom a a' + , SqlSelect b r + , ToAlias b + , ToAliasReference b + ) + => a -> (a' -> SqlQuery b) -> From (a' :& b) +crossJoinLateral lhs rhsFn = From $ do + (leftVal, leftFrom) <- unFrom (toFrom lhs) + (rightVal, rightFrom) <- unFrom (selectQuery (rhsFn leftVal)) + let ret = leftVal :& rightVal + pure $ (ret, fromJoin " CROSS JOIN LATERAL " leftFrom rightFrom Nothing) + +leftJoin :: ( ToFrom a a' + , ToFrom b b' + , ToMaybe b' + , HasOnClause rhs (a' :& ToMaybeT b') + , rhs ~ (b, (a' :& ToMaybeT b') -> SqlExpr (Value Bool)) + ) => a -> rhs -> From (a' :& ToMaybeT b') +leftJoin lhs (rhs, on') = From $ do + (leftVal, leftFrom) <- unFrom (toFrom lhs) + (rightVal, rightFrom) <- unFrom (toFrom rhs) + let ret = leftVal :& toMaybe rightVal + pure $ (ret, fromJoin " LEFT OUTER JOIN " leftFrom rightFrom (Just $ on' ret)) + +leftJoinLateral :: ( ToFrom a a' + , SqlSelect b r + , HasOnClause rhs (a' :& ToMaybeT b) + , ToAlias b + , ToAliasReference b + , ToMaybe b + , rhs ~ (a' -> SqlQuery b, (a' :& ToMaybeT b) -> SqlExpr (Value Bool)) + ) + => a -> rhs -> From (a' :& ToMaybeT b) +leftJoinLateral lhs (rhsFn, on') = From $ do + (leftVal, leftFrom) <- unFrom (toFrom lhs) + (rightVal, rightFrom) <- unFrom (selectQuery (rhsFn leftVal)) + let ret = leftVal :& toMaybe rightVal + pure $ (ret, fromJoin " LEFT OUTER JOIN LATERAL " leftFrom rightFrom (Just $ on' ret)) + +rightJoin :: ( ToFrom a a' + , ToFrom b b' + , ToMaybe a' + , HasOnClause rhs (ToMaybeT a' :& b') + , rhs ~ (b, (ToMaybeT a' :& b') -> SqlExpr (Value Bool)) + ) => a -> rhs -> From (ToMaybeT a' :& b') +rightJoin lhs (rhs, on') = From $ do + (leftVal, leftFrom) <- unFrom (toFrom lhs) + (rightVal, rightFrom) <- unFrom (toFrom rhs) + let ret = toMaybe leftVal :& rightVal + pure $ (ret, fromJoin " RIGHT OUTER JOIN " leftFrom rightFrom (Just $ on' ret)) + +fullOuterJoin :: ( ToFrom a a' + , ToFrom b b' + , ToMaybe a' + , ToMaybe b' + , HasOnClause rhs (ToMaybeT a' :& ToMaybeT b') + , rhs ~ (b, (ToMaybeT a' :& ToMaybeT b') -> SqlExpr (Value Bool)) + ) => a -> rhs -> From (ToMaybeT a' :& ToMaybeT b') +fullOuterJoin lhs (rhs, on') = From $ do + (leftVal, leftFrom) <- unFrom (toFrom lhs) + (rightVal, rightFrom) <- unFrom (toFrom rhs) + let ret = toMaybe leftVal :& toMaybe rightVal + pure $ (ret, fromJoin " FULL OUTER JOIN " leftFrom rightFrom (Just $ on' ret)) + +infixl 2 `innerJoin`, + `innerJoinLateral`, + `leftJoin`, + `leftJoinLateral`, + `crossJoin`, + `crossJoinLateral`, + `rightJoin`, + `fullOuterJoin` + + +------ Compatibility for old syntax + +data Lateral +data NotLateral + +type family IsLateral a where + IsLateral (a -> SqlQuery b, c) = Lateral + IsLateral (a -> SqlQuery b) = Lateral + IsLateral a = NotLateral + +class DoInnerJoin lateral lhs rhs res | lateral rhs lhs -> res where + doInnerJoin :: Proxy lateral -> lhs -> rhs -> From res + +instance ( ToFrom a a' + , ToFrom b b' + , HasOnClause rhs (a' :& b') + , rhs ~ (b, (a' :& b') -> SqlExpr (Value Bool)) + ) => DoInnerJoin NotLateral a rhs (a' :& b') where + doInnerJoin _ = innerJoin + +instance ( ToFrom a a' , SqlSelect b r , ToAlias b , ToAliasReference b - ) => From (CrossJoin a (a' -> SqlQuery b)) where - type FromT (CrossJoin a (a' -> SqlQuery b)) = FromCrossJoin a (a' -> SqlQuery b) - runFrom (CrossJoin leftPart q) = do - (leftVal, leftFrom) <- runFrom leftPart - (rightVal, rightFrom) <- fromSubQuery LateralSubQuery (q leftVal) - let ret = leftVal :& rightVal - pure $ (ret, fromJoin_ leftFrom CrossJoinKind rightFrom Nothing) + , d ~ (a' :& b) + ) => DoInnerJoin Lateral a (a' -> SqlQuery b, d -> SqlExpr (Value Bool)) d where + doInnerJoin _ = innerJoinLateral -class FromLeftJoin lateral lhs rhs res where - runFromLeftJoin :: Proxy lateral -> lhs -> rhs -> (res -> SqlExpr (Value Bool)) -> SqlQuery (res, RawFn) +instance ( DoInnerJoin lateral lhs rhs r, lateral ~ IsLateral rhs ) + => ToFrom (InnerJoin lhs rhs) r where + toFrom (InnerJoin a b) = doInnerJoin (Proxy @lateral) a b -instance ( From a - , FromT a ~ a' - , SqlSelect b r - , ToAlias b - , ToAliasReference b +class DoLeftJoin lateral lhs rhs res | lateral rhs lhs -> res where + doLeftJoin :: Proxy lateral -> lhs -> rhs -> From res + +instance ( ToFrom a a' + , ToFrom b b' + , ToMaybe b' + , ToMaybeT b' ~ mb + , HasOnClause rhs (a' :& mb) + , rhs ~ (b, (a' :& mb) -> SqlExpr (Value Bool)) + ) => DoLeftJoin NotLateral a rhs (a' :& mb) where + doLeftJoin _ = leftJoin + +instance ( ToFrom a a' , ToMaybe b - , mb ~ ToMaybeT b - ) => FromLeftJoin Lateral a (a' -> SqlQuery b) (a' :& mb) where - runFromLeftJoin _ leftPart q on' = do - (leftVal, leftFrom) <- runFrom leftPart - (rightVal, rightFrom) <- fromSubQuery LateralSubQuery (q leftVal) - let ret = leftVal :& (toMaybe rightVal) - pure $ (ret, fromJoin_ leftFrom LeftOuterJoinKind rightFrom (Just (on' ret))) + , d ~ (a' :& ToMaybeT b) + , SqlSelect b r + , ToAlias b + , ToAliasReference b + ) => DoLeftJoin Lateral a (a' -> SqlQuery b, d -> SqlExpr (Value Bool)) d where + doLeftJoin _ = leftJoinLateral -instance ( From a - , FromT a ~ a' - , From b - , FromT b ~ b' - , ToMaybe b' - , mb ~ ToMaybeT b' - ) => FromLeftJoin NotLateral a b (a' :& mb) where - runFromLeftJoin _ 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))) +instance ( DoLeftJoin lateral lhs rhs r, lateral ~ IsLateral rhs ) + => ToFrom (LeftOuterJoin lhs rhs) r where + toFrom (LeftOuterJoin a b) = doLeftJoin (Proxy @lateral) a b -instance ( FromLeftJoin (IsLateral b) a b b' - ) => From (LeftOuterJoin a (b, b' -> SqlExpr (Value Bool))) where - type FromT (LeftOuterJoin a (b, b' -> SqlExpr (Value Bool))) = FromOnClause (b, b' -> SqlExpr(Value Bool)) - runFrom (LeftOuterJoin lhs (rhs, on')) = - runFromLeftJoin (toProxy rhs) lhs rhs on' - where - toProxy :: b -> Proxy (IsLateral b) - toProxy _ = Proxy +class DoCrossJoin lateral lhs rhs res | lateral lhs rhs -> res where + doCrossJoin :: Proxy lateral -> lhs -> rhs -> From res -instance ( From a - , FromT a ~ a' - , From b - , FromT b ~ b' +instance (ToFrom a a', ToFrom b b') => DoCrossJoin NotLateral a b (a' :& b') where + doCrossJoin _ = crossJoin +instance (ToFrom a a', SqlSelect b r, ToAlias b, ToAliasReference b) + => DoCrossJoin Lateral a (a' -> SqlQuery b) (a' :& b) where + doCrossJoin _ = crossJoinLateral + +instance (DoCrossJoin lateral lhs rhs r, IsLateral rhs ~ lateral) + => ToFrom (CrossJoin lhs rhs) r where + toFrom (CrossJoin a b) = doCrossJoin (Proxy @lateral) a b + +instance ( ToFrom a a' + , ToFrom b b' , ToMaybe a' - , ma ~ ToMaybeT a' - , ToMaybe b' - , mb ~ ToMaybeT b' + , ToMaybeT a' ~ ma + , HasOnClause rhs (ma :& b') , ErrorOnLateral b - ) => From (FullOuterJoin a (b, (ma :& mb) -> SqlExpr (Value Bool))) where - type FromT (FullOuterJoin a (b, (ma :& mb) -> SqlExpr (Value Bool))) = FromOnClause (b, (ma :& mb) -> SqlExpr(Value Bool)) - runFrom (FullOuterJoin 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))) + , rhs ~ (b, (ma :& b') -> SqlExpr (Value Bool)) + ) => ToFrom (RightOuterJoin a rhs) (ma :& b') where + toFrom (RightOuterJoin a b) = rightJoin a b -instance ( From a - , FromT a ~ a' +instance ( ToFrom a a' + , ToFrom b b' , ToMaybe a' - , ma ~ ToMaybeT a' - , From b - , FromT b ~ b' + , ToMaybeT a' ~ ma + , ToMaybe b' + , ToMaybeT b' ~ mb + , HasOnClause rhs (ma :& mb) , ErrorOnLateral b - ) => From (RightOuterJoin a (b, (ma :& b') -> SqlExpr (Value Bool))) where - type FromT (RightOuterJoin a (b, (ma :& b') -> SqlExpr (Value Bool))) = FromOnClause (b, (ma :& b') -> SqlExpr(Value Bool)) - runFrom (RightOuterJoin 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))) + , rhs ~ (b, (ma :& mb) -> SqlExpr (Value Bool)) + ) => ToFrom (FullOuterJoin a rhs) (ma :& mb) where + toFrom (FullOuterJoin a b) = fullOuterJoin a b -instance (ToMaybe a, ToMaybe b) => ToMaybe (a :& b) where - type ToMaybeT (a :& b) = (ToMaybeT a :& ToMaybeT b) - toMaybe (a :& b) = (toMaybe a :& toMaybe b) diff --git a/src/Database/Esqueleto/Experimental/From/SqlSetOperation.hs b/src/Database/Esqueleto/Experimental/From/SqlSetOperation.hs index 67413f4..1e54241 100644 --- a/src/Database/Esqueleto/Experimental/From/SqlSetOperation.hs +++ b/src/Database/Esqueleto/Experimental/From/SqlSetOperation.hs @@ -1,211 +1,112 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Database.Esqueleto.Experimental.From.SqlSetOperation where -import Control.Monad.Trans.Class (lift) -import qualified Control.Monad.Trans.State as S -import qualified Control.Monad.Trans.Writer as W -import qualified Data.Text.Lazy.Builder as TLB -import Database.Esqueleto.Experimental.From -import Database.Esqueleto.Experimental.ToAlias -import Database.Esqueleto.Experimental.ToAliasReference -import Database.Esqueleto.Internal.Internal hiding - (From (..), - from, on) -import Database.Esqueleto.Internal.PersistentImport (DBName (..), - PersistValue) +import Control.Arrow (first) +import Control.Monad.Trans.Class (lift) +import qualified Control.Monad.Trans.State as S +import qualified Control.Monad.Trans.Writer as W +import qualified Data.Text.Lazy.Builder as TLB +import Database.Esqueleto.Experimental.From +import Database.Esqueleto.Experimental.ToAlias +import Database.Esqueleto.Experimental.ToAliasReference +import Database.Esqueleto.Internal.Internal hiding (From(..), from, on) +import Database.Esqueleto.Internal.PersistentImport + (DBName(..), Entity, PersistEntity, PersistValue) -data SqlSetOperation a - = SqlSetUnion (SqlSetOperation a) (SqlSetOperation a) - | SqlSetUnionAll (SqlSetOperation a) (SqlSetOperation a) - | SqlSetExcept (SqlSetOperation a) (SqlSetOperation a) - | SqlSetIntersect (SqlSetOperation a) (SqlSetOperation a) - | SelectQueryP NeedParens (SqlQuery a) +newtype SqlSetOperation a = SqlSetOperation + { unSqlSetOperation :: NeedParens -> SqlQuery (a, IdentInfo -> (TLB.Builder, [PersistValue]))} -runSetOperation :: (SqlSelect a r, ToAlias a, ToAliasReference a) - => SqlSetOperation a -> SqlQuery (a, NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue])) -runSetOperation operation = do - (aliasedOperation, ret) <- aliasQueries operation - ident <- newIdentFor (DBName "u") - ref <- toAliasReference ident ret - pure ( ref - , \_ info -> - let (queryText, queryVals) = operationToSql aliasedOperation info - in (parens queryText <> " AS " <> useIdent info ident, queryVals) - ) +instance ToAliasReference a => ToFrom (SqlSetOperation a) a where + toFrom setOperation = From $ do + ident <- newIdentFor (DBName "u") + (a, fromClause) <- unSqlSetOperation setOperation Never + ref <- toAliasReference ident a + pure (ref, \_ info -> (first parens $ fromClause info) <> (" AS " <> useIdent info ident, mempty)) - where - aliasQueries o = - case o of - SelectQueryP p 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 - let p' = - case p of - Parens -> Parens - Never -> - if (sdLimitClause sideData) /= mempty - || length (sdOrderByClause sideData) > 0 then - Parens - else - Never - pure (SelectQueryP p' $ Q $ W.WriterT $ pure (aliasedRet, sideData), aliasedRet) - SqlSetUnion o1 o2 -> do - (o1', ret) <- aliasQueries o1 - (o2', _ ) <- aliasQueries o2 - pure (SqlSetUnion o1' o2', ret) - SqlSetUnionAll o1 o2 -> do - (o1', ret) <- aliasQueries o1 - (o2', _ ) <- aliasQueries o2 - pure (SqlSetUnionAll o1' o2', ret) - SqlSetExcept o1 o2 -> do - (o1', ret) <- aliasQueries o1 - (o2', _ ) <- aliasQueries o2 - pure (SqlSetExcept o1' o2', ret) - SqlSetIntersect o1 o2 -> do - (o1', ret) <- aliasQueries o1 - (o2', _ ) <- aliasQueries o2 - pure (SqlSetIntersect o1' o2', ret) - - operationToSql o info = - case o of - SelectQueryP p q -> - let (builder, values) = toRawSql SELECT info q - in (parensM p builder, values) - SqlSetUnion o1 o2 -> doSetOperation "UNION" info o1 o2 - SqlSetUnionAll o1 o2 -> doSetOperation "UNION ALL" info o1 o2 - SqlSetExcept o1 o2 -> doSetOperation "EXCEPT" info o1 o2 - SqlSetIntersect 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) +class ToSqlSetOperation a r | a -> r where + toSqlSetOperation :: a -> SqlSetOperation r +instance ToSqlSetOperation (SqlSetOperation a) a where + toSqlSetOperation = id +instance (SqlSelect a r, ToAlias a, ToAliasReference a) => ToSqlSetOperation (SqlQuery a) a where + toSqlSetOperation subquery = + SqlSetOperation $ \p -> do + (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ subquery + state <- Q $ lift S.get + aliasedValue <- toAlias ret + Q $ lift $ S.put state + let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData) + let p' = + case p of + Parens -> Parens + Never -> + if (sdLimitClause sideData) /= mempty + || length (sdOrderByClause sideData) > 0 then + Parens + else + Never + pure (aliasedValue, \info -> first (parensM p') $ toRawSql SELECT info aliasedQuery) +mkSetOperation :: (ToSqlSetOperation a a', ToSqlSetOperation b a') => TLB.Builder -> a -> b -> SqlSetOperation a' +mkSetOperation operation lhs rhs = SqlSetOperation $ \p -> do + (leftValue, leftClause) <- unSqlSetOperation (toSqlSetOperation lhs) p + (_, rightClause) <- unSqlSetOperation (toSqlSetOperation rhs) p + pure (leftValue, \info -> leftClause info <> (operation, mempty) <> rightClause info) {-# DEPRECATED Union "/Since: 3.4.0.0/ - Use the 'union_' function instead of the 'Union' data constructor" #-} data Union a b = a `Union` b +instance ToSqlSetOperation a a' => ToSqlSetOperation (Union a a) a' where + toSqlSetOperation (Union a b) = union_ a b --- | @UNION@ SQL set operation. Can be used as an infix function between 'SqlQuery' values. -union_ :: a -> b -> Union a b -union_ = Union + +class Union_ a where + -- | @UNION@ SQL set operation. Can be used as an infix function between 'SqlQuery' values. + union_ :: a + +instance (ToSqlSetOperation a c, ToSqlSetOperation b c, res ~ SqlSetOperation c) + => Union_ (a -> b -> res) where + union_ = mkSetOperation " UNION " + +class UnionAll_ a where + -- | @UNION@ @ALL@ SQL set operation. Can be used as an infix function between 'SqlQuery' values. + unionAll_ :: a +instance (ToSqlSetOperation a c, ToSqlSetOperation b c, res ~ SqlSetOperation c) + => UnionAll_ (a -> b -> res) where + unionAll_ = mkSetOperation " UNION ALL " {-# DEPRECATED UnionAll "/Since: 3.4.0.0/ - Use the 'unionAll_' function instead of the 'UnionAll' data constructor" #-} data UnionAll a b = a `UnionAll` b - --- | @UNION@ @ALL@ SQL set operation. Can be used as an infix function between 'SqlQuery' values. -unionAll_ :: a -> b -> UnionAll a b -unionAll_ = UnionAll +instance ToSqlSetOperation a a' => ToSqlSetOperation (UnionAll a a) a' where + toSqlSetOperation (UnionAll a b) = unionAll_ a b {-# DEPRECATED Except "/Since: 3.4.0.0/ - Use the 'except_' function instead of the 'Except' data constructor" #-} data Except a b = a `Except` b +instance ToSqlSetOperation a a' => ToSqlSetOperation (Except a a) a' where + toSqlSetOperation (Except a b) = except_ a b -- | @EXCEPT@ SQL set operation. Can be used as an infix function between 'SqlQuery' values. -except_ :: a -> b -> Except a b -except_ = Except +except_ :: (ToSqlSetOperation a a', ToSqlSetOperation b a') => a -> b -> SqlSetOperation a' +except_ = mkSetOperation " EXCEPT " {-# DEPRECATED Intersect "/Since: 3.4.0.0/ - Use the 'intersect_' function instead of the 'Intersect' data constructor" #-} data Intersect a b = a `Intersect` b +instance ToSqlSetOperation a a' => ToSqlSetOperation (Intersect a a) a' where + toSqlSetOperation (Intersect a b) = intersect_ a b -- | @INTERSECT@ SQL set operation. Can be used as an infix function between 'SqlQuery' values. -intersect_ :: a -> b -> Intersect a b -intersect_ = Intersect - -class SetOperationT a ~ b => ToSetOperation a b | a -> b where - type SetOperationT a - toSetOperation :: a -> SqlSetOperation b -instance ToSetOperation (SqlSetOperation a) a where - type SetOperationT (SqlSetOperation a) = a - toSetOperation = id -instance ToSetOperation (SqlQuery a) a where - type SetOperationT (SqlQuery a) = a - toSetOperation = SelectQueryP Never -instance (ToSetOperation a c, ToSetOperation b c) => ToSetOperation (Union a b) c where - type SetOperationT (Union a b) = SetOperationT a - toSetOperation (Union a b) = SqlSetUnion (toSetOperation a) (toSetOperation b) -instance (ToSetOperation a c, ToSetOperation b c) => ToSetOperation (UnionAll a b) c where - type SetOperationT (UnionAll a b) = SetOperationT a - toSetOperation (UnionAll a b) = SqlSetUnionAll (toSetOperation a) (toSetOperation b) -instance (ToSetOperation a c, ToSetOperation b c) => ToSetOperation (Except a b) c where - type SetOperationT (Except a b) = SetOperationT a - toSetOperation (Except a b) = SqlSetExcept (toSetOperation a) (toSetOperation b) -instance (ToSetOperation a c, ToSetOperation b c) => ToSetOperation (Intersect a b) c where - type SetOperationT (Intersect a b) = SetOperationT a - toSetOperation (Intersect a b) = SqlSetIntersect (toSetOperation a) (toSetOperation b) +intersect_ :: (ToSqlSetOperation a a', ToSqlSetOperation b a') => a -> b -> SqlSetOperation a' +intersect_ = mkSetOperation " INTERSECT " {-# DEPRECATED SelectQuery "/Since: 3.4.0.0/ - It is no longer necessary to tag 'SqlQuery' values with @SelectQuery@" #-} -pattern SelectQuery :: SqlQuery a -> SqlSetOperation a -pattern SelectQuery q = SelectQueryP Never q +pattern SelectQuery a = a -instance - ( SqlSelect c r - , ToAlias c - , ToAliasReference c - , ToSetOperation a c - , ToSetOperation b c - , c ~ SetOperationT a - ) - => - From (Union a b) - where - type FromT (Union a b) = SetOperationT a - runFrom u = runSetOperation $ toSetOperation u - -instance - ( SqlSelect c r - , ToAlias c - , ToAliasReference c - , ToSetOperation a c - , ToSetOperation b c - , c ~ SetOperationT a - ) - => - From (UnionAll a b) - where - type FromT (UnionAll a b) = SetOperationT a - runFrom u = runSetOperation $ toSetOperation u - -instance - ( SqlSelect c r - , ToAlias c - , ToAliasReference c - , ToSetOperation a c - , ToSetOperation b c - , c ~ SetOperationT a - ) - => - From (Intersect a b) - where - type FromT (Intersect a b) = SetOperationT a - runFrom u = runSetOperation $ toSetOperation u - -instance - ( SqlSelect c r - , ToAlias c - , ToAliasReference c - , ToSetOperation a c - , ToSetOperation b c - , c ~ SetOperationT a - ) - => - From (Except a b) - where - type FromT (Except a b) = SetOperationT a - runFrom u = runSetOperation $ toSetOperation u - -instance (SqlSelect a r, ToAlias a, ToAliasReference a) => From (SqlSetOperation a) where - type FromT (SqlSetOperation a) = a - -- If someone uses just a plain SelectQuery it should behave like a normal subquery - runFrom (SelectQueryP _ subquery) = fromSubQuery NormalSubQuery subquery - -- Otherwise use the SqlSetOperation - runFrom u = runSetOperation $ toSetOperation u