beam-core-0.11.1.0: Database/Beam/Query/Combinators.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE UndecidableInstances #-}
module Database.Beam.Query.Combinators
( -- * Various SQL functions and constructs
coalesce_, fromMaybe_, position_
, charLength_, octetLength_, bitLength_
, currentTimestamp_
, lower_, upper_
, trim_
-- ** @IF-THEN-ELSE@ support
, if_, then_, else_
, then_'
, ifThenElse_, bool_
-- * SQL @UPDATE@ assignments
, (<-.), current_
-- * Project Haskell values to 'QGenExpr's
, HaskellLiteralForQExpr
, SqlValable(..), SqlValableTable
, default_
-- * General query combinators
, all_, values_
, allFromView_, join_, join_'
, guard_, guard_', filter_, filter_'
, related_, relatedBy_, relatedBy_'
, leftJoin_, leftJoin_'
, perhaps_, outerJoin_, outerJoin_'
, subselect_, references_, references_'
, nub_
, SqlJustable(..)
, SqlDeconstructMaybe(..)
, SqlOrderable
, QIfCond, QIfElse
, (<|>.)
, limit_, limitMaybe_
, offset_, offsetMaybe_
, as_
-- ** Subqueries
, exists_, unique_, distinct_, subquery_
-- ** Set operations
-- | 'Q' values can be combined using a variety of set operations. See the
-- <https://haskell-beam.github.io/beam/user-guide/queries/combining-queries manual section>.
, union_, unionAll_
, intersect_, intersectAll_
, except_, exceptAll_
-- * Window functions
-- | See the corresponding
-- <https://haskell-beam.github.io/beam/user-guide/queries/window-functions manual section> for more.
, over_, frame_, bounds_, unbounded_, nrows_, fromBound_
, noBounds_, noOrder_, noPartition_
, partitionBy_, orderPartitionBy_, withWindow_
-- * Ordering primitives
, orderBy_, asc_, desc_, nullsFirst_, nullsLast_
) where
import Database.Beam.Backend.SQL
import Database.Beam.Backend.Types
import Database.Beam.Query.Internal
import Database.Beam.Query.Ord
import Database.Beam.Query.Operator
import Database.Beam.Query.Types
import Database.Beam.Schema.Tables
import Control.Monad.Identity
import Control.Monad.Free
import Control.Applicative
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe
import Data.Proxy
import Data.Time (LocalTime)
import Unsafe.Coerce (unsafeCoerce)
import GHC.TypeLits (TypeError, ErrorMessage(Text))
-- | Introduce all entries of a table into the 'Q' monad
all_ :: BeamSqlBackend be
=> DatabaseEntity be db (TableEntity table)
-> Q be db s (table (QExpr be s))
all_ (DatabaseEntity dt@(DatabaseTable {})) =
Q $ liftF (QAll (\_ -> fromTable (tableNamed (tableName (dbTableSchema dt) (dbTableCurrentName dt))) . Just . (,Nothing))
(tableFieldsToExpressions (dbTableSettings dt))
(\_ -> Nothing) snd)
-- | Introduce all entries of a view into the 'Q' monad
allFromView_ :: ( Beamable table, BeamSqlBackend be )
=> DatabaseEntity be db (ViewEntity table)
-> Q be db s (table (QExpr be s))
allFromView_ (DatabaseEntity vw) =
Q $ liftF (QAll (\_ -> fromTable (tableNamed (tableName (dbViewSchema vw) (dbViewCurrentName vw))) . Just . (,Nothing))
(tableFieldsToExpressions (dbViewSettings vw))
(\_ -> Nothing) snd)
-- | SQL @VALUES@ clause. Introduce the elements of the given non-empty list as
-- rows in a joined table.
values_ :: forall be db s a
. ( Projectible be a
, BeamSqlBackend be )
=> NonEmpty a
-> Q be db s a
values_ rows =
Q $ liftF (QAll (\tblPfx ->
fromTable
(tableFromValues (NonEmpty.toList (NonEmpty.map (\row -> project (Proxy @be) row tblPfx) rows)))
. Just
. (,Just fieldNames))
(\tblNm' -> fst $ mkFieldNames (qualifiedField tblNm'))
(\_ -> Nothing) snd
)
where
fieldNames = snd $ mkFieldNames @be @a unqualifiedField
-- | Introduce all entries of a table into the 'Q' monad based on the
-- given QExpr. The join condition is expected to return a
-- 'Bool'. For a version that takes 'SqlBool' (a possibly @UNKNOWN@
-- boolean, that maps more closely to the SQL standard), see
-- 'join_''.
join_ :: ( Table table, BeamSqlBackend be )
=> DatabaseEntity be db (TableEntity table)
-> (table (QExpr be s) -> QExpr be s Bool)
-> Q be db s (table (QExpr be s))
join_ tbl mkOn = join_' tbl (sqlBool_ . mkOn)
-- | Like 'join_', but accepting an @ON@ condition that returns
-- 'SqlBool'
join_' :: ( Table table, BeamSqlBackend be )
=> DatabaseEntity be db (TableEntity table)
-> (table (QExpr be s) -> QExpr be s SqlBool)
-> Q be db s (table (QExpr be s))
join_' (DatabaseEntity tbl@(DatabaseTable {})) mkOn =
Q $ liftF (QAll (\_ -> fromTable (tableNamed (tableName (dbTableSchema tbl) (dbTableCurrentName tbl))) . Just . (, Nothing))
(tableFieldsToExpressions (dbTableSettings tbl))
(\tbl' -> let QExpr on = mkOn tbl' in Just on) snd)
-- | Introduce a table using a left join with no ON clause. Because this is not
-- an inner join, the resulting table is made nullable. This means that each
-- field that would normally have type 'QExpr x' will now have type 'QExpr
-- (Maybe x)'.
perhaps_ :: forall s r be db.
( Projectible be r, BeamSqlBackend be
, ThreadRewritable (QNested s) r
, Retaggable (QExpr be s) (WithRewrittenThread (QNested s) s r) )
=> Q be db (QNested s) r
-> Q be db s (Retag Nullable (WithRewrittenThread (QNested s) s r))
perhaps_ (Q sub) =
Q $ liftF (QArbitraryJoin
sub "" leftJoin
(\_ -> Nothing)
(\r -> retag (\(Columnar' (QExpr e) :: Columnar' (QExpr be s) a) ->
Columnar' (QExpr e) :: Columnar' (Nullable (QExpr be s)) a) $
rewriteThread (Proxy @s) r))
-- | Outer join. every row of each table, returning @NULL@ for any row
-- of either table for which the join condition finds no related rows.
--
-- This expects a join expression returning 'Bool', for a version that
-- accepts a 'SqlBool' (a possibly @UNKNOWN@ boolean, that maps more
-- closely to the SQL standard), see 'outerJoin_''
outerJoin_ :: forall s a b be db.
( BeamSqlBackend be, BeamSqlBackendSupportsOuterJoin be
, Projectible be a, Projectible be b
, ThreadRewritable (QNested s) a, ThreadRewritable (QNested s) b
, Retaggable (QExpr be s) (WithRewrittenThread (QNested s) s a)
, Retaggable (QExpr be s) (WithRewrittenThread (QNested s) s b)
)
=> Q be db (QNested s) a
-> Q be db (QNested s) b
-> ( (WithRewrittenThread (QNested s) s a, WithRewrittenThread (QNested s) s b) -> QExpr be s Bool )
-> Q be db s ( Retag Nullable (WithRewrittenThread (QNested s) s a)
, Retag Nullable (WithRewrittenThread (QNested s) s b) )
outerJoin_ a b on_ = outerJoin_' a b (sqlBool_ . on_)
-- | Like 'outerJoin_', but accepting 'SqlBool'. Pairs of rows for
-- which the join condition is unknown are considered to be unrelated,
-- by SQL compliant databases at least.
outerJoin_' :: forall s a b be db.
( BeamSqlBackend be, BeamSqlBackendSupportsOuterJoin be
, Projectible be a, Projectible be b
, ThreadRewritable (QNested s) a, ThreadRewritable (QNested s) b
, Retaggable (QExpr be s) (WithRewrittenThread (QNested s) s a)
, Retaggable (QExpr be s) (WithRewrittenThread (QNested s) s b)
)
=> Q be db (QNested s) a
-> Q be db (QNested s) b
-> ( (WithRewrittenThread (QNested s) s a, WithRewrittenThread (QNested s) s b) -> QExpr be s SqlBool )
-> Q be db s ( Retag Nullable (WithRewrittenThread (QNested s) s a)
, Retag Nullable (WithRewrittenThread (QNested s) s b) )
outerJoin_' (Q a) (Q b) on_ =
Q $ liftF (QTwoWayJoin a b outerJoin
(\(a', b') ->
let QExpr e = on_ (rewriteThread (Proxy @s) a', rewriteThread (Proxy @s) b')
in Just e)
(\(a', b') ->
let retag' :: (ThreadRewritable (QNested s) x, Retaggable (QExpr be s) (WithRewrittenThread (QNested s) s x))
=> x -> Retag Nullable (WithRewrittenThread (QNested s) s x)
retag' = retag (\(Columnar' (QExpr e) :: Columnar' (QExpr be s) x) ->
Columnar' (QExpr e) :: Columnar' (Nullable (QExpr be s)) x) .
rewriteThread (Proxy @s)
in ( retag' a', retag' b' )))
-- | Introduce a table using a left join. The ON clause is required here.Because
-- this is not an inner join, the resulting table is made nullable. This means
-- that each field that would normally have type 'QExpr x' will now have type
-- 'QExpr (Maybe x)'.
--
-- The @ON@ condition given must return 'Bool'. For a version that
-- accepts an @ON@ condition returning 'SqlBool', see 'leftJoin_''.
leftJoin_ :: forall s r be db.
( BeamSqlBackend be, Projectible be r
, ThreadRewritable (QNested s) r
, Retaggable (QExpr be s) (WithRewrittenThread (QNested s) s r) )
=> Q be db (QNested s) r
-> (WithRewrittenThread (QNested s) s r -> QExpr be s Bool)
-> Q be db s (Retag Nullable (WithRewrittenThread (QNested s) s r))
leftJoin_ sub on_ = leftJoin_' sub (sqlBool_ . on_)
-- | Like 'leftJoin_', but accepts an @ON@ clause returning 'SqlBool'.
leftJoin_' :: forall s r be db.
( BeamSqlBackend be, Projectible be r
, ThreadRewritable (QNested s) r
, Retaggable (QExpr be s) (WithRewrittenThread (QNested s) s r) )
=> Q be db (QNested s) r
-> (WithRewrittenThread (QNested s) s r -> QExpr be s SqlBool)
-> Q be db s (Retag Nullable (WithRewrittenThread (QNested s) s r))
leftJoin_' (Q sub) on_ =
Q $ liftF (QArbitraryJoin
sub "" leftJoin
(\r -> let QExpr e = on_ (rewriteThread (Proxy @s) r) in Just e)
(\r -> retag (\(Columnar' (QExpr e) :: Columnar' (QExpr be s) a) ->
Columnar' (QExpr e) :: Columnar' (Nullable (QExpr be s)) a) $
rewriteThread (Proxy @s) r))
subselect_ :: forall s r be db.
( ThreadRewritable (QNested s) r
, Projectible be r )
=> Q be db (QNested s) r
-> Q be db s (WithRewrittenThread (QNested s) s r)
subselect_ (Q q') =
Q (liftF (QSubSelect q' (rewriteThread (Proxy @s))))
-- | Only allow results for which the 'QExpr' yields 'True'. For a
-- version that operates over possibly @NULL@ 'SqlBool's, see
-- 'guard_''.
guard_ :: forall be db s
. BeamSqlBackend be
=> QExpr be s Bool -> Q be db s ()
guard_ = guard_' . sqlBool_
-- | Only allow results for which the 'QExpr' yields @TRUE@.
--
-- This function operates over 'SqlBool', which are like haskell
-- 'Bool's, except for the special @UNKNOWN@ value that occurs when
-- comparisons include @NULL@. For a version that operates over known
-- non-@NULL@ booleans, see 'guard_'.
guard_' :: forall be db s
. BeamSqlBackend be
=> QExpr be s SqlBool -> Q be db s ()
guard_' (QExpr guardE') = Q (liftF (QGuard guardE' ()))
-- | Synonym for @clause >>= \\x -> guard_ (mkExpr x)>> pure x@. Use 'filter_'' for comparisons with 'SqlBool'
filter_ :: forall r be db s
. BeamSqlBackend be
=> (r -> QExpr be s Bool)
-> Q be db s r -> Q be db s r
filter_ mkExpr clause = clause >>= \x -> guard_ (mkExpr x) >> pure x
-- | Synonym for @clause >>= \\x -> guard_' (mkExpr x)>> pure x@. Use 'filter_' for comparisons with 'Bool'
filter_' :: forall r be db s
. BeamSqlBackend be
=> (r -> QExpr be s SqlBool)
-> Q be db s r -> Q be db s r
filter_' mkExpr clause = clause >>= \x -> guard_' (mkExpr x) >> pure x
-- | Introduce all entries of the given table which are referenced by the given 'PrimaryKey'
related_ :: forall be db rel s
. ( Table rel, BeamSqlBackend be
, HasTableEquality be (PrimaryKey rel)
)
=> DatabaseEntity be db (TableEntity rel)
-> PrimaryKey rel (QExpr be s)
-> Q be db s (rel (QExpr be s))
related_ relTbl relKey =
join_ relTbl (\rel -> relKey ==. primaryKey rel)
-- | Introduce all entries of the given table for which the expression (which can depend on the queried table returns true)
relatedBy_ :: forall be db rel s
. ( Table rel, BeamSqlBackend be )
=> DatabaseEntity be db (TableEntity rel)
-> (rel (QExpr be s) -> QExpr be s Bool)
-> Q be db s (rel (QExpr be s))
relatedBy_ = join_
-- | Introduce all entries of the given table for which the expression (which can depend on the queried table returns true)
relatedBy_' :: forall be db rel s
. ( Table rel, BeamSqlBackend be )
=> DatabaseEntity be db (TableEntity rel)
-> (rel (QExpr be s) -> QExpr be s SqlBool)
-> Q be db s (rel (QExpr be s))
relatedBy_' = join_'
-- | Generate an appropriate boolean 'QGenExpr' comparing the given foreign key
-- to the given table. Useful for creating join conditions.
-- Use 'references_'' for a 'SqlBool' comparison.
references_ :: ( Table t, BeamSqlBackend be
, HasTableEquality be (PrimaryKey t) )
=> PrimaryKey t (QGenExpr ctxt be s) -> t (QGenExpr ctxt be s) -> QGenExpr ctxt be s Bool
references_ fk tbl = fk ==. pk tbl
-- | Generate an appropriate boolean 'QGenExpr' comparing the given foreign key
-- to the given table. Useful for creating join conditions.
-- Use 'references_' for a 'Bool' comparison.
references_' :: ( Table t, BeamSqlBackend be
, HasTableEquality be (PrimaryKey t) )
=> PrimaryKey t (QGenExpr ctxt be s) -> t (QGenExpr ctxt be s) -> QGenExpr ctxt be s SqlBool
references_' fk tbl = fk ==?. pk tbl
-- | Only return distinct values from a query
nub_ :: ( BeamSqlBackend be, Projectible be r )
=> Q be db s r -> Q be db s r
nub_ (Q sub) = Q $ liftF (QDistinct (\_ _ -> setQuantifierDistinct) sub id)
-- | Limit the number of results returned by a query.
--
-- See also `limitMaybe_` to conditionally apply a limit.
limit_ :: forall s a be db
. ( Projectible be a
, ThreadRewritable (QNested s) a )
=> Integer -> Q be db (QNested s) a -> Q be db s (WithRewrittenThread (QNested s) s a)
limit_ limit' (Q q) =
Q (liftF (QLimit limit' q (rewriteThread (Proxy @s))))
-- | Conditionally limit the number of results returned by a query.
--
-- @since 0.10.4.0
limitMaybe_ :: forall s a be db
. ( Projectible be a
, ThreadRewritable (QNested s) a )
=> Maybe Integer -> Q be db (QNested s) a -> Q be db s (WithRewrittenThread (QNested s) s a)
limitMaybe_ (Just limit') (Q q) =
Q (liftF (QLimit limit' q (rewriteThread (Proxy @s))))
-- This uses unsafeCoerce, but should be safe since this function is tested.
-- See discussion on https://github.com/haskell-beam/beam/pull/633.
limitMaybe_ Nothing (Q q) = Q (unsafeCoerce q)
-- | Drop the first `offset` results.
--
-- See also `offsetMaybe_` to conditionally apply an offset
offset_ :: forall s a be db
. ( Projectible be a
, ThreadRewritable (QNested s) a )
=> Integer -> Q be db (QNested s) a -> Q be db s (WithRewrittenThread (QNested s) s a)
offset_ offset' (Q q) =
Q (liftF (QOffset offset' q (rewriteThread (Proxy @s))))
-- | Conditionally drop the first `offset` results.
--
-- @since 0.10.4.0
offsetMaybe_ :: forall s a be db
. ( Projectible be a
, ThreadRewritable (QNested s) a )
=> Maybe Integer -> Q be db (QNested s) a -> Q be db s (WithRewrittenThread (QNested s) s a)
offsetMaybe_ (Just offset') (Q q) =
Q (liftF (QOffset offset' q (rewriteThread (Proxy @s))))
-- This uses unsafeCoerce, but should be safe since this function is tested.
-- See discussion on https://github.com/haskell-beam/beam/pull/633.
offsetMaybe_ Nothing (Q q) = Q (unsafeCoerce q)
-- | Use the SQL @EXISTS@ operator to determine if the given query returns any results
exists_ :: ( BeamSqlBackend be, HasQBuilder be, Projectible be a)
=> Q be db s a -> QExpr be s Bool
exists_ q = QExpr (\tbl -> existsE (buildSqlQuery tbl q))
-- | Use the SQL @UNIQUE@ operator to determine if the given query produces a unique result
unique_ :: ( BeamSqlBackend be, HasQBuilder be, Projectible be a)
=> Q be db s a -> QExpr be s Bool
unique_ q = QExpr (\tbl -> uniqueE (buildSqlQuery tbl q))
-- | Use the SQL99 @DISTINCT@ operator to determine if the given query produces a distinct result
distinct_ :: ( BeamSqlBackend be, BeamSql99ExpressionBackend be, HasQBuilder be, Projectible be a)
=> Q be db s a -> QExpr be s Bool
distinct_ q = QExpr (\tbl -> distinctE (buildSqlQuery tbl q))
-- | Project the (presumably) singular result of the given query as an expression
subquery_ :: ( BeamSqlBackend be, HasQBuilder be, Projectible be (QExpr be s a) )
=> Q be db s (QExpr be s a)
-> QGenExpr ctxt be s a
subquery_ q =
QExpr (\tbl -> subqueryE (buildSqlQuery tbl q))
-- | SQL @CHAR_LENGTH@ function
charLength_ :: ( BeamSqlBackend be, BeamSqlBackendIsString be text, Integral a )
=> QGenExpr context be s text -> QGenExpr context be s a
charLength_ (QExpr s) = QExpr (charLengthE <$> s)
-- | SQL @OCTET_LENGTH@ function
octetLength_ :: ( BeamSqlBackend be, BeamSqlBackendIsString be text, Integral a )
=> QGenExpr context be s text -> QGenExpr context be s a
octetLength_ (QExpr s) = QExpr (octetLengthE <$> s)
-- | SQL @BIT_LENGTH@ function
bitLength_ :: ( BeamSqlBackend be, Integral a )
=> QGenExpr context be s SqlBitString -> QGenExpr context be s a
bitLength_ (QExpr x) = QExpr (bitLengthE <$> x)
-- | SQL @CURRENT_TIMESTAMP@ function
currentTimestamp_ :: BeamSqlBackend be => QGenExpr ctxt be s LocalTime
currentTimestamp_ = QExpr (pure currentTimestampE)
-- | SQL @POSITION(.. IN ..)@ function
position_ :: ( BeamSqlBackendIsString be text
, BeamSqlBackend be, Integral b )
=> QExpr be s text -> QExpr be s text -> QExpr be s b
position_ (QExpr needle) (QExpr haystack) =
QExpr (liftA2 likeE needle haystack)
-- | SQL @LOWER@ function
lower_ :: ( BeamSqlBackendIsString be text
, BeamSqlBackend be )
=> QGenExpr context be s text -> QGenExpr context be s text
lower_ (QExpr s) = QExpr (lowerE <$> s)
-- | SQL @UPPER@ function
upper_ :: ( BeamSqlBackendIsString be text
, BeamSqlBackend be )
=> QGenExpr context be s text -> QGenExpr context be s text
upper_ (QExpr s) = QExpr (upperE <$> s)
-- | SQL @TRIM@ function
trim_ :: ( BeamSqlBackendIsString be text
, BeamSqlBackend be )
=> QGenExpr context be s text -> QGenExpr context be s text
trim_ (QExpr s) = QExpr (trimE <$> s)
-- | Combine all the given boolean value 'QGenExpr's with the '&&.' operator.
allE :: BeamSqlBackend be
=> [ QGenExpr context be s Bool ] -> QGenExpr context be s Bool
allE es = fromMaybe (QExpr (pure (valueE (sqlValueSyntax True)))) $
foldl (\expr x ->
Just $ maybe x (\e -> e &&. x) expr)
Nothing es
-- * UPDATE operators
-- | Extract an expression representing the current (non-UPDATEd) value of a 'QField'
current_ :: BeamSqlBackend be => QField s ty -> QExpr be s ty
current_ (QField False _ nm) = QExpr (pure (fieldE (unqualifiedField nm)))
current_ (QField True tbl nm) = QExpr (pure (fieldE (qualifiedField tbl nm)))
infix 4 <-.
class BeamSqlBackend be =>
SqlUpdatable be s lhs rhs | rhs -> be, lhs -> s
, rhs -> s, lhs s be -> rhs
, rhs -> lhs where
-- | Update a 'QField' or 'Beamable' type containing 'QField's with the given
-- 'QExpr' or 'Beamable' type containing 'QExpr'
(<-.) :: lhs
-> rhs
-> QAssignment be s
instance BeamSqlBackend be => SqlUpdatable be s (QField s a) (QExpr be s a) where
QField _ _ nm <-. QExpr expr =
QAssignment [(unqualifiedField nm, expr "t")]
instance (BeamSqlBackend be, Beamable tbl) => SqlUpdatable be s (tbl (QField s)) (tbl (QExpr be s)) where
lhs <-. rhs =
QAssignment $
allBeamValues (\(Columnar' (Const assignments)) -> assignments) $
runIdentity $
zipBeamFieldsM (\(Columnar' (QField _ _ f) :: Columnar' (QField s) t) (Columnar' (QExpr e)) ->
pure (Columnar' (Const (unqualifiedField f, e "t")) :: Columnar' (Const (BeamSqlBackendFieldNameSyntax be, BeamSqlBackendExpressionSyntax be)) t)) lhs rhs
instance (BeamSqlBackend be, Beamable tbl) => SqlUpdatable be s (tbl (Nullable (QField s))) (tbl (Nullable (QExpr be s))) where
lhs <-. rhs =
let lhs' = changeBeamRep (\(Columnar' (QField q tblName fieldName') :: Columnar' (Nullable (QField s)) a) ->
Columnar' (QField q tblName fieldName') :: Columnar' (QField s) a) lhs
rhs' = changeBeamRep (\(Columnar' (QExpr e) :: Columnar' (Nullable (QExpr be s)) a) ->
Columnar' (QExpr e) :: Columnar' (QExpr be s) a) rhs
in lhs' <-. rhs'
-- | SQL @UNION@ operator
union_ :: forall be db s a
. ( BeamSqlBackend be, Projectible be a
, ThreadRewritable (QNested s) a )
=> Q be db (QNested s) a -> Q be db (QNested s) a
-> Q be db s (WithRewrittenThread (QNested s) s a)
union_ (Q a) (Q b) = Q (liftF (QSetOp (unionTables False) a b (rewriteThread (Proxy @s))))
-- | SQL @UNION ALL@ operator
unionAll_ :: forall be db s a.
( BeamSqlBackend be, Projectible be a
, ThreadRewritable (QNested s) a)
=> Q be db (QNested s) a -> Q be db (QNested s) a
-> Q be db s (WithRewrittenThread (QNested s) s a)
unionAll_ (Q a) (Q b) = Q (liftF (QSetOp (unionTables True) a b (rewriteThread (Proxy @s))))
-- | SQL @INTERSECT@ operator
intersect_ :: forall be db s a.
( BeamSqlBackend be, Projectible be a
, ThreadRewritable (QNested s) a)
=> Q be db (QNested s) a -> Q be db (QNested s) a
-> Q be db s (WithRewrittenThread (QNested s) s a)
intersect_ (Q a) (Q b) = Q (liftF (QSetOp (intersectTables False) a b (rewriteThread (Proxy @s))))
-- | SQL @INTERSECT ALL@ operator
intersectAll_ :: forall be db s a.
( BeamSqlBackend be, Projectible be a
, ThreadRewritable (QNested s) a)
=> Q be db (QNested s) a -> Q be db (QNested s) a
-> Q be db s (WithRewrittenThread (QNested s) s a)
intersectAll_ (Q a) (Q b) = Q (liftF (QSetOp (intersectTables True) a b (rewriteThread (Proxy @s))))
-- | SQL @EXCEPT@ operator
except_ :: forall be db s a.
( BeamSqlBackend be, Projectible be a
, ThreadRewritable (QNested s) a)
=> Q be db (QNested s) a -> Q be db (QNested s) a
-> Q be db s (WithRewrittenThread (QNested s) s a)
except_ (Q a) (Q b) = Q (liftF (QSetOp (exceptTable False) a b (rewriteThread (Proxy @s))))
-- | SQL @EXCEPT ALL@ operator
exceptAll_ :: forall be db s a.
( BeamSqlBackend be, Projectible be a
, ThreadRewritable (QNested s) a)
=> Q be db (QNested s) a -> Q be db (QNested s) a
-> Q be db s (WithRewrittenThread (QNested s) s a)
exceptAll_ (Q a) (Q b) = Q (liftF (QSetOp (exceptTable True) a b (rewriteThread (Proxy @s))))
-- | Convenience function that allows you to use type applications to specify
-- the result of a 'QGenExpr'.
--
-- Useful to disambiguate the types of 'QGenExpr's without having to provide a
-- complete type signature. As an example, the 'countAll_' aggregate can
-- return a result of any 'Integral' type. Without further constraints, the
-- type is ambiguous. You can use 'as_' to disambiguate the return type.
--
-- For example, this is ambiguous
--
-- > aggregate_ (\_ -> countAll_) ..
--
-- But this is not
--
-- > aggregate_ (\_ -> as_ @Int32 countAll_) ..
--
as_ :: forall a ctxt be s. QGenExpr ctxt be s a -> QGenExpr ctxt be s a
as_ = id
-- * Marshalling between Haskell literals and QExprs
type family HaskellLiteralForQExpr x = a
type instance HaskellLiteralForQExpr (QGenExpr context be s a) = a
type instance HaskellLiteralForQExpr (table (QGenExpr context be s)) = table Identity
type instance HaskellLiteralForQExpr (table (Nullable f)) = HaskellLiteralForQExpr_AddNullable (HaskellLiteralForQExpr (table f))
type family HaskellLiteralForQExpr_AddNullable x = a
type instance HaskellLiteralForQExpr_AddNullable (tbl f) = tbl (Nullable f)
type SqlValableTable be table =
( Beamable table
, FieldsFulfillConstraint (HasSqlValueSyntax (BeamSqlBackendValueSyntax be)) table )
class SqlValable a where
val_ :: HaskellLiteralForQExpr a -> a
instance ( BeamSqlBackendCanSerialize be a, BeamSqlBackend be ) =>
SqlValable (QGenExpr ctxt be s a) where
val_ = QExpr . pure . valueE . sqlValueSyntax
instance ( Beamable table, BeamSqlBackend be
, FieldsFulfillConstraint (BeamSqlBackendCanSerialize be) table ) =>
SqlValable (table (QGenExpr ctxt be s)) where
val_ tbl =
let fields :: table (WithConstraint (BeamSqlBackendCanSerialize be))
fields = withConstrainedFields tbl
in changeBeamRep (\(Columnar' (WithConstraint x :: WithConstraint (BeamSqlBackendCanSerialize be) x)) ->
Columnar' (QExpr (pure (valueE (sqlValueSyntax x))))) fields
instance ( Beamable table, BeamSqlBackend be
, FieldsFulfillConstraintNullable (BeamSqlBackendCanSerialize be) table ) =>
SqlValable (table (Nullable (QGenExpr ctxt be s))) where
val_ tbl =
let fields :: table (Nullable (WithConstraint (BeamSqlBackendCanSerialize be)))
fields = withNullableConstrainedFields tbl
in changeBeamRep (\(Columnar' (WithConstraint x :: WithConstraint (BeamSqlBackendCanSerialize be) (Maybe x))) ->
Columnar' (QExpr (pure (valueE (sqlValueSyntax x))))) fields
-- | SQL @DEFAULT@ support.
--
-- Note that `default_` has restrictions not currently represented in the Haskell type system.
-- For example, using `default_` as the argument to a function like `coalesce_`
-- will result in a runtime error, just like the SQL code @COALESCE (NULL, DEFAULT)@
-- would raise a runtime error.
default_ :: BeamSqlBackend be => QGenExpr ctxt be s a
-- See #744 for issues with `default_`.
default_ = QExpr (pure defaultE)
-- * Window functions
noBounds_ :: QFrameBounds be
noBounds_ = QFrameBounds Nothing
fromBound_ :: BeamSql2003ExpressionBackend be
=> QFrameBound be -> QFrameBounds be
fromBound_ start = bounds_ start Nothing
bounds_ :: BeamSql2003ExpressionBackend be
=> QFrameBound be
-> Maybe (QFrameBound be)
-> QFrameBounds be
bounds_ (QFrameBound start) end =
QFrameBounds . Just $
fromToBoundSyntax start
(fmap (\(QFrameBound end') -> end') end)
unbounded_ :: BeamSql2003ExpressionBackend be => QFrameBound be
unbounded_ = QFrameBound unboundedSyntax
nrows_ :: BeamSql2003ExpressionBackend be
=> Int -> QFrameBound be
nrows_ x = QFrameBound (nrowsBoundSyntax x)
noPartition_ :: Integral a => Maybe (QExpr be s a)
noPartition_ = Nothing
noOrder_ :: Integral a => Maybe (QOrd be s a)
noOrder_ = Nothing
partitionBy_, orderPartitionBy_ :: partition -> Maybe partition
partitionBy_ = Just
orderPartitionBy_ = Just
-- | Specify a window frame with all the options
frame_ :: forall be ordering partition s
. ( BeamSql2003ExpressionBackend be
, SqlOrderable be ordering
, Projectible be partition )
=> Maybe partition {-^ PARTITION BY -}
-> Maybe ordering {-^ ORDER BY -}
-> QFrameBounds be {-^ RANGE / ROWS -}
-> QWindow be s
frame_ partition_ ordering_ (QFrameBounds bounds) =
QWindow $ \tblPfx ->
frameSyntax (case maybe [] (flip (project (Proxy @be)) tblPfx) partition_ of
[] -> Nothing
xs -> Just xs)
(case fmap (makeSQLOrdering (Proxy @be)) ordering_ of
Nothing -> Nothing
Just [] -> Nothing
Just xs -> Just (sequenceA xs tblPfx))
bounds
-- | Produce a window expression given an aggregate function and a window.
over_ :: BeamSql2003ExpressionBackend be
=> QAgg be s a -> QWindow be s -> QWindowExpr be s a
over_ (QExpr a) (QWindow frame) = QExpr (overE <$> a <*> frame)
-- | Compute a query over windows.
--
-- The first function builds window frames using the 'frame_', 'partitionBy_',
-- etc functions. The return type can be a single frame, tuples of frame, or
-- any arbitrarily nested tuple of the above. Instances up to 8-tuples are
-- provided.
--
-- The second function builds the resulting projection using the result of the
-- subquery as well as the window frames built in the first function. In this
-- function, window expressions can be included in the output using the
-- 'over_' function.
--
withWindow_ :: forall window a s r be db
. ( ProjectibleWithPredicate WindowFrameContext be (WithExprContext (BeamSqlBackendWindowFrameSyntax' be)) window
, Projectible be r, Projectible be a
, ContextRewritable a
, ThreadRewritable (QNested s) (WithRewrittenContext a QValueContext) )
=> (r -> window) -- ^ Window builder function
-> (r -> window -> a) -- ^ Projection builder function. Has access to the windows generated above
-> Q be db (QNested s) r -- ^ Query to window over
-> Q be db s (WithRewrittenThread (QNested s) s (WithRewrittenContext a QValueContext))
withWindow_ mkWindow mkProjection (Q windowOver)=
Q (liftF (QWindowOver mkWindow mkProjection windowOver (rewriteThread (Proxy @s) . rewriteContext (Proxy @QValueContext))))
-- * Order bys
class SqlOrderable be a | a -> be where
makeSQLOrdering :: Proxy be -> a -> [ WithExprContext (BeamSqlBackendOrderingSyntax be) ]
instance SqlOrderable be (QOrd be s a) where
makeSQLOrdering _ (QOrd x) = [x]
instance TypeError ('Text "Missing mandatory sorting order. Use either 'asc_' or 'desc_' to specify sorting order.") =>
SqlOrderable be (QGenExpr ctx be s a) where
makeSQLOrdering = error "unreachable SqlOrderable QGenExpr instance"
instance SqlOrderable be a => SqlOrderable be [a] where
makeSQLOrdering be = concatMap (makeSQLOrdering be)
instance ( SqlOrderable be a, SqlOrderable be b ) => SqlOrderable be (a, b) where
makeSQLOrdering be (a, b) =
makeSQLOrdering be a <> makeSQLOrdering be b
instance ( SqlOrderable be a, SqlOrderable be b
, SqlOrderable be c ) => SqlOrderable be (a, b, c) where
makeSQLOrdering be (a, b, c) =
makeSQLOrdering be a <> makeSQLOrdering be b <> makeSQLOrdering be c
instance ( SqlOrderable be a, SqlOrderable be b
, SqlOrderable be c, SqlOrderable be d ) => SqlOrderable be (a, b, c, d) where
makeSQLOrdering be (a, b, c, d) =
makeSQLOrdering be a <> makeSQLOrdering be b <> makeSQLOrdering be c <> makeSQLOrdering be d
instance ( SqlOrderable be a, SqlOrderable be b
, SqlOrderable be c, SqlOrderable be d
, SqlOrderable be e ) => SqlOrderable be (a, b, c, d, e) where
makeSQLOrdering be (a, b, c, d, e) =
makeSQLOrdering be a <> makeSQLOrdering be b <> makeSQLOrdering be c <> makeSQLOrdering be d <>
makeSQLOrdering be e
instance ( SqlOrderable be a, SqlOrderable be b
, SqlOrderable be c, SqlOrderable be d
, SqlOrderable be e, SqlOrderable be f ) => SqlOrderable be (a, b, c, d, e, f) where
makeSQLOrdering be (a, b, c, d, e, f) =
makeSQLOrdering be a <> makeSQLOrdering be b <> makeSQLOrdering be c <> makeSQLOrdering be d <>
makeSQLOrdering be e <> makeSQLOrdering be f
instance ( SqlOrderable be a, SqlOrderable be b
, SqlOrderable be c, SqlOrderable be d
, SqlOrderable be e, SqlOrderable be f
, SqlOrderable be g ) => SqlOrderable be (a, b, c, d, e, f, g) where
makeSQLOrdering be (a, b, c, d, e, f, g) =
makeSQLOrdering be a <> makeSQLOrdering be b <> makeSQLOrdering be c <> makeSQLOrdering be d <>
makeSQLOrdering be e <> makeSQLOrdering be f <> makeSQLOrdering be g
instance ( SqlOrderable be a, SqlOrderable be b
, SqlOrderable be c, SqlOrderable be d
, SqlOrderable be e, SqlOrderable be f
, SqlOrderable be g, SqlOrderable be h ) => SqlOrderable be (a, b, c, d, e, f, g, h) where
makeSQLOrdering be (a, b, c, d, e, f, g, h) =
makeSQLOrdering be a <> makeSQLOrdering be b <> makeSQLOrdering be c <> makeSQLOrdering be d <>
makeSQLOrdering be e <> makeSQLOrdering be f <> makeSQLOrdering be g <> makeSQLOrdering be h
-- | Order by the given expressions. The return type of the ordering key should
-- either be the result of 'asc_' or 'desc_' (or another ordering 'QOrd'
-- generated by a backend-specific ordering) or an (possibly nested) tuple of
-- results of the former.
--
-- The <https://haskell-beam.github.io/beam/user-guide/queries/ordering manual section>
-- has more information.
orderBy_ :: forall s a ordering be db
. ( Projectible be a, SqlOrderable be ordering
, ThreadRewritable (QNested s) a )
=> (a -> ordering) -> Q be db (QNested s) a -> Q be db s (WithRewrittenThread (QNested s) s a)
orderBy_ orderer (Q q) =
Q (liftF (QOrderBy (sequenceA . makeSQLOrdering (Proxy @be) . orderer) q (rewriteThread (Proxy @s))))
nullsFirst_ :: IsSql2003OrderingElementaryOLAPOperationsSyntax (BeamSqlBackendOrderingSyntax be)
=> QOrd be s a -> QOrd be s a
nullsFirst_ (QOrd e) = QOrd (nullsFirstOrdering <$> e)
nullsLast_ :: IsSql2003OrderingElementaryOLAPOperationsSyntax (BeamSqlBackendOrderingSyntax be)
=> QOrd be s a -> QOrd be s a
nullsLast_ (QOrd e) = QOrd (nullsLastOrdering <$> e)
-- | Produce a 'QOrd' corresponding to a SQL @ASC@ ordering
asc_ :: forall be s a
. BeamSqlBackend be
=> QExpr be s a -> QOrd be s a
asc_ (QExpr e) = QOrd (ascOrdering <$> e)
-- | Produce a 'QOrd' corresponding to a SQL @DESC@ ordering
desc_ :: forall be s a
. BeamSqlBackend be
=> QExpr be s a -> QOrd be s a
desc_ (QExpr e) = QOrd (descOrdering <$> e)
-- * Subqueries
-- * Nullable conversions
-- | Type class for things that can be nullable. This includes 'QExpr (Maybe a)', 'tbl (Nullable
-- QExpr)', and 'PrimaryKey tbl (Nullable QExpr)'
class SqlJustable a b | b -> a where
-- | Given something of type 'QExpr a', 'tbl QExpr', or 'PrimaryKey tbl
-- QExpr', turn it into a 'QExpr (Maybe a)', 'tbl (Nullable QExpr)', or
-- 'PrimaryKey t (Nullable QExpr)' respectively that contains the same
-- values.
just_ :: a -> b
-- | Return either a 'QExpr (Maybe x)' representing 'Nothing' or a nullable 'Table' or
-- 'PrimaryKey' filled with 'Nothing'.
nothing_ :: b
instance BeamSqlBackend be =>
SqlJustable (QExpr be s a) (QExpr be s (Maybe a)) where
just_ (QExpr e) = QExpr e
nothing_ = QExpr (pure (valueE (sqlValueSyntax SqlNull)))
instance {-# OVERLAPPING #-} ( Table t, BeamSqlBackend be ) =>
SqlJustable (PrimaryKey t (QExpr be s)) (PrimaryKey t (Nullable (QExpr be s))) where
just_ = changeBeamRep (\(Columnar' q) -> Columnar' (just_ q))
nothing_ = changeBeamRep (\(Columnar' _) -> Columnar' nothing_) (primaryKey (tblSkeleton :: TableSkeleton t))
instance {-# OVERLAPPING #-} ( Table t, BeamSqlBackend be ) =>
SqlJustable (t (QExpr be s)) (t (Nullable (QExpr be s))) where
just_ = changeBeamRep (\(Columnar' q) -> Columnar' (just_ q))
nothing_ = changeBeamRep (\(Columnar' _) -> Columnar' nothing_) (tblSkeleton :: TableSkeleton t)
instance {-# OVERLAPPING #-} Table t => SqlJustable (PrimaryKey t Identity) (PrimaryKey t (Nullable Identity)) where
just_ = changeBeamRep (\(Columnar' q) -> Columnar' (Just q))
nothing_ = changeBeamRep (\(Columnar' _) -> Columnar' Nothing) (primaryKey (tblSkeleton :: TableSkeleton t))
instance {-# OVERLAPPING #-} Table t => SqlJustable (t Identity) (t (Nullable Identity)) where
just_ = changeBeamRep (\(Columnar' q) -> Columnar' (Just q))
nothing_ = changeBeamRep (\(Columnar' _) -> Columnar' Nothing) (tblSkeleton :: TableSkeleton t)
-- * Nullable checking
data QIfCond context be s a = QIfCond (QGenExpr context be s SqlBool) (QGenExpr context be s a)
newtype QIfElse context be s a = QIfElse (QGenExpr context be s a)
then_ :: QGenExpr context be s Bool -> QGenExpr context be s a -> QIfCond context be s a
then_ cond res = QIfCond (sqlBool_ cond) res
then_' :: QGenExpr context be s SqlBool -> QGenExpr context be s a -> QIfCond context be s a
then_' cond res = QIfCond cond res
else_ :: QGenExpr context be s a -> QIfElse context be s a
else_ = QIfElse
if_ :: BeamSqlBackend be
=> [ QIfCond context be s a ]
-> QIfElse context be s a
-> QGenExpr context be s a
if_ conds (QIfElse (QExpr elseExpr)) =
QExpr (\tbl -> caseE (map (\(QIfCond (QExpr cond) (QExpr res)) -> (cond tbl, res tbl)) conds) (elseExpr tbl))
ifThenElse_
:: BeamSqlBackend be
=> QGenExpr context be s Bool
-> QGenExpr context be s a
-> QGenExpr context be s a
-> QGenExpr context be s a
ifThenElse_ c t f = if_ [c `then_` t] (else_ f)
bool_
:: BeamSqlBackend be
=> QGenExpr context be s a
-> QGenExpr context be s a
-> QGenExpr context be s Bool
-> QGenExpr context be s a
bool_ f t c = ifThenElse_ c t f
-- | SQL @COALESCE@ support
coalesce_ :: BeamSqlBackend be
=> [ QGenExpr ctxt be s (Maybe a) ] -> QGenExpr ctxt be s a -> QGenExpr ctxt be s a
coalesce_ qs (QExpr onNull) =
QExpr $ do
onNull' <- onNull
coalesceE . (<> [onNull']) <$> mapM (\(QExpr q) -> q) qs
-- | Convert a 'Maybe' value to a concrete value, by suppling a default
fromMaybe_ :: BeamSqlBackend be
=> QGenExpr ctxt be s a -> QGenExpr ctxt be s (Maybe a) -> QGenExpr ctxt be s a
fromMaybe_ onNull q = coalesce_ [q] onNull
-- | Type class for anything which can be checked for null-ness. This includes 'QExpr (Maybe a)' as
-- well as 'Table's or 'PrimaryKey's over 'Nullable QExpr'.
class BeamSqlBackend be => SqlDeconstructMaybe be a nonNullA s | a s -> be, a -> nonNullA, a -> s, nonNullA -> s where
-- | Returns a 'QExpr' that evaluates to true when the first argument is not null
isJust_ :: a -> QGenExpr ctxt be s Bool
-- | Returns a 'QExpr' that evaluates to true when the first argument is null
isNothing_ :: a -> QGenExpr ctxt be s Bool
-- | Given an object (third argument) which may or may not be null, return the default value if
-- null (first argument), or transform the value that could be null to yield the result of the
-- expression (second argument)
maybe_ :: QGenExpr ctxt be s y -> (nonNullA -> QGenExpr ctxt be s y) -> a -> QGenExpr ctxt be s y
instance BeamSqlBackend be => SqlDeconstructMaybe be (QGenExpr ctxt be s (Maybe x)) (QGenExpr ctxt be s x) s where
isJust_ (QExpr x) = QExpr (isNotNullE <$> x)
isNothing_ (QExpr x) = QExpr (isNullE <$> x)
maybe_ (QExpr onNothing) onJust (QExpr e) =
let QExpr onJust' = onJust (QExpr e)
in QExpr (\tbl -> caseE [(isNotNullE (e tbl), onJust' tbl)] (onNothing tbl))
instance ( BeamSqlBackend be, Beamable t)
=> SqlDeconstructMaybe be (t (Nullable (QGenExpr ctxt be s))) (t (QGenExpr ctxt be s)) s where
isJust_ t = allE (allBeamValues (\(Columnar' e) -> isJust_ e) t)
isNothing_ t = allE (allBeamValues (\(Columnar' e) -> isNothing_ e) t)
maybe_ (QExpr onNothing) onJust tbl =
let QExpr onJust' = onJust (changeBeamRep (\(Columnar' (QExpr e)) -> Columnar' (QExpr e)) tbl)
QExpr cond = isJust_ @be tbl
in QExpr (\tblPfx -> caseE [(cond tblPfx, onJust' tblPfx)] (onNothing tblPfx))
infixl 3 <|>.
(<|>.) :: ( SqlJustable a (QGenExpr ctxt syntax s y)
, SqlDeconstructMaybe syntax (QGenExpr ctxt syntax s y) a s
)
=> QGenExpr ctxt syntax s y
-> QGenExpr ctxt syntax s y
-> QGenExpr ctxt syntax s y
l <|>. r = maybe_ r just_ l