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

Add new experimental aggregates using SqlAggregate wrapper around SqlExpr.

Browse Source
This commit is contained in:
belevy 2021-02-14 16:56:58 -06:00
commit 75f9c8d3b8
6 changed files with 293 additions and 134 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
esqueleto.cabal
View File

@ -30,6 +30,7 @@ library
exposed-modules: exposed-modules:
Database.Esqueleto Database.Esqueleto
Database.Esqueleto.Experimental Database.Esqueleto.Experimental
Database.Esqueleto.Experimental.Aggregates
Database.Esqueleto.Internal.Language Database.Esqueleto.Internal.Language
Database.Esqueleto.Internal.Sql Database.Esqueleto.Internal.Sql
Database.Esqueleto.Internal.Internal Database.Esqueleto.Internal.Internal

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

@ -53,6 +53,8 @@ module Database.Esqueleto.Experimental
, with , with
, withRecursive , withRecursive
, agg
-- ** Internals -- ** Internals
, From(..) , From(..)
, ToMaybe(..) , ToMaybe(..)
@ -219,9 +221,13 @@ module Database.Esqueleto.Experimental
, module Database.Esqueleto.Internal.PersistentImport , module Database.Esqueleto.Internal.PersistentImport
) where ) where
import Database.Esqueleto.Internal.Internal hiding (From, from, on) import Data.Coerce
import Database.Esqueleto.Internal.Internal hiding
(From, from, groupBy, on, sum_, (?.), (^.))
import qualified Database.Esqueleto.Internal.Internal as I ((?.), (^.))
import Database.Esqueleto.Internal.PersistentImport import Database.Esqueleto.Internal.PersistentImport
import Database.Esqueleto.Experimental.Aggregates
import Database.Esqueleto.Experimental.From import Database.Esqueleto.Experimental.From
import Database.Esqueleto.Experimental.From.CommonTableExpression import Database.Esqueleto.Experimental.From.CommonTableExpression
import Database.Esqueleto.Experimental.From.Join import Database.Esqueleto.Experimental.From.Join
@ -561,3 +567,4 @@ import Database.Esqueleto.Experimental.ToMaybe
-- ) -- )
-- @ -- @
-- --
--

139
src/Database/Esqueleto/Experimental/Aggregates.hs Normal file
View File

@ -0,0 +1,139 @@
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Database.Esqueleto.Experimental.Aggregates
where
import Control.Monad.IO.Class
import qualified Control.Monad.Trans.Writer as W
import Data.Coerce (Coercible, coerce)
import Database.Esqueleto.Internal.Internal
( GroupByClause(..)
, SideData(..)
, SqlExpr(..)
, SqlQuery(..)
, SqlSelect(..)
, ToSomeValues(..)
, noMeta
, select
, unsafeSqlFunction
)
import qualified Database.Esqueleto.Internal.Internal as I
import Database.Esqueleto.Internal.PersistentImport
( Entity
, EntityField
, Key
, PersistEntity
, PersistField
, SqlReadT
, persistIdField
)
class SqlExprEntity expr where
(^.) :: (PersistEntity val, PersistField typ)
=> expr (Entity val)
-> EntityField val typ
-> expr typ
(?.) :: (PersistEntity val, PersistField typ)
=> expr (Maybe (Entity val))
-> EntityField val typ
-> expr (Maybe typ)
-- | Project a field of an entity.
instance SqlExprEntity SqlExpr where
(^.) = (I.^.)
(?.) = (I.?.)
newtype SqlAggregate a = SqlAggregate { agg :: SqlExpr a }
deriving via SqlExpr instance SqlExprEntity SqlAggregate
test :: (PersistEntity ent, PersistField a, PersistField b, PersistField c)
=> SqlExpr (Maybe (Entity ent))
-> EntityField ent a
-> SqlExpr b
-> SqlExpr c
-> SqlQuery (SqlExpr (Maybe a), SqlExpr b, SqlExpr (Maybe Int), SqlExpr Int)
test ent field y other = do
groupBy (ent, y) $ \(ent', y') ->
pure (ent' ?. field, y', sum_ other, countRows_)
countRows_ :: (PersistField n, Integral n) => SqlAggregate n
countRows_ = SqlAggregate $ ERaw noMeta $ \_ _ -> ("COUNT(*)", [])
-- Tuple magic, only SqlExprs are on the leaves.
-- The Coercible instance from the SqlExpr a -> SqlExpr b allows 0 cost casting
class Coercible a r => Aggregateable a r | a -> r, r -> a where
toAggregate :: a -> r
toAggregate = coerce
fromAggregate :: r -> a
fromAggregate = coerce
instance Aggregateable () () where
instance Aggregateable (SqlExpr a) (SqlAggregate a) where
instance (Aggregateable a ra, Aggregateable b rb) => Aggregateable (a,b) (ra, rb) where
instance
( Aggregateable a ra
, Aggregateable b rb
, Aggregateable c rc
) => Aggregateable (a,b,c) (ra,rb,rc) where
instance
( Aggregateable a ra
, Aggregateable b rb
, Aggregateable c rc
, Aggregateable d rd
) => Aggregateable (a,b,c,d) (ra,rb,rc,rd) where
instance
( Aggregateable a ra
, Aggregateable b rb
, Aggregateable c rc
, Aggregateable d rd
, Aggregateable e re
) => Aggregateable (a,b,c,d,e) (ra,rb,rc,rd,re) where
instance
( Aggregateable a ra
, Aggregateable b rb
, Aggregateable c rc
, Aggregateable d rd
, Aggregateable e re
, Aggregateable f rf
) => Aggregateable (a,b,c,d,e,f) (ra,rb,rc,rd,re,rf) where
instance
( Aggregateable a ra
, Aggregateable b rb
, Aggregateable c rc
, Aggregateable d rd
, Aggregateable e re
, Aggregateable f rf
, Aggregateable g rg
) => Aggregateable (a,b,c,d,e,f,g) (ra,rb,rc,rd,re,rf,rg) where
instance
( Aggregateable a ra
, Aggregateable b rb
, Aggregateable c rc
, Aggregateable d rd
, Aggregateable e re
, Aggregateable f rf
, Aggregateable g rg
, Aggregateable h rh
) => Aggregateable (a,b,c,d,e,f,g,h) (ra,rb,rc,rd,re,rf,rg,rh) where
sum_ :: (PersistField a, PersistField n, Integral n) => SqlExpr a -> SqlAggregate (Maybe n)
sum_ = coerce . unsafeSqlFunction "SUM"
groupBy :: ( ToSomeValues a
, Aggregateable a a'
, Aggregateable b b'
) => a -> (a' -> SqlQuery b') -> SqlQuery b
groupBy a f = do
Q $ W.tell $ mempty{sdGroupByClause = GroupBy $ toSomeValues a }
fmap fromAggregate $ f $ toAggregate a

48
src/Database/Esqueleto/Experimental/From/Join.hs
View File

@ -10,22 +10,21 @@
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module Database.Esqueleto.Experimental.From.Join module Database.Esqueleto.Experimental.From.Join
where where
import Data.Bifunctor (first) import Control.Arrow (first)
import Data.Kind (Constraint) import Data.Kind (Constraint)
import Data.Proxy import Data.Proxy
import qualified Data.Text.Lazy.Builder as TLB import qualified Data.Text.Lazy.Builder as TLB
import Database.Esqueleto.Experimental.From import Database.Esqueleto.Experimental.From
import Database.Esqueleto.Experimental.From.SqlSetOperation
import Database.Esqueleto.Experimental.ToAlias import Database.Esqueleto.Experimental.ToAlias
import Database.Esqueleto.Experimental.ToAliasReference import Database.Esqueleto.Experimental.ToAliasReference
import Database.Esqueleto.Experimental.ToMaybe import Database.Esqueleto.Experimental.ToMaybe
import Database.Esqueleto.Internal.Internal hiding import Database.Esqueleto.Internal.Internal hiding
(From(..), from, fromJoin, on) (From(..), from, fromJoin, on)
import Database.Esqueleto.Internal.PersistentImport
(Entity(..), EntityField, PersistEntity, PersistField)
import GHC.TypeLits import GHC.TypeLits
-- | A left-precedence pair. Pronounced \"and\". Used to represent expressions -- | A left-precedence pair. Pronounced \"and\". Used to represent expressions
@ -40,30 +39,41 @@ import GHC.TypeLits
-- See the examples at the beginning of this module to see how this -- See the examples at the beginning of this module to see how this
-- operator is used in 'JOIN' operations. -- operator is used in 'JOIN' operations.
data (:&) a b = a :& b data (:&) a b = a :& b
deriving (Show, Eq)
infixl 2 :& infixl 2 :&
instance (ToMaybe a, ToMaybe b) => ToMaybe (a :& b) where instance (ToMaybe a, ToMaybe b) => ToMaybe (a :& b) where
type ToMaybeT (a :& b) = (ToMaybeT a :& ToMaybeT b) type ToMaybeT (a :& b) = (ToMaybeT a :& ToMaybeT b)
toMaybe (a :& b) = (toMaybe a :& toMaybe b) toMaybe (a :& b) = (toMaybe a :& toMaybe b)
class ValidOnClause a fromInductiveTupleP :: Proxy (a :& b) -> Proxy (a, b)
fromInductiveTupleP = const Proxy
toInductiveTuple :: (a, b) -> (a :& b)
toInductiveTuple (a, b) = a :& b
instance (SqlSelect a a', SqlSelect b b') => SqlSelect (a :& b) (a' :& b') where
sqlSelectCols esc (a :& b) = sqlSelectCols esc (a, b)
sqlSelectColCount = sqlSelectColCount . fromInductiveTupleP
sqlSelectProcessRow p = fmap toInductiveTuple . sqlSelectProcessRow (fromInductiveTupleP p)
class ValidOnClause a where
-- | 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 :: a -> (b -> SqlExpr Bool) -> (a, b -> SqlExpr Bool)
on = (,)
infix 9 `on`
instance {-# OVERLAPPABLE #-} ToFrom a a' => ValidOnClause a instance {-# OVERLAPPABLE #-} ToFrom a a' => ValidOnClause a
instance ValidOnClause (a -> SqlQuery b) instance ValidOnClause (a -> SqlQuery b)
-- | An @ON@ clause that describes how two tables are related. This should be
-- used as an infix operator after a 'JOIN'. For example,
--
-- @
-- select $
-- from $ table \@Person
-- \`innerJoin\` table \@BlogPost
-- \`on\` (\\(p :& bP) ->
-- p ^. PersonId ==. bP ^. BlogPostAuthorId)
-- @
on :: ValidOnClause a => a -> (b -> SqlExpr Bool) -> (a, b -> SqlExpr Bool)
on = (,)
infix 9 `on`
type family ErrorOnLateral a :: Constraint where 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 (a -> SqlQuery b) = TypeError ('Text "LATERAL can only be used for INNER, LEFT, and CROSS join kinds.")
ErrorOnLateral _ = () ErrorOnLateral _ = ()

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

@ -1,6 +1,7 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# language DerivingStrategies, GeneralizedNewtypeDeriving #-} {-# language DerivingStrategies, GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
@ -24,6 +25,7 @@
-- tracker so we can safely support it. -- tracker so we can safely support it.
module Database.Esqueleto.Internal.Internal where module Database.Esqueleto.Internal.Internal where
import Data.Kind (Constraint)
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
import Data.Coerce (Coercible, coerce) import Data.Coerce (Coercible, coerce)
import Control.Arrow (first, (***)) import Control.Arrow (first, (***))
@ -534,14 +536,14 @@ subSelectForeign expr foreignKey k =
subSelectUnsafe :: (SqlSelect (SqlExpr a) a, PersistField a) => SqlQuery (SqlExpr a) -> SqlExpr a subSelectUnsafe :: (SqlSelect (SqlExpr a) a, PersistField a) => SqlQuery (SqlExpr a) -> SqlExpr a
subSelectUnsafe = sub SELECT subSelectUnsafe = sub SELECT
-- | Project a field of an entity.
(^.) :: forall typ val . (PersistEntity val, PersistField typ) (^.) :: (PersistEntity val, PersistField typ)
=> SqlExpr (Entity val) => SqlExpr (Entity val)
-> EntityField val typ -> EntityField val typ
-> SqlExpr typ -> SqlExpr typ
ERaw m f ^. field (ERaw m f) ^. field
| isIdField field = idFieldValue | isIdField field = idFieldValue
| Just alias <- sqlExprMetaAlias m = | Just alias <- sqlExprMetaAlias m =
ERaw noMeta $ \_ info -> ERaw noMeta $ \_ info ->
f Never info <> ("." <> useIdent info (aliasedEntityColumnIdent alias fieldDef), []) f Never info <> ("." <> useIdent info (aliasedEntityColumnIdent alias fieldDef), [])
| otherwise = ERaw noMeta $ \_ info -> (dot info $ persistFieldDef field, []) | otherwise = ERaw noMeta $ \_ info -> (dot info $ persistFieldDef field, [])
@ -563,7 +565,10 @@ ERaw m f ^. field
\p info -> (parensM p $ uncommas $ dot info <$> idFields, []) \p info -> (parensM p $ uncommas $ dot info <$> idFields, [])
ed = entityDef $ getEntityVal (Proxy :: Proxy (SqlExpr (Entity val))) getProxy :: EntityField ent val -> Proxy (SqlExpr (Entity ent))
getProxy = const Proxy
ed = entityDef $ getEntityVal $ getProxy field
dot info fieldDef = dot info fieldDef =
sourceIdent info <> "." <> fieldIdent sourceIdent info <> "." <> fieldIdent
@ -1136,6 +1141,13 @@ data SomeValue where
class ToSomeValues a where class ToSomeValues a where
toSomeValues :: a -> [SomeValue] toSomeValues :: a -> [SomeValue]
instance {-# INCOHERENT #-} PersistField a => ToSomeValues (SqlExpr a) where
toSomeValues a = [SomeValue a]
instance PersistEntity a => ToSomeValues (SqlExpr (Entity a)) where
toSomeValues a = [SomeValue $ a ^. persistIdField]
instance PersistEntity a => ToSomeValues (SqlExpr (Maybe (Entity a))) where
toSomeValues a = [SomeValue $ a ?. persistIdField]
instance instance
( ToSomeValues a ( ToSomeValues a
, ToSomeValues b , ToSomeValues b
@ -2077,8 +2089,6 @@ parensM Parens = parens
data OrderByType = ASC | DESC data OrderByType = ASC | DESC
instance ToSomeValues (SqlExpr a) where
toSomeValues a = [SomeValue a]
fieldName fieldName
:: (PersistEntity val, PersistField typ) :: (PersistEntity val, PersistField typ)
@ -3042,13 +3052,8 @@ instance (SqlSelect a ra, SqlSelect b rb) => SqlSelect (a, b) (ra, rb) where
] ]
sqlSelectColCount = uncurry (+) . (sqlSelectColCount *** sqlSelectColCount) . fromTupleP sqlSelectColCount = uncurry (+) . (sqlSelectColCount *** sqlSelectColCount) . fromTupleP
sqlSelectProcessRow p = sqlSelectProcessRow p =
let x = getType processRow let (fstP, sndP) = fromTupleP p
getType :: SqlSelect a r => (z -> Either y (r,x)) -> Proxy a colCountFst = sqlSelectColCount fstP
getType = const Proxy
colCountFst = sqlSelectColCount x
(fstP, sndP) = fromTupleP p
processRow row = processRow row =
let (rowFst, rowSnd) = splitAt colCountFst row let (rowFst, rowSnd) = splitAt colCountFst row
in (,) <$> sqlSelectProcessRow fstP rowFst in (,) <$> sqlSelectProcessRow fstP rowFst

197
test/Common/Test.hs
View File

@ -1,25 +1,25 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE Rank2Types #-} {-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-unused-binds #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-} {-# OPTIONS_GHC -fno-warn-deprecations #-}
@ -62,41 +62,38 @@ module Common.Test
, Key(..) , Key(..)
) where ) where
import Control.Monad (forM_, replicateM, import Control.Monad (forM_, replicateM, replicateM_, void)
replicateM_, void) import Control.Monad.Catch (MonadCatch)
import Control.Monad.Catch (MonadCatch) import Control.Monad.Reader (ask)
import Control.Monad.Reader (ask) import Data.Either
import Data.Either import Data.Time
import Data.Time
#if __GLASGOW_HASKELL__ >= 806 #if __GLASGOW_HASKELL__ >= 806
import Control.Monad.Fail (MonadFail) import Control.Monad.Fail (MonadFail)
#endif #endif
import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Logger (MonadLogger (..), import Control.Monad.Logger (MonadLogger(..), NoLoggingT, runNoLoggingT)
NoLoggingT, import Control.Monad.Trans.Reader (ReaderT)
runNoLoggingT) import qualified Data.Attoparsec.Text as AP
import Control.Monad.Trans.Reader (ReaderT) import Data.Char (toLower, toUpper)
import qualified Data.Attoparsec.Text as AP import Data.Monoid ((<>))
import Data.Char (toLower, toUpper) import Database.Esqueleto
import Data.Monoid ((<>)) import Database.Esqueleto.Experimental hiding
import Database.Esqueleto (countRows_, from, groupBy, on, sum_, (?.), (^.))
import Database.Esqueleto.Experimental hiding (from, on) import qualified Database.Esqueleto.Experimental as EX
import qualified Database.Esqueleto.Experimental as Experimental import Database.Persist.TH
import Database.Persist.TH import Test.Hspec
import Test.Hspec import UnliftIO
import UnliftIO
import Data.Conduit (ConduitT, runConduit, import Data.Conduit (ConduitT, runConduit, (.|))
(.|)) import qualified Data.Conduit.List as CL
import qualified Data.Conduit.List as CL import qualified Data.List as L
import qualified Data.List as L import qualified Data.Set as S
import qualified Data.Set as S import qualified Data.Text as Text
import qualified Data.Text as Text import qualified Data.Text.Internal.Lazy as TL
import qualified Data.Text.Internal.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB
import qualified Data.Text.Lazy.Builder as TLB
import qualified Database.Esqueleto.Internal.ExprParser as P import qualified Database.Esqueleto.Internal.ExprParser as P
import qualified Database.Esqueleto.Internal.Sql as EI import qualified Database.Esqueleto.Internal.Sql as EI
import qualified UnliftIO.Resource as R import qualified UnliftIO.Resource as R
-- Test schema -- Test schema
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase| share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
@ -458,10 +455,10 @@ testSubSelect run = do
eres <- try $ run $ do eres <- try $ run $ do
setup setup
bad <- select $ bad <- select $
from $ \n -> do from $ \(n :: SqlExpr (Entity Numbers)) -> do
pure $ (,) (n ^. NumbersInt) $ pure $ (,) (n ^. NumbersInt) $
subSelectUnsafe $ subSelectUnsafe $
from $ \n' -> do from $ \(n' :: SqlExpr (Entity Numbers)) -> do
pure (just (n' ^. NumbersDouble)) pure (just (n' ^. NumbersDouble))
good <- select $ good <- select $
from $ \n -> do from $ \n -> do
@ -484,10 +481,10 @@ testSubSelect run = do
eres <- try $ run $ do eres <- try $ run $ do
setup setup
select $ select $
from $ \n -> do from $ \(n :: SqlExpr (Entity Numbers)) -> do
pure $ (,) (n ^. NumbersInt) $ pure $ (,) (n ^. NumbersInt) $
subSelectUnsafe $ subSelectUnsafe $
from $ \n' -> do from $ \(n' :: SqlExpr (Entity Numbers)) -> do
where_ $ val False where_ $ val False
pure (n' ^. NumbersDouble) pure (n' ^. NumbersDouble)
case eres of case eres of
@ -501,14 +498,14 @@ testSelectSource run = do
describe "selectSource" $ do describe "selectSource" $ do
it "works for a simple example" $ run $ do it "works for a simple example" $ run $ do
let query = selectSource $ let query = selectSource $
Experimental.from $ Table @Person EX.from $ Table @Person
p1e <- insert' p1 p1e <- insert' p1
ret <- runConduit $ query .| CL.consume ret <- runConduit $ query .| CL.consume
liftIO $ ret `shouldBe` [ p1e ] liftIO $ ret `shouldBe` [ p1e ]
it "can run a query many times" $ run $ do it "can run a query many times" $ run $ do
let query = selectSource $ let query = selectSource $
Experimental.from $ Table @Person EX.from $ Table @Person
p1e <- insert' p1 p1e <- insert' p1
ret0 <- runConduit $ query .| CL.consume ret0 <- runConduit $ query .| CL.consume
ret1 <- runConduit $ query .| CL.consume ret1 <- runConduit $ query .| CL.consume
@ -537,7 +534,7 @@ testSelectFrom run = do
describe "select/from" $ do describe "select/from" $ do
it "works for a simple example" $ run $ do it "works for a simple example" $ run $ do
p1e <- insert' p1 p1e <- insert' p1
ret <- select $ Experimental.from $ Table @Person ret <- select $ EX.from $ Table @Person
liftIO $ ret `shouldBe` [ p1e ] liftIO $ ret `shouldBe` [ p1e ]
it "works for a simple self-join (one entity)" $ run $ do it "works for a simple self-join (one entity)" $ run $ do
@ -545,7 +542,7 @@ testSelectFrom run = do
ret <- ret <-
select $ do select $ do
person1 :& person2 <- person1 :& person2 <-
Experimental.from $ Table @Person EX.from $ Table @Person
`crossJoin` Table @Person `crossJoin` Table @Person
return (person1, person2) return (person1, person2)
liftIO $ ret `shouldBe` [ (p1e, p1e) ] liftIO $ ret `shouldBe` [ (p1e, p1e) ]
@ -556,7 +553,7 @@ testSelectFrom run = do
ret <- ret <-
select $ do select $ do
person1 :& person2 <- person1 :& person2 <-
Experimental.from $ Table @Person EX.from $ Table @Person
`crossJoin` Table @Person `crossJoin` Table @Person
return (person1, person2) return (person1, person2)
liftIO $ liftIO $
@ -672,7 +669,7 @@ testSelectFrom run = do
number = 101 number = 101
Right thePk = keyFromValues [toPersistValue number] Right thePk = keyFromValues [toPersistValue number]
fcPk <- insert fc fcPk <- insert fc
[Entity _ ret] <- select $ Experimental.from $ Table @Frontcover [Entity _ ret] <- select $ EX.from $ Table @Frontcover
liftIO $ do liftIO $ do
ret `shouldBe` fc ret `shouldBe` fc
fcPk `shouldBe` thePk fcPk `shouldBe` thePk
@ -879,9 +876,9 @@ testSelectSubQuery run = describe "select subquery" $ do
it "works" $ run $ do it "works" $ run $ do
_ <- insert' p1 _ <- insert' p1
let q = do let q = do
p <- Experimental.from $ Table @Person p <- EX.from $ Table @Person
return ( p ^. PersonName, p ^. PersonAge) return ( p ^. PersonName, p ^. PersonAge)
ret <- select $ Experimental.from q ret <- select $ EX.from q
liftIO $ ret `shouldBe` [ (Value $ personName p1, Value $ personAge p1) ] liftIO $ ret `shouldBe` [ (Value $ personName p1, Value $ personAge p1) ]
it "supports sub-selecting Maybe entities" $ run $ do it "supports sub-selecting Maybe entities" $ run $ do
@ -890,11 +887,11 @@ testSelectSubQuery run = describe "select subquery" $ do
l1Deeds <- mapM (\k -> insert' $ Deed k (entityKey l1e)) (map show [1..3 :: Int]) l1Deeds <- mapM (\k -> insert' $ Deed k (entityKey l1e)) (map show [1..3 :: Int])
let l1WithDeeds = do d <- l1Deeds let l1WithDeeds = do d <- l1Deeds
pure (l1e, Just d) pure (l1e, Just d)
let q = Experimental.from $ do let q = EX.from $ do
(lords :& deeds) <- (lords :& deeds) <-
Experimental.from $ Table @Lord EX.from $ Table @Lord
`LeftOuterJoin` Table @Deed `LeftOuterJoin` Table @Deed
`Experimental.on` (\(l :& d) -> just (l ^. LordId) ==. d ?. DeedOwnerId) `EX.on` (\(l :& d) -> just (l ^. LordId) ==. d ?. DeedOwnerId)
pure (lords, deeds) pure (lords, deeds)
ret <- select q ret <- select q
@ -905,8 +902,8 @@ testSelectSubQuery run = describe "select subquery" $ do
_ <- insert' p3 _ <- insert' p3
let q = do let q = do
(name, age) <- (name, age) <-
Experimental.from $ SubQuery $ do EX.from $ SubQuery $ do
p <- Experimental.from $ Table @Person p <- EX.from $ Table @Person
return ( p ^. PersonName, p ^. PersonAge) return ( p ^. PersonName, p ^. PersonAge)
orderBy [ asc age ] orderBy [ asc age ]
pure name pure name
@ -920,13 +917,13 @@ testSelectSubQuery run = describe "select subquery" $ do
mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int]) mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int])
let q = do let q = do
(lord :& deed) <- Experimental.from $ Table @Lord (lord :& deed) <- EX.from $ Table @Lord
`InnerJoin` Table @Deed `InnerJoin` Table @Deed
`Experimental.on` (\(lord :& deed) -> `EX.on` (\(lord :& deed) ->
lord ^. LordId ==. deed ^. DeedOwnerId) lord ^. LordId ==. deed ^. DeedOwnerId)
return (lord ^. LordId, deed ^. DeedId) return (lord ^. LordId, deed ^. DeedId)
q' = do q' = do
(lordId, deedId) <- Experimental.from $ SubQuery q (lordId, deedId) <- EX.from $ SubQuery q
groupBy (lordId) groupBy (lordId)
return (lordId, count deedId) return (lordId, count deedId)
(ret :: [(Value (Key Lord), Value Int)]) <- select q' (ret :: [(Value (Key Lord), Value Int)]) <- select q'
@ -941,15 +938,15 @@ testSelectSubQuery run = describe "select subquery" $ do
mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int]) mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int])
let q = do let q = do
(lord :& deed) <- Experimental.from $ Table @Lord (lord :& deed) <- EX.from $ Table @Lord
`InnerJoin` Table @Deed `InnerJoin` Table @Deed
`Experimental.on` (\(lord :& deed) -> `EX.on` (\(lord :& deed) ->
lord ^. LordId ==. deed ^. DeedOwnerId) lord ^. LordId ==. deed ^. DeedOwnerId)
groupBy (lord ^. LordId) groupBy (lord)
return (lord ^. LordId, count (deed ^. DeedId)) return (lord ^. LordId, count (deed ^. DeedId))
(ret :: [(Value Int)]) <- select $ do (ret :: [(Value Int)]) <- select $ do
(lordId, deedCount) <- Experimental.from $ SubQuery q (lordId, deedCount) <- EX.from $ SubQuery q
where_ $ deedCount >. val (3 :: Int) where_ $ deedCount >. val (3 :: Int)
return (count lordId) return (count lordId)
@ -962,9 +959,9 @@ testSelectSubQuery run = describe "select subquery" $ do
mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int]) mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int])
let q = do let q = do
(lord :& deed) <- Experimental.from $ Table @Lord (lord :& deed) <- EX.from $ Table @Lord
`InnerJoin` (Experimental.from $ Table @Deed) `InnerJoin` (EX.from $ Table @Deed)
`Experimental.on` (\(lord :& deed) -> `EX.on` (\(lord :& deed) ->
lord ^. LordId ==. deed ^. DeedOwnerId) lord ^. LordId ==. deed ^. DeedOwnerId)
groupBy (lord ^. LordId) groupBy (lord ^. LordId)
return (lord ^. LordId, count (deed ^. DeedId)) return (lord ^. LordId, count (deed ^. DeedId))
@ -976,11 +973,11 @@ testSelectSubQuery run = describe "select subquery" $ do
l1k <- insert l1 l1k <- insert l1
l3k <- insert l3 l3k <- insert l3
let q = do let q = do
(lord :& (_, dogCounts)) <- Experimental.from $ Table @Lord (lord :& (_, dogCounts)) <- EX.from $ Table @Lord
`LeftOuterJoin` do `LeftOuterJoin` do
lord <- Experimental.from $ Table @Lord lord <- EX.from $ Table @Lord
pure (lord ^. LordId, lord ^. LordDogs) pure (lord ^. LordId, lord ^. LordDogs)
`Experimental.on` (\(lord :& (lordId, _)) -> `EX.on` (\(lord :& (lordId, _)) ->
just (lord ^. LordId) ==. lordId) just (lord ^. LordId) ==. lordId)
groupBy (lord ^. LordId, dogCounts) groupBy (lord ^. LordId, dogCounts)
return (lord ^. LordId, dogCounts) return (lord ^. LordId, dogCounts)
@ -990,19 +987,19 @@ testSelectSubQuery run = describe "select subquery" $ do
it "unions" $ run $ do it "unions" $ run $ do
_ <- insert p1 _ <- insert p1
_ <- insert p2 _ <- insert p2
let q = Experimental.from $ let q = EX.from $
(do (do
p <- Experimental.from $ Table @Person p <- EX.from $ Table @Person
where_ $ not_ $ isNothing $ p ^. PersonAge where_ $ not_ $ isNothing $ p ^. PersonAge
return (p ^. PersonName)) return (p ^. PersonName))
`union_` `union_`
(do (do
p <- Experimental.from $ Table @Person p <- EX.from $ Table @Person
where_ $ isNothing $ p ^. PersonAge where_ $ isNothing $ p ^. PersonAge
return (p ^. PersonName)) return (p ^. PersonName))
`union_` `union_`
(do (do
p <- Experimental.from $ Table @Person p <- EX.from $ Table @Person
where_ $ isNothing $ p ^. PersonAge where_ $ isNothing $ p ^. PersonAge
return (p ^. PersonName)) return (p ^. PersonName))
names <- select q names <- select q
@ -2350,7 +2347,7 @@ testExperimentalFrom run = do
_ <- insert' p2 _ <- insert' p2
p3e <- insert' p3 p3e <- insert' p3
peopleWithAges <- select $ do peopleWithAges <- select $ do
people <- Experimental.from $ Table @Person people <- EX.from $ Table @Person
where_ $ not_ $ isNothing $ people ^. PersonAge where_ $ not_ $ isNothing $ people ^. PersonAge
return people return people
liftIO $ peopleWithAges `shouldMatchList` [p1e, p3e] liftIO $ peopleWithAges `shouldMatchList` [p1e, p3e]
@ -2363,9 +2360,9 @@ testExperimentalFrom run = do
d2e <- insert' $ Deed "2" (entityKey l1e) d2e <- insert' $ Deed "2" (entityKey l1e)
lordDeeds <- select $ do lordDeeds <- select $ do
(lords :& deeds) <- (lords :& deeds) <-
Experimental.from $ Table @Lord EX.from $ Table @Lord
`InnerJoin` Table @Deed `InnerJoin` Table @Deed
`Experimental.on` (\(l :& d) -> l ^. LordId ==. d ^. DeedOwnerId) `EX.on` (\(l :& d) -> l ^. LordId ==. d ^. DeedOwnerId)
pure (lords, deeds) pure (lords, deeds)
liftIO $ lordDeeds `shouldMatchList` [ (l1e, d1e) liftIO $ lordDeeds `shouldMatchList` [ (l1e, d1e)
, (l1e, d2e) , (l1e, d2e)
@ -2379,9 +2376,9 @@ testExperimentalFrom run = do
d2e <- insert' $ Deed "2" (entityKey l1e) d2e <- insert' $ Deed "2" (entityKey l1e)
lordDeeds <- select $ do lordDeeds <- select $ do
(lords :& deeds) <- (lords :& deeds) <-
Experimental.from $ Table @Lord EX.from $ Table @Lord
`LeftOuterJoin` Table @Deed `LeftOuterJoin` Table @Deed
`Experimental.on` (\(l :& d) -> just (l ^. LordId) ==. d ?. DeedOwnerId) `EX.on` (\(l :& d) -> just (l ^. LordId) ==. d ?. DeedOwnerId)
pure (lords, deeds) pure (lords, deeds)
liftIO $ lordDeeds `shouldMatchList` [ (l1e, Just d1e) liftIO $ lordDeeds `shouldMatchList` [ (l1e, Just d1e)
@ -2393,8 +2390,8 @@ testExperimentalFrom run = do
insert_ l1 insert_ l1
insert_ l2 insert_ l2
insert_ l3 insert_ l3
delete $ void $ Experimental.from $ Table @Lord delete $ void $ EX.from $ Table @Lord
lords <- select $ Experimental.from $ Table @Lord lords <- select $ EX.from $ Table @Lord
liftIO $ lords `shouldMatchList` [] liftIO $ lords `shouldMatchList` []
it "supports implicit cross joins" $ do it "supports implicit cross joins" $ do
@ -2402,11 +2399,11 @@ testExperimentalFrom run = do
l1e <- insert' l1 l1e <- insert' l1
l2e <- insert' l2 l2e <- insert' l2
ret <- select $ do ret <- select $ do
lords1 <- Experimental.from $ Table @Lord lords1 <- EX.from $ Table @Lord
lords2 <- Experimental.from $ Table @Lord lords2 <- EX.from $ Table @Lord
pure (lords1, lords2) pure (lords1, lords2)
ret2 <- select $ do ret2 <- select $ do
(lords1 :& lords2) <- Experimental.from $ Table @Lord `CrossJoin` Table @Lord (lords1 :& lords2) <- EX.from $ Table @Lord `CrossJoin` Table @Lord
pure (lords1,lords2) pure (lords1,lords2)
liftIO $ ret `shouldMatchList` ret2 liftIO $ ret `shouldMatchList` ret2
liftIO $ ret `shouldMatchList` [ (l1e, l1e) liftIO $ ret `shouldMatchList` [ (l1e, l1e)
@ -2420,12 +2417,12 @@ testExperimentalFrom run = do
run $ void $ do run $ void $ do
let q = do let q = do
(persons :& profiles :& posts) <- (persons :& profiles :& posts) <-
Experimental.from $ Table @Person EX.from $ Table @Person
`InnerJoin` Table @Profile `InnerJoin` Table @Profile
`Experimental.on` (\(people :& profiles) -> `EX.on` (\(people :& profiles) ->
people ^. PersonId ==. profiles ^. ProfilePerson) people ^. PersonId ==. profiles ^. ProfilePerson)
`LeftOuterJoin` Table @BlogPost `LeftOuterJoin` Table @BlogPost
`Experimental.on` (\(people :& _ :& posts) -> `EX.on` (\(people :& _ :& posts) ->
just (people ^. PersonId) ==. posts ?. BlogPostAuthorId) just (people ^. PersonId) ==. posts ?. BlogPostAuthorId)
pure (persons, posts, profiles) pure (persons, posts, profiles)
--error . show =<< renderQuerySelect q --error . show =<< renderQuerySelect q
@ -2437,7 +2434,7 @@ testExperimentalFrom run = do
insert_ p3 insert_ p3
-- Pretend this isnt all posts -- Pretend this isnt all posts
upperNames <- select $ do upperNames <- select $ do
author <- Experimental.from $ SelectQuery $ Experimental.from $ Table @Person author <- EX.from $ SelectQuery $ EX.from $ Table @Person
pure $ upper_ $ author ^. PersonName pure $ upper_ $ author ^. PersonName
liftIO $ upperNames `shouldMatchList` [ Value "JOHN" liftIO $ upperNames `shouldMatchList` [ Value "JOHN"