module Database.Relational.Query.Projectable (
expr,
SqlProjectable (unsafeProjectSqlTerms), unsafeProjectSql,
value,
valueTrue, valueFalse,
values,
unsafeValueNull,
PlaceHolders, addPlaceHolders, unsafePlaceHolders,
placeholder', placeholder,
unsafeShowSqlExpr,
unsafeShowSqlProjection,
ProjectableShowSql (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, showStringSQL, rowStringSQL)
import Database.Relational.Query.Context (Flat, Aggregated, Exists, OverWindow)
import Database.Relational.Query.Component (columnSQL, showsColumnSQL)
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, unsafeFromColumns, columns,
ListProjection, unsafeShowSqlListProjection)
import qualified Database.Relational.Query.Projection as Projection
unsafeShowSqlProjection :: Projection c r -> String
unsafeShowSqlProjection = showStringSQL . rowStringSQL . map showsColumnSQL . columns
exprOfProjection :: Projection c r -> Expr c r
exprOfProjection = UnsafeExpr.Expr . stringSQL . unsafeShowSqlProjection
expr :: Projection p a -> Expr p a
expr = exprOfProjection
unsafeSqlTermsProjection :: [String] -> Projection c t
unsafeSqlTermsProjection = unsafeFromColumns . map columnSQL
class SqlProjectable p where
unsafeProjectSqlTerms :: [String]
-> p t
instance SqlProjectable (Projection Flat) where
unsafeProjectSqlTerms = unsafeSqlTermsProjection
instance SqlProjectable (Projection Aggregated) where
unsafeProjectSqlTerms = unsafeSqlTermsProjection
instance SqlProjectable (Projection OverWindow) where
unsafeProjectSqlTerms = unsafeSqlTermsProjection
instance SqlProjectable (Expr p) where
unsafeProjectSqlTerms = UnsafeExpr.Expr . rowStringSQL . map stringSQL
unsafeProjectSql :: SqlProjectable p => String -> p t
unsafeProjectSql = unsafeProjectSqlTerms . (:[])
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
-> String
unsafeShowSqlExpr :: Expr p t -> String
unsafeShowSqlExpr = UnsafeExpr.showExpr
instance ProjectableShowSql (Expr p) where
unsafeShowSql = unsafeShowSqlExpr
instance ProjectableShowSql (Projection c) where
unsafeShowSql = unsafeShowSqlProjection
type SqlBinOp = Keyword -> Keyword -> Keyword
unsafeUniOp :: (ProjectableShowSql p0, SqlProjectable p1)
=> (Keyword -> Keyword) -> p0 a -> p1 b
unsafeUniOp u = unsafeProjectSql . SQL.strUniOp u . unsafeShowSql
unsafeFlatUniOp :: (SqlProjectable p, ProjectableShowSql p)
=> Keyword -> p a -> p b
unsafeFlatUniOp kw = unsafeUniOp (SQL.paren . SQL.defineUniOp kw)
parenBinStr :: SqlBinOp -> String -> String -> String
parenBinStr op = SQL.strBinOp $ \x y -> SQL.paren $ op x y
unsafeBinOp :: (SqlProjectable p, ProjectableShowSql p)
=> SqlBinOp
-> p a -> p b -> p c
unsafeBinOp op a b = unsafeProjectSql
$ parenBinStr 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.strUniOp (SQL.paren . SQL.defineUniOp SQL.EXISTS)
. unsafeShowSqlListProjection 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
unsafeSqlWord :: ProjectableShowSql p => p a -> Keyword
unsafeSqlWord = SQL.word . unsafeShowSql
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 <> unsafeSqlWord p <> SQL.THEN <> unsafeSqlWord r
else' = SQL.ELSE <> unsafeSqlWord e
caseSearch :: (SqlProjectable p, ProjectableShowSql p)
=> [(p (Maybe Bool), p a)]
-> p a
-> p a
caseSearch cs e = unsafeProjectSql . SQL.wordShow $ 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.wordShow $ SQL.CASE <> unsafeSqlWord 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
$ parenBinStr SQL.in' (unsafeShowSql a) (unsafeShowSqlListProjection unsafeShowSql lp)
isNothing :: (SqlProjectable (Projection c), ProjectableShowSql (Projection c), HasColumnConstraint NotNull r)
=> Projection c (Maybe r) -> Projection c (Maybe Bool)
isNothing mr = unsafeProjectSql $
parenBinStr (SQL.defineBinOp SQL.IS)
(Projection.unsafeShowSqlNotNullMaybeProjection mr) (SQL.wordShow 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.wordShow
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
addPlaceHolders :: Functor f => f a -> f (PlaceHolders p, a)
addPlaceHolders = fmap ((,) PlaceHolders)
unsafePlaceHolders :: PlaceHolders p
unsafePlaceHolders = PlaceHolders
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 ><