module Database.Relational.Query.Projectable (
SqlProjectable (unsafeProjectSqlTerms), unsafeProjectSql',
unsafeProjectSql,
value,
valueTrue, valueFalse,
values,
nothing, unsafeValueNull,
PlaceHolders, unsafeAddPlaceHolders, unsafePlaceHolders,
pwPlaceholder, placeholder', placeholder, unitPlaceHolder, unitPH,
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 Language.SQL.Keyword (Keyword)
import qualified Language.SQL.Keyword as SQL
import Database.Record
(PersistableWidth, persistableWidth, PersistableRecordWidth,
HasColumnConstraint, NotNull)
import Database.Record.Persistable (runPersistableRecordWidth)
import Database.Relational.Query.Internal.SQL (StringSQL, stringSQL, showStringSQL)
import qualified Database.Relational.Query.Internal.Sub as Internal
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
nothing :: (OperatorProjectable (Projection c), SqlProjectable (Projection c), PersistableWidth a)
=> Projection c (Maybe a)
nothing = proxyWidth persistableWidth
where
proxyWidth :: SqlProjectable (Projection c) => PersistableRecordWidth a -> Projection c (Maybe a)
proxyWidth w = unsafeProjectSqlTerms $ replicate (runPersistableRecordWidth w) SQL.NULL
unsafeValueNull :: (OperatorProjectable (Projection c), SqlProjectable (Projection c), PersistableWidth a)
=> Projection c (Maybe a)
unsafeValueNull = nothing
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
caseSearch :: OperatorProjectable (Projection c)
=> [(Projection c (Maybe Bool), Projection c a)]
-> Projection c a
-> Projection c a
caseSearch = Internal.caseSearch
casesOrElse :: OperatorProjectable (Projection c)
=> [(Projection c (Maybe Bool), Projection c a)]
-> Projection c a
-> Projection c a
casesOrElse = caseSearch
caseSearchMaybe :: (OperatorProjectable (Projection c) , PersistableWidth a)
=> [(Projection c (Maybe Bool), Projection c (Maybe a))]
-> Projection c (Maybe a)
caseSearchMaybe cs = caseSearch cs unsafeValueNull
case' :: OperatorProjectable (Projection c)
=> Projection c a
-> [(Projection c a, Projection c b)]
-> Projection c b
-> Projection c b
case' = Internal.case'
casesOrElse' :: OperatorProjectable (Projection c)
=> (Projection c a, [(Projection c a, Projection c b)])
-> Projection c b
-> Projection c b
casesOrElse' = uncurry case'
caseMaybe :: (OperatorProjectable (Projection c) , PersistableWidth b)
=> Projection c a
-> [(Projection c a, Projection c (Maybe b))]
-> Projection c (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
unitPH :: PlaceHolders ()
unitPH = unitPlaceHolder
unsafeCastPlaceHolders :: PlaceHolders a -> PlaceHolders b
unsafeCastPlaceHolders PlaceHolders = PlaceHolders
pwPlaceholder :: SqlProjectable p
=> PersistableRecordWidth a
-> (p a -> b)
-> (PlaceHolders a, b)
pwPlaceholder pw f = (PlaceHolders, f $ projectPlaceHolder pw)
where
projectPlaceHolder :: SqlProjectable p
=> PersistableRecordWidth a
-> p a
projectPlaceHolder = unsafeProjectSqlTerms . (`replicate` "?") . runPersistableRecordWidth
placeholder' :: (PersistableWidth t, SqlProjectable p) => (p t -> a) -> (PlaceHolders t, a)
placeholder' = pwPlaceholder persistableWidth
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 ><