Add new experimental aggregates using SqlAggregate wrapper around SqlExpr.
This commit is contained in:
belevy
commit
75f9c8d3b8
@ -30,6 +30,7 @@ library
|
||||
exposed-modules:
|
||||
Database.Esqueleto
|
||||
Database.Esqueleto.Experimental
|
||||
Database.Esqueleto.Experimental.Aggregates
|
||||
Database.Esqueleto.Internal.Language
|
||||
Database.Esqueleto.Internal.Sql
|
||||
Database.Esqueleto.Internal.Internal
|
||||
|
||||
@ -53,6 +53,8 @@ module Database.Esqueleto.Experimental
|
||||
, with
|
||||
, withRecursive
|
||||
|
||||
, agg
|
||||
|
||||
-- ** Internals
|
||||
, From(..)
|
||||
, ToMaybe(..)
|
||||
@ -219,9 +221,13 @@ module Database.Esqueleto.Experimental
|
||||
, module Database.Esqueleto.Internal.PersistentImport
|
||||
) 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.Experimental.Aggregates
|
||||
import Database.Esqueleto.Experimental.From
|
||||
import Database.Esqueleto.Experimental.From.CommonTableExpression
|
||||
import Database.Esqueleto.Experimental.From.Join
|
||||
@ -561,3 +567,4 @@ import Database.Esqueleto.Experimental.ToMaybe
|
||||
-- )
|
||||
-- @
|
||||
--
|
||||
--
|
||||
|
||||
139
src/Database/Esqueleto/Experimental/Aggregates.hs
Normal file
139
src/Database/Esqueleto/Experimental/Aggregates.hs
Normal 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
|
||||
@ -10,22 +10,21 @@
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
|
||||
|
||||
module Database.Esqueleto.Experimental.From.Join
|
||||
where
|
||||
|
||||
import Data.Bifunctor (first)
|
||||
import Control.Arrow (first)
|
||||
import Data.Kind (Constraint)
|
||||
import Data.Proxy
|
||||
import qualified Data.Text.Lazy.Builder as TLB
|
||||
import Database.Esqueleto.Experimental.From
|
||||
import Database.Esqueleto.Experimental.From.SqlSetOperation
|
||||
import Database.Esqueleto.Experimental.ToAlias
|
||||
import Database.Esqueleto.Experimental.ToAliasReference
|
||||
import Database.Esqueleto.Experimental.ToMaybe
|
||||
import Database.Esqueleto.Internal.Internal hiding
|
||||
(From(..), from, fromJoin, on)
|
||||
import Database.Esqueleto.Internal.PersistentImport
|
||||
(Entity(..), EntityField, PersistEntity, PersistField)
|
||||
import GHC.TypeLits
|
||||
|
||||
-- | A left-precedence pair. Pronounced \"and\". Used to represent expressions
|
||||
@ -40,30 +39,41 @@ import GHC.TypeLits
|
||||
-- See the examples at the beginning of this module to see how this
|
||||
-- operator is used in 'JOIN' operations.
|
||||
data (:&) a b = a :& b
|
||||
deriving (Show, Eq)
|
||||
infixl 2 :&
|
||||
|
||||
instance (ToMaybe a, ToMaybe b) => ToMaybe (a :& b) where
|
||||
type ToMaybeT (a :& b) = (ToMaybeT a :& ToMaybeT b)
|
||||
toMaybe (a :& b) = (toMaybe a :& toMaybe b)
|
||||
|
||||
class ValidOnClause a
|
||||
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 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
|
||||
ErrorOnLateral (a -> SqlQuery b) = TypeError ('Text "LATERAL can only be used for INNER, LEFT, and CROSS join kinds.")
|
||||
ErrorOnLateral _ = ()
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# language DerivingStrategies, GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE QuantifiedConstraints #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE EmptyDataDecls #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
@ -24,6 +25,7 @@
|
||||
-- tracker so we can safely support it.
|
||||
module Database.Esqueleto.Internal.Internal where
|
||||
|
||||
import Data.Kind (Constraint)
|
||||
import Control.Applicative ((<|>))
|
||||
import Data.Coerce (Coercible, coerce)
|
||||
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 = sub SELECT
|
||||
|
||||
-- | Project a field of an entity.
|
||||
(^.) :: forall typ val . (PersistEntity val, PersistField typ)
|
||||
|
||||
(^.) :: (PersistEntity val, PersistField typ)
|
||||
=> SqlExpr (Entity val)
|
||||
-> EntityField val typ
|
||||
-> SqlExpr typ
|
||||
ERaw m f ^. field
|
||||
(ERaw m f) ^. field
|
||||
| isIdField field = idFieldValue
|
||||
| Just alias <- sqlExprMetaAlias m =
|
||||
| Just alias <- sqlExprMetaAlias m =
|
||||
ERaw noMeta $ \_ info ->
|
||||
f Never info <> ("." <> useIdent info (aliasedEntityColumnIdent alias fieldDef), [])
|
||||
| otherwise = ERaw noMeta $ \_ info -> (dot info $ persistFieldDef field, [])
|
||||
@ -563,7 +565,10 @@ ERaw m f ^. field
|
||||
\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 =
|
||||
sourceIdent info <> "." <> fieldIdent
|
||||
@ -1136,6 +1141,13 @@ data SomeValue where
|
||||
class ToSomeValues a where
|
||||
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
|
||||
( ToSomeValues a
|
||||
, ToSomeValues b
|
||||
@ -2077,8 +2089,6 @@ parensM Parens = parens
|
||||
|
||||
data OrderByType = ASC | DESC
|
||||
|
||||
instance ToSomeValues (SqlExpr a) where
|
||||
toSomeValues a = [SomeValue a]
|
||||
|
||||
fieldName
|
||||
:: (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
|
||||
sqlSelectProcessRow p =
|
||||
let x = getType processRow
|
||||
getType :: SqlSelect a r => (z -> Either y (r,x)) -> Proxy a
|
||||
getType = const Proxy
|
||||
|
||||
colCountFst = sqlSelectColCount x
|
||||
|
||||
(fstP, sndP) = fromTupleP p
|
||||
let (fstP, sndP) = fromTupleP p
|
||||
colCountFst = sqlSelectColCount fstP
|
||||
processRow row =
|
||||
let (rowFst, rowSnd) = splitAt colCountFst row
|
||||
in (,) <$> sqlSelectProcessRow fstP rowFst
|
||||
|
||||
@ -1,25 +1,25 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE EmptyDataDecls #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE EmptyDataDecls #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE Rank2Types #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE Rank2Types #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-unused-binds #-}
|
||||
{-# OPTIONS_GHC -fno-warn-deprecations #-}
|
||||
@ -62,41 +62,38 @@ module Common.Test
|
||||
, Key(..)
|
||||
) where
|
||||
|
||||
import Control.Monad (forM_, replicateM,
|
||||
replicateM_, void)
|
||||
import Control.Monad.Catch (MonadCatch)
|
||||
import Control.Monad.Reader (ask)
|
||||
import Data.Either
|
||||
import Data.Time
|
||||
import Control.Monad (forM_, replicateM, replicateM_, void)
|
||||
import Control.Monad.Catch (MonadCatch)
|
||||
import Control.Monad.Reader (ask)
|
||||
import Data.Either
|
||||
import Data.Time
|
||||
#if __GLASGOW_HASKELL__ >= 806
|
||||
import Control.Monad.Fail (MonadFail)
|
||||
import Control.Monad.Fail (MonadFail)
|
||||
#endif
|
||||
import Control.Monad.IO.Class (MonadIO (liftIO))
|
||||
import Control.Monad.Logger (MonadLogger (..),
|
||||
NoLoggingT,
|
||||
runNoLoggingT)
|
||||
import Control.Monad.Trans.Reader (ReaderT)
|
||||
import qualified Data.Attoparsec.Text as AP
|
||||
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
|
||||
import Control.Monad.IO.Class (MonadIO(liftIO))
|
||||
import Control.Monad.Logger (MonadLogger(..), NoLoggingT, runNoLoggingT)
|
||||
import Control.Monad.Trans.Reader (ReaderT)
|
||||
import qualified Data.Attoparsec.Text as AP
|
||||
import Data.Char (toLower, toUpper)
|
||||
import Data.Monoid ((<>))
|
||||
import Database.Esqueleto
|
||||
import Database.Esqueleto.Experimental hiding
|
||||
(countRows_, from, groupBy, on, sum_, (?.), (^.))
|
||||
import qualified Database.Esqueleto.Experimental as EX
|
||||
import Database.Persist.TH
|
||||
import Test.Hspec
|
||||
import UnliftIO
|
||||
|
||||
import Data.Conduit (ConduitT, runConduit,
|
||||
(.|))
|
||||
import qualified Data.Conduit.List as CL
|
||||
import qualified Data.List as L
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Internal.Lazy as TL
|
||||
import qualified Data.Text.Lazy.Builder as TLB
|
||||
import Data.Conduit (ConduitT, runConduit, (.|))
|
||||
import qualified Data.Conduit.List as CL
|
||||
import qualified Data.List as L
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Internal.Lazy as TL
|
||||
import qualified Data.Text.Lazy.Builder as TLB
|
||||
import qualified Database.Esqueleto.Internal.ExprParser as P
|
||||
import qualified Database.Esqueleto.Internal.Sql as EI
|
||||
import qualified UnliftIO.Resource as R
|
||||
import qualified Database.Esqueleto.Internal.Sql as EI
|
||||
import qualified UnliftIO.Resource as R
|
||||
|
||||
-- Test schema
|
||||
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
|
||||
@ -458,10 +455,10 @@ testSubSelect run = do
|
||||
eres <- try $ run $ do
|
||||
setup
|
||||
bad <- select $
|
||||
from $ \n -> do
|
||||
from $ \(n :: SqlExpr (Entity Numbers)) -> do
|
||||
pure $ (,) (n ^. NumbersInt) $
|
||||
subSelectUnsafe $
|
||||
from $ \n' -> do
|
||||
from $ \(n' :: SqlExpr (Entity Numbers)) -> do
|
||||
pure (just (n' ^. NumbersDouble))
|
||||
good <- select $
|
||||
from $ \n -> do
|
||||
@ -484,10 +481,10 @@ testSubSelect run = do
|
||||
eres <- try $ run $ do
|
||||
setup
|
||||
select $
|
||||
from $ \n -> do
|
||||
from $ \(n :: SqlExpr (Entity Numbers)) -> do
|
||||
pure $ (,) (n ^. NumbersInt) $
|
||||
subSelectUnsafe $
|
||||
from $ \n' -> do
|
||||
from $ \(n' :: SqlExpr (Entity Numbers)) -> do
|
||||
where_ $ val False
|
||||
pure (n' ^. NumbersDouble)
|
||||
case eres of
|
||||
@ -501,14 +498,14 @@ testSelectSource run = do
|
||||
describe "selectSource" $ do
|
||||
it "works for a simple example" $ run $ do
|
||||
let query = selectSource $
|
||||
Experimental.from $ Table @Person
|
||||
EX.from $ Table @Person
|
||||
p1e <- insert' p1
|
||||
ret <- runConduit $ query .| CL.consume
|
||||
liftIO $ ret `shouldBe` [ p1e ]
|
||||
|
||||
it "can run a query many times" $ run $ do
|
||||
let query = selectSource $
|
||||
Experimental.from $ Table @Person
|
||||
EX.from $ Table @Person
|
||||
p1e <- insert' p1
|
||||
ret0 <- runConduit $ query .| CL.consume
|
||||
ret1 <- runConduit $ query .| CL.consume
|
||||
@ -537,7 +534,7 @@ testSelectFrom run = do
|
||||
describe "select/from" $ do
|
||||
it "works for a simple example" $ run $ do
|
||||
p1e <- insert' p1
|
||||
ret <- select $ Experimental.from $ Table @Person
|
||||
ret <- select $ EX.from $ Table @Person
|
||||
liftIO $ ret `shouldBe` [ p1e ]
|
||||
|
||||
it "works for a simple self-join (one entity)" $ run $ do
|
||||
@ -545,7 +542,7 @@ testSelectFrom run = do
|
||||
ret <-
|
||||
select $ do
|
||||
person1 :& person2 <-
|
||||
Experimental.from $ Table @Person
|
||||
EX.from $ Table @Person
|
||||
`crossJoin` Table @Person
|
||||
return (person1, person2)
|
||||
liftIO $ ret `shouldBe` [ (p1e, p1e) ]
|
||||
@ -556,7 +553,7 @@ testSelectFrom run = do
|
||||
ret <-
|
||||
select $ do
|
||||
person1 :& person2 <-
|
||||
Experimental.from $ Table @Person
|
||||
EX.from $ Table @Person
|
||||
`crossJoin` Table @Person
|
||||
return (person1, person2)
|
||||
liftIO $
|
||||
@ -672,7 +669,7 @@ testSelectFrom run = do
|
||||
number = 101
|
||||
Right thePk = keyFromValues [toPersistValue number]
|
||||
fcPk <- insert fc
|
||||
[Entity _ ret] <- select $ Experimental.from $ Table @Frontcover
|
||||
[Entity _ ret] <- select $ EX.from $ Table @Frontcover
|
||||
liftIO $ do
|
||||
ret `shouldBe` fc
|
||||
fcPk `shouldBe` thePk
|
||||
@ -879,9 +876,9 @@ testSelectSubQuery run = describe "select subquery" $ do
|
||||
it "works" $ run $ do
|
||||
_ <- insert' p1
|
||||
let q = do
|
||||
p <- Experimental.from $ Table @Person
|
||||
p <- EX.from $ Table @Person
|
||||
return ( p ^. PersonName, p ^. PersonAge)
|
||||
ret <- select $ Experimental.from q
|
||||
ret <- select $ EX.from q
|
||||
liftIO $ ret `shouldBe` [ (Value $ personName p1, Value $ personAge p1) ]
|
||||
|
||||
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])
|
||||
let l1WithDeeds = do d <- l1Deeds
|
||||
pure (l1e, Just d)
|
||||
let q = Experimental.from $ do
|
||||
let q = EX.from $ do
|
||||
(lords :& deeds) <-
|
||||
Experimental.from $ Table @Lord
|
||||
EX.from $ Table @Lord
|
||||
`LeftOuterJoin` Table @Deed
|
||||
`Experimental.on` (\(l :& d) -> just (l ^. LordId) ==. d ?. DeedOwnerId)
|
||||
`EX.on` (\(l :& d) -> just (l ^. LordId) ==. d ?. DeedOwnerId)
|
||||
pure (lords, deeds)
|
||||
|
||||
ret <- select q
|
||||
@ -905,8 +902,8 @@ testSelectSubQuery run = describe "select subquery" $ do
|
||||
_ <- insert' p3
|
||||
let q = do
|
||||
(name, age) <-
|
||||
Experimental.from $ SubQuery $ do
|
||||
p <- Experimental.from $ Table @Person
|
||||
EX.from $ SubQuery $ do
|
||||
p <- EX.from $ Table @Person
|
||||
return ( p ^. PersonName, p ^. PersonAge)
|
||||
orderBy [ asc age ]
|
||||
pure name
|
||||
@ -920,13 +917,13 @@ testSelectSubQuery run = describe "select subquery" $ do
|
||||
|
||||
mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int])
|
||||
let q = do
|
||||
(lord :& deed) <- Experimental.from $ Table @Lord
|
||||
(lord :& deed) <- EX.from $ Table @Lord
|
||||
`InnerJoin` Table @Deed
|
||||
`Experimental.on` (\(lord :& deed) ->
|
||||
`EX.on` (\(lord :& deed) ->
|
||||
lord ^. LordId ==. deed ^. DeedOwnerId)
|
||||
return (lord ^. LordId, deed ^. DeedId)
|
||||
q' = do
|
||||
(lordId, deedId) <- Experimental.from $ SubQuery q
|
||||
(lordId, deedId) <- EX.from $ SubQuery q
|
||||
groupBy (lordId)
|
||||
return (lordId, count deedId)
|
||||
(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])
|
||||
let q = do
|
||||
(lord :& deed) <- Experimental.from $ Table @Lord
|
||||
(lord :& deed) <- EX.from $ Table @Lord
|
||||
`InnerJoin` Table @Deed
|
||||
`Experimental.on` (\(lord :& deed) ->
|
||||
`EX.on` (\(lord :& deed) ->
|
||||
lord ^. LordId ==. deed ^. DeedOwnerId)
|
||||
groupBy (lord ^. LordId)
|
||||
groupBy (lord)
|
||||
return (lord ^. LordId, count (deed ^. DeedId))
|
||||
|
||||
(ret :: [(Value Int)]) <- select $ do
|
||||
(lordId, deedCount) <- Experimental.from $ SubQuery q
|
||||
(lordId, deedCount) <- EX.from $ SubQuery q
|
||||
where_ $ deedCount >. val (3 :: Int)
|
||||
return (count lordId)
|
||||
|
||||
@ -962,9 +959,9 @@ testSelectSubQuery run = describe "select subquery" $ do
|
||||
|
||||
mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int])
|
||||
let q = do
|
||||
(lord :& deed) <- Experimental.from $ Table @Lord
|
||||
`InnerJoin` (Experimental.from $ Table @Deed)
|
||||
`Experimental.on` (\(lord :& deed) ->
|
||||
(lord :& deed) <- EX.from $ Table @Lord
|
||||
`InnerJoin` (EX.from $ Table @Deed)
|
||||
`EX.on` (\(lord :& deed) ->
|
||||
lord ^. LordId ==. deed ^. DeedOwnerId)
|
||||
groupBy (lord ^. LordId)
|
||||
return (lord ^. LordId, count (deed ^. DeedId))
|
||||
@ -976,11 +973,11 @@ testSelectSubQuery run = describe "select subquery" $ do
|
||||
l1k <- insert l1
|
||||
l3k <- insert l3
|
||||
let q = do
|
||||
(lord :& (_, dogCounts)) <- Experimental.from $ Table @Lord
|
||||
(lord :& (_, dogCounts)) <- EX.from $ Table @Lord
|
||||
`LeftOuterJoin` do
|
||||
lord <- Experimental.from $ Table @Lord
|
||||
lord <- EX.from $ Table @Lord
|
||||
pure (lord ^. LordId, lord ^. LordDogs)
|
||||
`Experimental.on` (\(lord :& (lordId, _)) ->
|
||||
`EX.on` (\(lord :& (lordId, _)) ->
|
||||
just (lord ^. LordId) ==. lordId)
|
||||
groupBy (lord ^. LordId, dogCounts)
|
||||
return (lord ^. LordId, dogCounts)
|
||||
@ -990,19 +987,19 @@ testSelectSubQuery run = describe "select subquery" $ do
|
||||
it "unions" $ run $ do
|
||||
_ <- insert p1
|
||||
_ <- insert p2
|
||||
let q = Experimental.from $
|
||||
let q = EX.from $
|
||||
(do
|
||||
p <- Experimental.from $ Table @Person
|
||||
p <- EX.from $ Table @Person
|
||||
where_ $ not_ $ isNothing $ p ^. PersonAge
|
||||
return (p ^. PersonName))
|
||||
`union_`
|
||||
(do
|
||||
p <- Experimental.from $ Table @Person
|
||||
p <- EX.from $ Table @Person
|
||||
where_ $ isNothing $ p ^. PersonAge
|
||||
return (p ^. PersonName))
|
||||
`union_`
|
||||
(do
|
||||
p <- Experimental.from $ Table @Person
|
||||
p <- EX.from $ Table @Person
|
||||
where_ $ isNothing $ p ^. PersonAge
|
||||
return (p ^. PersonName))
|
||||
names <- select q
|
||||
@ -2350,7 +2347,7 @@ testExperimentalFrom run = do
|
||||
_ <- insert' p2
|
||||
p3e <- insert' p3
|
||||
peopleWithAges <- select $ do
|
||||
people <- Experimental.from $ Table @Person
|
||||
people <- EX.from $ Table @Person
|
||||
where_ $ not_ $ isNothing $ people ^. PersonAge
|
||||
return people
|
||||
liftIO $ peopleWithAges `shouldMatchList` [p1e, p3e]
|
||||
@ -2363,9 +2360,9 @@ testExperimentalFrom run = do
|
||||
d2e <- insert' $ Deed "2" (entityKey l1e)
|
||||
lordDeeds <- select $ do
|
||||
(lords :& deeds) <-
|
||||
Experimental.from $ Table @Lord
|
||||
EX.from $ Table @Lord
|
||||
`InnerJoin` Table @Deed
|
||||
`Experimental.on` (\(l :& d) -> l ^. LordId ==. d ^. DeedOwnerId)
|
||||
`EX.on` (\(l :& d) -> l ^. LordId ==. d ^. DeedOwnerId)
|
||||
pure (lords, deeds)
|
||||
liftIO $ lordDeeds `shouldMatchList` [ (l1e, d1e)
|
||||
, (l1e, d2e)
|
||||
@ -2379,9 +2376,9 @@ testExperimentalFrom run = do
|
||||
d2e <- insert' $ Deed "2" (entityKey l1e)
|
||||
lordDeeds <- select $ do
|
||||
(lords :& deeds) <-
|
||||
Experimental.from $ Table @Lord
|
||||
EX.from $ Table @Lord
|
||||
`LeftOuterJoin` Table @Deed
|
||||
`Experimental.on` (\(l :& d) -> just (l ^. LordId) ==. d ?. DeedOwnerId)
|
||||
`EX.on` (\(l :& d) -> just (l ^. LordId) ==. d ?. DeedOwnerId)
|
||||
|
||||
pure (lords, deeds)
|
||||
liftIO $ lordDeeds `shouldMatchList` [ (l1e, Just d1e)
|
||||
@ -2393,8 +2390,8 @@ testExperimentalFrom run = do
|
||||
insert_ l1
|
||||
insert_ l2
|
||||
insert_ l3
|
||||
delete $ void $ Experimental.from $ Table @Lord
|
||||
lords <- select $ Experimental.from $ Table @Lord
|
||||
delete $ void $ EX.from $ Table @Lord
|
||||
lords <- select $ EX.from $ Table @Lord
|
||||
liftIO $ lords `shouldMatchList` []
|
||||
|
||||
it "supports implicit cross joins" $ do
|
||||
@ -2402,11 +2399,11 @@ testExperimentalFrom run = do
|
||||
l1e <- insert' l1
|
||||
l2e <- insert' l2
|
||||
ret <- select $ do
|
||||
lords1 <- Experimental.from $ Table @Lord
|
||||
lords2 <- Experimental.from $ Table @Lord
|
||||
lords1 <- EX.from $ Table @Lord
|
||||
lords2 <- EX.from $ Table @Lord
|
||||
pure (lords1, lords2)
|
||||
ret2 <- select $ do
|
||||
(lords1 :& lords2) <- Experimental.from $ Table @Lord `CrossJoin` Table @Lord
|
||||
(lords1 :& lords2) <- EX.from $ Table @Lord `CrossJoin` Table @Lord
|
||||
pure (lords1,lords2)
|
||||
liftIO $ ret `shouldMatchList` ret2
|
||||
liftIO $ ret `shouldMatchList` [ (l1e, l1e)
|
||||
@ -2420,12 +2417,12 @@ testExperimentalFrom run = do
|
||||
run $ void $ do
|
||||
let q = do
|
||||
(persons :& profiles :& posts) <-
|
||||
Experimental.from $ Table @Person
|
||||
EX.from $ Table @Person
|
||||
`InnerJoin` Table @Profile
|
||||
`Experimental.on` (\(people :& profiles) ->
|
||||
`EX.on` (\(people :& profiles) ->
|
||||
people ^. PersonId ==. profiles ^. ProfilePerson)
|
||||
`LeftOuterJoin` Table @BlogPost
|
||||
`Experimental.on` (\(people :& _ :& posts) ->
|
||||
`EX.on` (\(people :& _ :& posts) ->
|
||||
just (people ^. PersonId) ==. posts ?. BlogPostAuthorId)
|
||||
pure (persons, posts, profiles)
|
||||
--error . show =<< renderQuerySelect q
|
||||
@ -2437,7 +2434,7 @@ testExperimentalFrom run = do
|
||||
insert_ p3
|
||||
-- Pretend this isnt all posts
|
||||
upperNames <- select $ do
|
||||
author <- Experimental.from $ SelectQuery $ Experimental.from $ Table @Person
|
||||
author <- EX.from $ SelectQuery $ EX.from $ Table @Person
|
||||
pure $ upper_ $ author ^. PersonName
|
||||
|
||||
liftIO $ upperNames `shouldMatchList` [ Value "JOHN"
|
||||
|
||||
Loading…
Reference in New Issue
Block a user