module Database.Relational.Query.Projectable (
expr,
SqlProjectable (unsafeProjectSqlTerms'), unsafeProjectSql',
unsafeProjectSqlTerms, unsafeProjectSql,
value,
valueTrue, valueFalse,
values,
unsafeValueNull,
PlaceHolders, unsafeAddPlaceHolders, unsafePlaceHolders,
placeholder', placeholder, unitPlaceHolder,
ProjectableShowSql (unsafeShowSql'), unsafeShowSql,
SqlBinOp,
unsafeBinOp,
unsafeUniOp,
(.=.), (.<.), (.<=.), (.>.), (.>=.), (.<>.),
casesOrElse, casesOrElse',
caseSearch, caseSearchMaybe, case', caseMaybe,
in', and', or',
isNothing, isJust, fromMaybe, fromMaybe',
not', exists,
(.||.), (?||?),
(.+.), (.-.), (./.), (.*.), negate', fromIntegral', showNum,
(?+?), (?-?), (?/?), (?*?), negateMaybe, fromIntegralMaybe, showNumMaybe,
rank, denseRank, rowNumber, percentRank, cumeDist,
dense_rank, row_number, percent_rank, cume_dist,
projectZip, (><),
ProjectableIdZip (..),
ProjectableMaybe (just, flattenMaybe),
ProjectableFunctor (..), ProjectableApplicative (..), ipfmap
) where
import Prelude hiding (pi)
import Data.Int (Int64)
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, rowStringSQL)
import Database.Relational.Query.Context (Flat, Aggregated, Exists, OverWindow)
import Database.Relational.Query.Expr (Expr)
import qualified Database.Relational.Query.Expr as Expr
import qualified Database.Relational.Query.Expr.Unsafe as UnsafeExpr
import Database.Relational.Query.Pure
(ShowConstantTermsSQL, showConstantTermsSQL', ProductConstructor (..))
import Database.Relational.Query.Pi (Pi)
import qualified Database.Relational.Query.Pi as Pi
import Database.Relational.Query.Projection
(Projection, ListProjection)
import qualified Database.Relational.Query.Projection as Projection
expr :: Projection p a -> Expr p a
expr = UnsafeExpr.Expr . Projection.unsafeStringSql
class SqlProjectable p where
unsafeProjectSqlTerms' :: [StringSQL]
-> p t
unsafeProjectSqlTerms :: SqlProjectable p
=> [String]
-> p t
unsafeProjectSqlTerms = unsafeProjectSqlTerms' . map stringSQL
instance SqlProjectable (Projection Flat) where
unsafeProjectSqlTerms' = Projection.unsafeFromSqlTerms
instance SqlProjectable (Projection Aggregated) where
unsafeProjectSqlTerms' = Projection.unsafeFromSqlTerms
instance SqlProjectable (Projection OverWindow) where
unsafeProjectSqlTerms' = Projection.unsafeFromSqlTerms
instance SqlProjectable (Expr p) where
unsafeProjectSqlTerms' = UnsafeExpr.Expr . rowStringSQL
unsafeProjectSql' :: SqlProjectable p => StringSQL -> p t
unsafeProjectSql' = unsafeProjectSqlTerms' . (:[])
unsafeProjectSql :: SqlProjectable p => String -> p t
unsafeProjectSql = unsafeProjectSql' . stringSQL
unsafeValueNull :: SqlProjectable p => p (Maybe a)
unsafeValueNull = unsafeProjectSql "NULL"
value :: (ShowConstantTermsSQL t, SqlProjectable p) => t -> p t
value = unsafeProjectSqlTerms' . showConstantTermsSQL'
valueTrue :: (SqlProjectable p, ProjectableMaybe p) => p (Maybe Bool)
valueTrue = just $ value True
valueFalse :: (SqlProjectable p, ProjectableMaybe p) => p (Maybe Bool)
valueFalse = just $ value False
values :: (ShowConstantTermsSQL t, SqlProjectable 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 (Expr p) where
unsafeShowSql' = UnsafeExpr.unsafeStringSql
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
(.=.) :: (SqlProjectable p, ProjectableShowSql p)
=> p ft -> p ft -> p (Maybe Bool)
(.=.) = compareBinOp (SQL..=.)
(.<.) :: (SqlProjectable p, ProjectableShowSql p)
=> p ft -> p ft -> p (Maybe Bool)
(.<.) = compareBinOp (SQL..<.)
(.<=.) :: (SqlProjectable p, ProjectableShowSql p)
=> p ft -> p ft -> p (Maybe Bool)
(.<=.) = compareBinOp (SQL..<=.)
(.>.) :: (SqlProjectable p, ProjectableShowSql p)
=> p ft -> p ft -> p (Maybe Bool)
(.>.) = compareBinOp (SQL..>.)
(.>=.) :: (SqlProjectable p, ProjectableShowSql p)
=> p ft -> p ft -> p (Maybe Bool)
(.>=.) = compareBinOp (SQL..>=.)
(.<>.) :: (SqlProjectable p, ProjectableShowSql p)
=> p ft -> p ft -> p (Maybe Bool)
(.<>.) = compareBinOp (SQL..<>.)
and' :: (SqlProjectable p, ProjectableShowSql p)
=> p ft -> p ft -> p (Maybe Bool)
and' = compareBinOp SQL.and
or' :: (SqlProjectable p, ProjectableShowSql p)
=> p ft -> p ft -> p (Maybe Bool)
or' = compareBinOp SQL.or
not' :: (SqlProjectable p, ProjectableShowSql p)
=> p (Maybe Bool) -> p (Maybe Bool)
not' = unsafeFlatUniOp SQL.NOT
exists :: (SqlProjectable p, ProjectableShowSql p)
=> ListProjection (Projection Exists) r -> p (Maybe Bool)
exists = unsafeProjectSql' . SQL.paren . SQL.defineUniOp SQL.EXISTS
. Projection.unsafeStringSqlList unsafeShowSql'
(.||.) :: (SqlProjectable p, ProjectableShowSql p, IsString a)
=> p a -> p a -> p a
(.||.) = unsafeBinOp (SQL..||.)
(?||?) :: (SqlProjectable p, ProjectableShowSql p, IsString a)
=> p (Maybe a) -> p (Maybe a) -> p (Maybe a)
(?||?) = unsafeBinOp (SQL..||.)
monoBinOp' :: (SqlProjectable p, ProjectableShowSql p)
=> Keyword -> p a -> p a -> p a
monoBinOp' = monoBinOp . SQL.defineBinOp
(.+.) :: (SqlProjectable p, ProjectableShowSql p, Num a)
=> p a -> p a -> p a
(.+.) = monoBinOp' "+"
(.-.) :: (SqlProjectable p, ProjectableShowSql p, Num a)
=> p a -> p a -> p a
(.-.) = monoBinOp' "-"
(./.) :: (SqlProjectable p, ProjectableShowSql p, Num a)
=> p a -> p a -> p a
(./.) = monoBinOp' "/"
(.*.) :: (SqlProjectable p, ProjectableShowSql p, Num a)
=> p a -> p a -> p a
(.*.) = monoBinOp' "*"
negate' :: (SqlProjectable 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
(?+?) :: (SqlProjectable p, ProjectableShowSql p, Num a)
=> p (Maybe a) -> p (Maybe a) -> p (Maybe a)
(?+?) = monoBinOp' "+"
(?-?) :: (SqlProjectable p, ProjectableShowSql p, Num a)
=> p (Maybe a) -> p (Maybe a) -> p (Maybe a)
(?-?) = monoBinOp' "-"
(?/?) :: (SqlProjectable p, ProjectableShowSql p, Num a)
=> p (Maybe a) -> p (Maybe a) -> p (Maybe a)
(?/?) = monoBinOp' "/"
(?*?) :: (SqlProjectable p, ProjectableShowSql p, Num a)
=> p (Maybe a) -> p (Maybe a) -> p (Maybe a)
(?*?) = monoBinOp' "*"
negateMaybe :: (SqlProjectable 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 :: (SqlProjectable 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 :: (SqlProjectable p, ProjectableShowSql p)
=> [(p (Maybe Bool), p a)]
-> p a
-> p a
caseSearch cs e = unsafeProjectSql' $ SQL.CASE <> whensClause "caseSearch" cs e
casesOrElse :: (SqlProjectable p, ProjectableShowSql p)
=> [(p (Maybe Bool), p a)]
-> p a
-> p a
casesOrElse = caseSearch
caseSearchMaybe :: (ProjectableShowSql p, SqlProjectable p)
=> [(p (Maybe Bool), p (Maybe a))]
-> p (Maybe a)
caseSearchMaybe cs = caseSearch cs unsafeValueNull
case' :: (SqlProjectable 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' :: (SqlProjectable p, ProjectableShowSql p)
=> (p a, [(p a, p b)])
-> p b
-> p b
casesOrElse' = uncurry case'
caseMaybe :: (SqlProjectable p, ProjectableShowSql p, ProjectableMaybe p)
=> p a
-> [(p a, p (Maybe b))]
-> p (Maybe b)
caseMaybe v cs = case' v cs unsafeValueNull
in' :: (SqlProjectable 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 :: (SqlProjectable (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 :: (SqlProjectable (Projection c), ProjectableShowSql (Projection c), HasColumnConstraint NotNull r)
=> Projection c (Maybe r) -> Projection c (Maybe Bool)
isJust = not' . isNothing
fromMaybe :: (SqlProjectable (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
fromMaybe' :: (SqlProjectable (Projection c), ProjectableShowSql (Projection c), HasColumnConstraint NotNull r)
=> Projection c r -> Projection c (Maybe r) -> Projection c r
fromMaybe' = fromMaybe
unsafeUniTermFunction :: SqlProjectable p => Keyword -> p t
unsafeUniTermFunction = unsafeProjectSql' . (SQL.<++> stringSQL "()")
rank :: Projection OverWindow Int64
rank = unsafeUniTermFunction SQL.RANK
denseRank :: Projection OverWindow Int64
denseRank = unsafeUniTermFunction SQL.DENSE_RANK
dense_rank :: Projection OverWindow Int64
dense_rank = denseRank
rowNumber :: Projection OverWindow Int64
rowNumber = unsafeUniTermFunction SQL.ROW_NUMBER
row_number :: Projection OverWindow Int64
row_number = rowNumber
percentRank :: Projection OverWindow Double
percentRank = unsafeUniTermFunction SQL.PERCENT_RANK
percent_rank :: Projection OverWindow Double
percent_rank = percentRank
cumeDist :: Projection OverWindow Double
cumeDist = unsafeUniTermFunction SQL.CUME_DIST
cume_dist :: Projection OverWindow Double
cume_dist = cumeDist
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
instance ProjectableMaybe (Expr p) where
just = Expr.just
flattenMaybe = Expr.fromJust
class ProjectableApplicative p => ProjectableIdZip p where
leftId :: p ((), a) -> p a
rightId :: p (a, ()) -> p a
instance ProjectableIdZip PlaceHolders where
leftId = unsafeCastPlaceHolders
rightId = unsafeCastPlaceHolders
class ProjectableFunctor p where
(|$|) :: ProductConstructor (a -> b) => (a -> b) -> p a -> p b
ipfmap :: (ProjectableFunctor p, ProductConstructor (a -> b))
=> p a -> p b
ipfmap = (|$|) productConstructor
class ProjectableFunctor p => ProjectableApplicative p where
(|*|) :: p (a -> b) -> p a -> p b
instance ProjectableFunctor PlaceHolders where
_ |$| PlaceHolders = PlaceHolders
instance ProjectableApplicative PlaceHolders where
pf |*| pa = unsafeCastPlaceHolders (pf >< pa)
instance ProjectableFunctor (Projection c) where
(|$|) = Projection.pfmap
instance ProjectableApplicative (Projection c) where
(|*|) = Projection.pap
instance ProjectableFunctor (Pi a) where
(|$|) = Pi.pfmap
instance ProjectableApplicative (Pi a) where
(|*|) = Pi.pap
infixl 7 .*., ./., ?*?, ?/?
infixl 6 .+., .-., ?+?, ?-?
infixl 5 .||., ?||?
infixl 4 |$|, |*|
infix 4 .=., .<>., .>., .>=., .<., .<=., `in'`
infixr 3 `and'`
infixr 2 `or'`
infixl 1 ><