module Database.Relational.Projectable (
SqlContext (unsafeProjectSqlTerms), unsafeProjectSql',
unsafeProjectSql,
value,
valueTrue, valueFalse,
values,
nothing,
PlaceHolders, unsafeAddPlaceHolders, unsafePlaceHolders,
pwPlaceholder, placeholder', placeholder, unitPlaceHolder, unitPH,
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, (><),
ProjectableMaybe (just, flattenMaybe),
) where
import Prelude hiding (pi)
import Data.String (IsString)
import Data.Functor.ProductIsomorphic
(ProductIsoFunctor, (|$|), ProductIsoApplicative, pureP, (|*|),
ProductIsoEmpty, pureE, peRight, peLeft, )
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.Internal.ContextType
(Flat, Aggregated, Exists, OverWindow)
import Database.Relational.Internal.String (StringSQL, stringSQL, showStringSQL)
import Database.Relational.SqlSyntax (Record, Predicate)
import qualified Database.Relational.SqlSyntax as Syntax
import Database.Relational.Pure ()
import Database.Relational.TupleInstances ()
import Database.Relational.ProjectableClass
(ShowConstantTermsSQL, showConstantTermsSQL, )
import Database.Relational.Record (RecordList)
import qualified Database.Relational.Record as Record
class SqlContext c where
unsafeProjectSqlTerms :: [StringSQL]
-> Record c t
instance SqlContext Flat where
unsafeProjectSqlTerms = Record.unsafeFromSqlTerms
instance SqlContext Aggregated where
unsafeProjectSqlTerms = Record.unsafeFromSqlTerms
instance SqlContext OverWindow where
unsafeProjectSqlTerms = Record.unsafeFromSqlTerms
class SqlContext c => OperatorContext c
instance OperatorContext Flat
instance OperatorContext Aggregated
unsafeProjectSql' :: SqlContext c => StringSQL -> Record c t
unsafeProjectSql' = unsafeProjectSqlTerms . (:[])
unsafeProjectSql :: SqlContext c => String -> Record c t
unsafeProjectSql = unsafeProjectSql' . stringSQL
nothing :: (OperatorContext c, SqlContext c, PersistableWidth a)
=> Record c (Maybe a)
nothing = proxyWidth persistableWidth
where
proxyWidth :: SqlContext c => PersistableRecordWidth a -> Record c (Maybe a)
proxyWidth w = unsafeProjectSqlTerms $ replicate (runPersistableRecordWidth w) SQL.NULL
value :: (ShowConstantTermsSQL t, OperatorContext c) => t -> Record c t
value = unsafeProjectSqlTerms . showConstantTermsSQL
valueTrue :: (OperatorContext c, ProjectableMaybe (Record c)) => Record c (Maybe Bool)
valueTrue = just $ value True
valueFalse :: (OperatorContext c, ProjectableMaybe (Record c)) => Record c (Maybe Bool)
valueFalse = just $ value False
values :: (ShowConstantTermsSQL t, OperatorContext c) => [t] -> RecordList (Record c) t
values = Record.list . map value
unsafeShowSql' :: Record c a -> StringSQL
unsafeShowSql' = Record.unsafeStringSql
unsafeShowSql :: Record c a
-> String
unsafeShowSql = showStringSQL . unsafeShowSql'
type SqlBinOp = Keyword -> Keyword -> Keyword
unsafeUniOp :: SqlContext c2
=> (Keyword -> Keyword) -> Record c1 a -> Record c2 b
unsafeUniOp u = unsafeProjectSql' . u . unsafeShowSql'
unsafeFlatUniOp :: SqlContext c
=> Keyword -> Record c a -> Record c b
unsafeFlatUniOp kw = unsafeUniOp (SQL.paren . SQL.defineUniOp kw)
unsafeBinOp :: SqlContext k
=> SqlBinOp
-> Record k a -> Record k b -> Record k c
unsafeBinOp op a b = unsafeProjectSql' . SQL.paren $
op (unsafeShowSql' a) (unsafeShowSql' b)
compareBinOp :: SqlContext c
=> SqlBinOp
-> Record c a -> Record c a -> Record c (Maybe Bool)
compareBinOp = unsafeBinOp
monoBinOp :: SqlContext c
=> SqlBinOp
-> Record c a -> Record c a -> Record c a
monoBinOp = unsafeBinOp
(.=.) :: OperatorContext c
=> Record c ft -> Record c ft -> Record c (Maybe Bool)
(.=.) = compareBinOp (SQL..=.)
(.<.) :: OperatorContext c
=> Record c ft -> Record c ft -> Record c (Maybe Bool)
(.<.) = compareBinOp (SQL..<.)
(.<=.) :: OperatorContext c
=> Record c ft -> Record c ft -> Record c (Maybe Bool)
(.<=.) = compareBinOp (SQL..<=.)
(.>.) :: OperatorContext c
=> Record c ft -> Record c ft -> Record c (Maybe Bool)
(.>.) = compareBinOp (SQL..>.)
(.>=.) :: OperatorContext c
=> Record c ft -> Record c ft -> Record c (Maybe Bool)
(.>=.) = compareBinOp (SQL..>=.)
(.<>.) :: OperatorContext c
=> Record c ft -> Record c ft -> Record c (Maybe Bool)
(.<>.) = compareBinOp (SQL..<>.)
and' :: OperatorContext c
=> Record c (Maybe Bool) -> Record c (Maybe Bool) -> Record c (Maybe Bool)
and' = monoBinOp SQL.and
or' :: OperatorContext c
=> Record c (Maybe Bool) -> Record c (Maybe Bool) -> Record c (Maybe Bool)
or' = monoBinOp SQL.or
not' :: OperatorContext c
=> Record c (Maybe Bool) -> Record c (Maybe Bool)
not' = unsafeFlatUniOp SQL.NOT
exists :: OperatorContext c
=> RecordList (Record Exists) r -> Record c (Maybe Bool)
exists = unsafeProjectSql' . SQL.paren . SQL.defineUniOp SQL.EXISTS
. Record.unsafeStringSqlList unsafeShowSql'
(.||.) :: OperatorContext c
=> Record c a -> Record c a -> Record c a
(.||.) = unsafeBinOp (SQL..||.)
(?||?) :: (OperatorContext c, IsString a)
=> Record c (Maybe a) -> Record c (Maybe a) -> Record c (Maybe a)
(?||?) = unsafeBinOp (SQL..||.)
unsafeLike :: OperatorContext c
=> Record c a -> Record c b -> Record c (Maybe Bool)
unsafeLike = unsafeBinOp (SQL.defineBinOp SQL.LIKE)
like' :: (OperatorContext c, IsString a)
=> Record c a -> Record c a -> Record c (Maybe Bool)
x `like'` y = x `unsafeLike` y
likeMaybe' :: (OperatorContext c, IsString a)
=> Record c (Maybe a) -> Record c (Maybe a) -> Record c (Maybe Bool)
x `likeMaybe'` y = x `unsafeLike` y
like :: (OperatorContext c, IsString a, ShowConstantTermsSQL a)
=> Record c a -> a -> Record c (Maybe Bool)
x `like` a = x `like'` value a
likeMaybe :: (OperatorContext c, IsString a, ShowConstantTermsSQL a)
=> Record c (Maybe a) -> a -> Record c (Maybe Bool)
x `likeMaybe` a = x `unsafeLike` value a
monoBinOp' :: SqlContext c
=> Keyword -> Record c a -> Record c a -> Record c a
monoBinOp' = monoBinOp . SQL.defineBinOp
(.+.) :: (OperatorContext c, Num a)
=> Record c a -> Record c a -> Record c a
(.+.) = monoBinOp' "+"
(.-.) :: (OperatorContext c, Num a)
=> Record c a -> Record c a -> Record c a
(.-.) = monoBinOp' "-"
(./.) :: (OperatorContext c, Num a)
=> Record c a -> Record c a -> Record c a
(./.) = monoBinOp' "/"
(.*.) :: (OperatorContext c, Num a)
=> Record c a -> Record c a -> Record c a
(.*.) = monoBinOp' "*"
negate' :: (OperatorContext c, Num a)
=> Record c a -> Record c a
negate' = unsafeFlatUniOp $ SQL.word "-"
unsafeCastProjectable :: SqlContext c
=> Record c a -> Record c b
unsafeCastProjectable = unsafeProjectSql' . unsafeShowSql'
fromIntegral' :: (SqlContext c, Integral a, Num b)
=> Record c a -> Record c b
fromIntegral' = unsafeCastProjectable
showNum :: (SqlContext c, Num a, IsString b)
=> Record c a -> Record c b
showNum = unsafeCastProjectable
(?+?) :: (OperatorContext c, Num a)
=> Record c (Maybe a) -> Record c (Maybe a) -> Record c (Maybe a)
(?+?) = monoBinOp' "+"
(?-?) :: (OperatorContext c, Num a)
=> Record c (Maybe a) -> Record c (Maybe a) -> Record c (Maybe a)
(?-?) = monoBinOp' "-"
(?/?) :: (OperatorContext c, Num a)
=> Record c (Maybe a) -> Record c (Maybe a) -> Record c (Maybe a)
(?/?) = monoBinOp' "/"
(?*?) :: (OperatorContext c, Num a)
=> Record c (Maybe a) -> Record c (Maybe a) -> Record c (Maybe a)
(?*?) = monoBinOp' "*"
negateMaybe :: (OperatorContext c, Num a)
=> Record c (Maybe a) -> Record c (Maybe a)
negateMaybe = unsafeFlatUniOp $ SQL.word "-"
fromIntegralMaybe :: (SqlContext c, Integral a, Num b)
=> Record c (Maybe a) -> Record c (Maybe b)
fromIntegralMaybe = unsafeCastProjectable
showNumMaybe :: (SqlContext c, Num a, IsString b)
=> Record c (Maybe a) -> Record c (Maybe b)
showNumMaybe = unsafeCastProjectable
caseSearch :: OperatorContext c
=> [(Predicate c, Record c a)]
-> Record c a
-> Record c a
caseSearch = Syntax.caseSearch
casesOrElse :: OperatorContext c
=> [(Predicate c, Record c a)]
-> Record c a
-> Record c a
casesOrElse = caseSearch
caseSearchMaybe :: (OperatorContext c , PersistableWidth a)
=> [(Predicate c, Record c (Maybe a))]
-> Record c (Maybe a)
caseSearchMaybe cs = caseSearch cs nothing
case' :: OperatorContext c
=> Record c a
-> [(Record c a, Record c b)]
-> Record c b
-> Record c b
case' = Syntax.case'
casesOrElse' :: OperatorContext c
=> (Record c a, [(Record c a, Record c b)])
-> Record c b
-> Record c b
casesOrElse' = uncurry case'
caseMaybe :: (OperatorContext c , PersistableWidth b)
=> Record c a
-> [(Record c a, Record c (Maybe b))]
-> Record c (Maybe b)
caseMaybe v cs = case' v cs nothing
in' :: OperatorContext c
=> Record c t -> RecordList (Record c) t -> Record c (Maybe Bool)
in' a lp = unsafeProjectSql' . SQL.paren
$ SQL.in' (unsafeShowSql' a) (Record.unsafeStringSqlList unsafeShowSql' lp)
isNothing :: (OperatorContext c, HasColumnConstraint NotNull r)
=> Record c (Maybe r) -> Predicate c
isNothing mr = unsafeProjectSql' $
SQL.paren $ (SQL.defineBinOp SQL.IS)
(Record.unsafeStringSqlNotNullMaybe mr) SQL.NULL
isJust :: (OperatorContext c, HasColumnConstraint NotNull r)
=> Record c (Maybe r) -> Predicate c
isJust = not' . isNothing
fromMaybe :: (OperatorContext c, HasColumnConstraint NotNull r)
=> Record c r -> Record c (Maybe r) -> Record c r
fromMaybe d p = [ (isNothing p, d) ] `casesOrElse` unsafeCastProjectable p
unsafeUniTermFunction :: SqlContext c => Keyword -> Record c t
unsafeUniTermFunction = unsafeProjectSql' . (SQL.<++> stringSQL "()")
rank :: Integral a => Record OverWindow a
rank = unsafeUniTermFunction SQL.RANK
denseRank :: Integral a => Record OverWindow a
denseRank = unsafeUniTermFunction SQL.DENSE_RANK
rowNumber :: Integral a => Record OverWindow a
rowNumber = unsafeUniTermFunction SQL.ROW_NUMBER
percentRank :: Record OverWindow Double
percentRank = unsafeUniTermFunction SQL.PERCENT_RANK
cumeDist :: Record 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 = pureP ()
unitPH :: PlaceHolders ()
unitPH = pureP ()
unsafeCastPlaceHolders :: PlaceHolders a -> PlaceHolders b
unsafeCastPlaceHolders PlaceHolders = PlaceHolders
pwPlaceholder :: SqlContext c
=> PersistableRecordWidth a
-> (Record c a -> b)
-> (PlaceHolders a, b)
pwPlaceholder pw f = (PlaceHolders, f $ projectPlaceHolder pw)
where
projectPlaceHolder :: SqlContext c
=> PersistableRecordWidth a
-> Record c a
projectPlaceHolder = unsafeProjectSqlTerms . (`replicate` "?") . runPersistableRecordWidth
placeholder' :: (PersistableWidth t, SqlContext c) => (Record c t -> a) -> (PlaceHolders t, a)
placeholder' = pwPlaceholder persistableWidth
placeholder :: (PersistableWidth t, SqlContext c, Monad m) => (Record c t -> m a) -> m (PlaceHolders t, a)
placeholder f = do
let (ph, ma) = placeholder' f
a <- ma
return (ph, a)
projectZip :: ProductIsoApplicative p => p a -> p b -> p (a, b)
projectZip pa pb = (,) |$| pa |*| pb
(><) :: ProductIsoApplicative 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 (Record c) where
just = Record.just
flattenMaybe = Record.flattenMaybe
instance ProductIsoEmpty PlaceHolders () where
pureE = unsafePlaceHolders
peRight = unsafeCastPlaceHolders
peLeft = unsafeCastPlaceHolders
instance ProductIsoFunctor PlaceHolders where
_ |$| PlaceHolders = PlaceHolders
instance ProductIsoApplicative PlaceHolders where
pureP _ = unsafeCastPlaceHolders unitPH
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 ><