module Database.Relational.Query.Projectable (
SqlProjectable (unsafeProjectSqlTerms), unsafeProjectSql',
unsafeProjectSql,
value,
valueTrue, valueFalse,
values,
unsafeValueNull,
PlaceHolders, unsafeAddPlaceHolders, unsafePlaceHolders,
placeholder', placeholder, unitPlaceHolder,
ProjectableShowSql (unsafeShowSql'), unsafeShowSql,
(.=.), (.<.), (.<=.), (.>.), (.>=.), (.<>.),
and', or', in',
(.||.), (?||?), like, likeMaybe, like', likeMaybe',
(.+.), (.-.), (.*.), (./.),
(?+?), (?-?), (?*?), (?/?),
isNothing, isJust, fromMaybe,
not', exists,
negate', fromIntegral', showNum,
negateMaybe, fromIntegralMaybe, showNumMaybe,
casesOrElse, casesOrElse',
caseSearch, caseSearchMaybe, case', caseMaybe,
SqlBinOp, unsafeBinOp, unsafeUniOp,
rank, denseRank, rowNumber, percentRank, cumeDist,
projectZip, (><),
ProjectableIdZip (..),
ProjectableMaybe (just, flattenMaybe),
) where
import Prelude hiding (pi)
import Data.String (IsString)
import Data.Monoid ((<>), mconcat)
import Control.Applicative ((<$>))
import Language.SQL.Keyword (Keyword)
import qualified Language.SQL.Keyword as SQL
import Database.Record
(PersistableWidth, PersistableRecordWidth, derivedWidth,
HasColumnConstraint, NotNull)
import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL)
import Database.Relational.Query.ProjectableClass
(ProjectableFunctor (..), ProjectableApplicative (..), )
import Database.Relational.Query.Context (Flat, Aggregated, Exists, OverWindow)
import Database.Relational.Query.TupleInstances ()
import Database.Relational.Query.ProjectableClass
(ShowConstantTermsSQL, showConstantTermsSQL, )
import Database.Relational.Query.Projection
(Projection, ListProjection)
import qualified Database.Relational.Query.Projection as Projection
class SqlProjectable p where
unsafeProjectSqlTerms :: [StringSQL]
-> p t
instance SqlProjectable (Projection Flat) where
unsafeProjectSqlTerms = Projection.unsafeFromSqlTerms
instance SqlProjectable (Projection Aggregated) where
unsafeProjectSqlTerms = Projection.unsafeFromSqlTerms
instance SqlProjectable (Projection OverWindow) where
unsafeProjectSqlTerms = Projection.unsafeFromSqlTerms
class SqlProjectable p => OperatorProjectable p
instance OperatorProjectable (Projection Flat)
instance OperatorProjectable (Projection Aggregated)
unsafeProjectSql' :: SqlProjectable p => StringSQL -> p t
unsafeProjectSql' = unsafeProjectSqlTerms . (:[])
unsafeProjectSql :: SqlProjectable p => String -> p t
unsafeProjectSql = unsafeProjectSql' . stringSQL
unsafeValueNull :: OperatorProjectable p => p (Maybe a)
unsafeValueNull = unsafeProjectSql "NULL"
value :: (ShowConstantTermsSQL t, OperatorProjectable p) => t -> p t
value = unsafeProjectSqlTerms . showConstantTermsSQL
valueTrue :: (OperatorProjectable p, ProjectableMaybe p) => p (Maybe Bool)
valueTrue = just $ value True
valueFalse :: (OperatorProjectable p, ProjectableMaybe p) => p (Maybe Bool)
valueFalse = just $ value False
values :: (ShowConstantTermsSQL t, OperatorProjectable p) => [t] -> ListProjection p t
values = Projection.list . map value
class ProjectableShowSql p where
unsafeShowSql' :: p a
-> StringSQL
unsafeShowSql :: ProjectableShowSql p
=> p a
-> String
unsafeShowSql = showStringSQL . unsafeShowSql'
instance ProjectableShowSql (Projection c) where
unsafeShowSql' = Projection.unsafeStringSql
type SqlBinOp = Keyword -> Keyword -> Keyword
unsafeUniOp :: (ProjectableShowSql p0, SqlProjectable p1)
=> (Keyword -> Keyword) -> p0 a -> p1 b
unsafeUniOp u = unsafeProjectSql' . u . unsafeShowSql'
unsafeFlatUniOp :: (SqlProjectable p, ProjectableShowSql p)
=> Keyword -> p a -> p b
unsafeFlatUniOp kw = unsafeUniOp (SQL.paren . SQL.defineUniOp kw)
unsafeBinOp :: (SqlProjectable p, ProjectableShowSql p)
=> SqlBinOp
-> p a -> p b -> p c
unsafeBinOp op a b = unsafeProjectSql' . SQL.paren $
op (unsafeShowSql' a) (unsafeShowSql' b)
compareBinOp :: (SqlProjectable p, ProjectableShowSql p)
=> SqlBinOp
-> p a -> p a -> p (Maybe Bool)
compareBinOp = unsafeBinOp
monoBinOp :: (SqlProjectable p, ProjectableShowSql p)
=> SqlBinOp
-> p a -> p a -> p a
monoBinOp = unsafeBinOp
(.=.) :: (OperatorProjectable p, ProjectableShowSql p)
=> p ft -> p ft -> p (Maybe Bool)
(.=.) = compareBinOp (SQL..=.)
(.<.) :: (OperatorProjectable p, ProjectableShowSql p)
=> p ft -> p ft -> p (Maybe Bool)
(.<.) = compareBinOp (SQL..<.)
(.<=.) :: (OperatorProjectable p, ProjectableShowSql p)
=> p ft -> p ft -> p (Maybe Bool)
(.<=.) = compareBinOp (SQL..<=.)
(.>.) :: (OperatorProjectable p, ProjectableShowSql p)
=> p ft -> p ft -> p (Maybe Bool)
(.>.) = compareBinOp (SQL..>.)
(.>=.) :: (OperatorProjectable p, ProjectableShowSql p)
=> p ft -> p ft -> p (Maybe Bool)
(.>=.) = compareBinOp (SQL..>=.)
(.<>.) :: (OperatorProjectable p, ProjectableShowSql p)
=> p ft -> p ft -> p (Maybe Bool)
(.<>.) = compareBinOp (SQL..<>.)
and' :: (OperatorProjectable p, ProjectableShowSql p)
=> p (Maybe Bool) -> p (Maybe Bool) -> p (Maybe Bool)
and' = monoBinOp SQL.and
or' :: (OperatorProjectable p, ProjectableShowSql p)
=> p (Maybe Bool) -> p (Maybe Bool) -> p (Maybe Bool)
or' = monoBinOp SQL.or
not' :: (OperatorProjectable p, ProjectableShowSql p)
=> p (Maybe Bool) -> p (Maybe Bool)
not' = unsafeFlatUniOp SQL.NOT
exists :: (OperatorProjectable p, ProjectableShowSql p)
=> ListProjection (Projection Exists) r -> p (Maybe Bool)
exists = unsafeProjectSql' . SQL.paren . SQL.defineUniOp SQL.EXISTS
. Projection.unsafeStringSqlList unsafeShowSql'
(.||.) :: (OperatorProjectable p, ProjectableShowSql p, IsString a)
=> p a -> p a -> p a
(.||.) = unsafeBinOp (SQL..||.)
(?||?) :: (OperatorProjectable p, ProjectableShowSql p, IsString a)
=> p (Maybe a) -> p (Maybe a) -> p (Maybe a)
(?||?) = unsafeBinOp (SQL..||.)
unsafeLike :: (OperatorProjectable p, ProjectableShowSql p)
=> p a -> p b -> p (Maybe Bool)
unsafeLike = unsafeBinOp (SQL.defineBinOp SQL.LIKE)
like' :: (OperatorProjectable p, ProjectableShowSql p, IsString a)
=> p a -> p a -> p (Maybe Bool)
x `like'` y = x `unsafeLike` y
likeMaybe' :: (OperatorProjectable p, ProjectableShowSql p, IsString a)
=> p (Maybe a) -> p (Maybe a) -> p (Maybe Bool)
x `likeMaybe'` y = x `unsafeLike` y
like :: (OperatorProjectable p, ProjectableShowSql p, IsString a, ShowConstantTermsSQL a)
=> p a -> a -> p (Maybe Bool)
x `like` a = x `like'` value a
likeMaybe :: (OperatorProjectable p, ProjectableShowSql p, IsString a, ShowConstantTermsSQL a)
=> p (Maybe a) -> a -> p (Maybe Bool)
x `likeMaybe` a = x `unsafeLike` value a
monoBinOp' :: (SqlProjectable p, ProjectableShowSql p)
=> Keyword -> p a -> p a -> p a
monoBinOp' = monoBinOp . SQL.defineBinOp
(.+.) :: (OperatorProjectable p, ProjectableShowSql p, Num a)
=> p a -> p a -> p a
(.+.) = monoBinOp' "+"
(.-.) :: (OperatorProjectable p, ProjectableShowSql p, Num a)
=> p a -> p a -> p a
(.-.) = monoBinOp' "-"
(./.) :: (OperatorProjectable p, ProjectableShowSql p, Num a)
=> p a -> p a -> p a
(./.) = monoBinOp' "/"
(.*.) :: (OperatorProjectable p, ProjectableShowSql p, Num a)
=> p a -> p a -> p a
(.*.) = monoBinOp' "*"
negate' :: (OperatorProjectable p, ProjectableShowSql p, Num a)
=> p a -> p a
negate' = unsafeFlatUniOp $ SQL.word "-"
unsafeCastProjectable :: (SqlProjectable p, ProjectableShowSql p)
=> p a -> p b
unsafeCastProjectable = unsafeProjectSql' . unsafeShowSql'
fromIntegral' :: (SqlProjectable p, ProjectableShowSql p, Integral a, Num b)
=> p a -> p b
fromIntegral' = unsafeCastProjectable
showNum :: (SqlProjectable p, ProjectableShowSql p, Num a, IsString b)
=> p a -> p b
showNum = unsafeCastProjectable
(?+?) :: (OperatorProjectable p, ProjectableShowSql p, Num a)
=> p (Maybe a) -> p (Maybe a) -> p (Maybe a)
(?+?) = monoBinOp' "+"
(?-?) :: (OperatorProjectable p, ProjectableShowSql p, Num a)
=> p (Maybe a) -> p (Maybe a) -> p (Maybe a)
(?-?) = monoBinOp' "-"
(?/?) :: (OperatorProjectable p, ProjectableShowSql p, Num a)
=> p (Maybe a) -> p (Maybe a) -> p (Maybe a)
(?/?) = monoBinOp' "/"
(?*?) :: (OperatorProjectable p, ProjectableShowSql p, Num a)
=> p (Maybe a) -> p (Maybe a) -> p (Maybe a)
(?*?) = monoBinOp' "*"
negateMaybe :: (OperatorProjectable p, ProjectableShowSql p, Num a)
=> p (Maybe a) -> p (Maybe a)
negateMaybe = unsafeFlatUniOp $ SQL.word "-"
fromIntegralMaybe :: (SqlProjectable p, ProjectableShowSql p, Integral a, Num b)
=> p (Maybe a) -> p (Maybe b)
fromIntegralMaybe = unsafeCastProjectable
showNumMaybe :: (SqlProjectable p, ProjectableShowSql p, Num a, IsString b)
=> p (Maybe a) -> p (Maybe b)
showNumMaybe = unsafeCastProjectable
whensClause :: (OperatorProjectable p, ProjectableShowSql p)
=> String
-> [(p a, p b)]
-> p b
-> Keyword
whensClause eTag cs0 e = d cs0 where
d [] = error $ eTag ++ ": Empty when clauses!"
d cs@(_:_) = mconcat [when' p r | (p, r) <- cs] <> else' <> SQL.END
when' p r = SQL.WHEN <> unsafeShowSql' p <> SQL.THEN <> unsafeShowSql' r
else' = SQL.ELSE <> unsafeShowSql' e
caseSearch :: (OperatorProjectable p, ProjectableShowSql p)
=> [(p (Maybe Bool), p a)]
-> p a
-> p a
caseSearch cs e = unsafeProjectSql' $ SQL.CASE <> whensClause "caseSearch" cs e
casesOrElse :: (OperatorProjectable p, ProjectableShowSql p)
=> [(p (Maybe Bool), p a)]
-> p a
-> p a
casesOrElse = caseSearch
caseSearchMaybe :: (OperatorProjectable p, ProjectableShowSql p)
=> [(p (Maybe Bool), p (Maybe a))]
-> p (Maybe a)
caseSearchMaybe cs = caseSearch cs unsafeValueNull
case' :: (OperatorProjectable p, ProjectableShowSql p)
=> p a
-> [(p a, p b)]
-> p b
-> p b
case' v cs e = unsafeProjectSql' $ SQL.CASE <> unsafeShowSql' v <> whensClause "case'" cs e
casesOrElse' :: (OperatorProjectable p, ProjectableShowSql p)
=> (p a, [(p a, p b)])
-> p b
-> p b
casesOrElse' = uncurry case'
caseMaybe :: (OperatorProjectable p, ProjectableShowSql p, ProjectableMaybe p)
=> p a
-> [(p a, p (Maybe b))]
-> p (Maybe b)
caseMaybe v cs = case' v cs unsafeValueNull
in' :: (OperatorProjectable p, ProjectableShowSql p)
=> p t -> ListProjection p t -> p (Maybe Bool)
in' a lp = unsafeProjectSql' . SQL.paren
$ SQL.in' (unsafeShowSql' a) (Projection.unsafeStringSqlList unsafeShowSql' lp)
isNothing :: (OperatorProjectable (Projection c), ProjectableShowSql (Projection c), HasColumnConstraint NotNull r)
=> Projection c (Maybe r) -> Projection c (Maybe Bool)
isNothing mr = unsafeProjectSql' $
SQL.paren $ (SQL.defineBinOp SQL.IS)
(Projection.unsafeStringSqlNotNullMaybe mr) SQL.NULL
isJust :: (OperatorProjectable (Projection c), ProjectableShowSql (Projection c), HasColumnConstraint NotNull r)
=> Projection c (Maybe r) -> Projection c (Maybe Bool)
isJust = not' . isNothing
fromMaybe :: (OperatorProjectable (Projection c), ProjectableShowSql (Projection c), HasColumnConstraint NotNull r)
=> Projection c r -> Projection c (Maybe r) -> Projection c r
fromMaybe d p = [ (isNothing p, d) ] `casesOrElse` unsafeCastProjectable p
unsafeUniTermFunction :: SqlProjectable p => Keyword -> p t
unsafeUniTermFunction = unsafeProjectSql' . (SQL.<++> stringSQL "()")
rank :: Integral a => Projection OverWindow a
rank = unsafeUniTermFunction SQL.RANK
denseRank :: Integral a => Projection OverWindow a
denseRank = unsafeUniTermFunction SQL.DENSE_RANK
rowNumber :: Integral a => Projection OverWindow a
rowNumber = unsafeUniTermFunction SQL.ROW_NUMBER
percentRank :: Projection OverWindow Double
percentRank = unsafeUniTermFunction SQL.PERCENT_RANK
cumeDist :: Projection OverWindow Double
cumeDist = unsafeUniTermFunction SQL.CUME_DIST
data PlaceHolders p = PlaceHolders
unsafeAddPlaceHolders :: Functor f => f a -> f (PlaceHolders p, a)
unsafeAddPlaceHolders = fmap ((,) PlaceHolders)
unsafePlaceHolders :: PlaceHolders p
unsafePlaceHolders = PlaceHolders
unitPlaceHolder :: PlaceHolders ()
unitPlaceHolder = unsafePlaceHolders
unsafeCastPlaceHolders :: PlaceHolders a -> PlaceHolders b
unsafeCastPlaceHolders PlaceHolders = PlaceHolders
unsafeProjectPlaceHolder' :: (PersistableWidth r, SqlProjectable p)
=> (PersistableRecordWidth r, p r)
unsafeProjectPlaceHolder' = unsafeProjectSqlTerms . (`replicate` "?") <$> derivedWidth
unsafeProjectPlaceHolder :: (PersistableWidth r, SqlProjectable p)
=> p r
unsafeProjectPlaceHolder = snd unsafeProjectPlaceHolder'
placeholder' :: (PersistableWidth t, SqlProjectable p) => (p t -> a) -> (PlaceHolders t, a)
placeholder' f = (PlaceHolders, f unsafeProjectPlaceHolder)
placeholder :: (PersistableWidth t, SqlProjectable p, Monad m) => (p t -> m a) -> m (PlaceHolders t, a)
placeholder f = do
let (ph, ma) = placeholder' f
a <- ma
return (ph, a)
projectZip :: ProjectableApplicative p => p a -> p b -> p (a, b)
projectZip pa pb = (,) |$| pa |*| pb
(><) :: ProjectableApplicative p => p a -> p b -> p (a, b)
(><) = projectZip
class ProjectableMaybe p where
just :: p a -> p (Maybe a)
flattenMaybe :: p (Maybe (Maybe a)) -> p (Maybe a)
instance ProjectableMaybe PlaceHolders where
just = unsafeCastPlaceHolders
flattenMaybe = unsafeCastPlaceHolders
instance ProjectableMaybe (Projection c) where
just = Projection.just
flattenMaybe = Projection.flattenMaybe
class ProjectableApplicative p => ProjectableIdZip p where
leftId :: p ((), a) -> p a
rightId :: p (a, ()) -> p a
instance ProjectableIdZip PlaceHolders where
leftId = unsafeCastPlaceHolders
rightId = unsafeCastPlaceHolders
instance ProjectableFunctor PlaceHolders where
_ |$| PlaceHolders = PlaceHolders
instance ProjectableApplicative PlaceHolders where
pf |*| pa = unsafeCastPlaceHolders (pf >< pa)
infixl 7 .*., ./., ?*?, ?/?
infixl 6 .+., .-., ?+?, ?-?
infixl 5 .||., ?||?
infix 4 .=., .<>., .>., .>=., .<., .<=., `in'`, `like`, `likeMaybe`, `like'`, `likeMaybe'`
infixr 3 `and'`
infixr 2 `or'`
infixl 1 ><