{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Database.Ribbit.Conditions (
Where,
Equals,
NotEquals,
Lt,
Lte,
Gt,
Gte,
And,
Or,
Not,
IsNull,
NotNull,
type (?),
RenderConditions,
RenderJoinConditions,
) where
import Data.Type.Bool (If)
import Database.Ribbit.Params (ParamsTypeSchema, ResultType,
ProjectionType)
import Database.Ribbit.Table (Validate, Flatten, (:>), ValidField,
NotInSchema)
import GHC.TypeLits (Symbol, AppendSymbol, TypeError, ErrorMessage((:<>:),
ShowType))
import qualified GHC.TypeLits as Lit
data Where query conditions
infixl 6 `Where`
data Equals (l :: k1) (r :: k2)
infix 9 `Equals`
data NotEquals l r
infix 9 `NotEquals`
data Lt l r
infix 9 `Lt`
data Lte l r
infix 9 `Lte`
data Gt l r
infix 9 `Gt`
data Gte l r
infix 9 `Gte`
data And l r
infixr 8 `And`
data Or (l :: k1) (r :: k2)
infixr 7 `Or`
data Not a
data IsNull (field :: Symbol)
data NotNull (field :: Symbol)
type family RenderConditions a schema where
RenderConditions (Or l r) schema =
"( "
`AppendSymbol` RenderConditions l schema
`AppendSymbol` " ) OR ("
`AppendSymbol` RenderConditions r schema
`AppendSymbol` " )"
RenderConditions (And l r) schema =
"( "
`AppendSymbol` RenderConditions l schema
`AppendSymbol` " ) AND ( "
`AppendSymbol` RenderConditions r schema
`AppendSymbol` " )"
RenderConditions condition schema = RenderCondition condition schema
type family RenderCondition condition schema where
RenderCondition (Equals l r) schema = SimpleCondition schema (Expr l) "=" (Expr r)
RenderCondition (NotEquals l r) schema = SimpleCondition schema (Expr l) "!=" (Expr r)
RenderCondition (Lt l r) schema = SimpleCondition schema (Expr l) "<" (Expr r)
RenderCondition (Lte l r) schema = SimpleCondition schema (Expr l) "<=" (Expr r)
RenderCondition (Gt l r) schema = SimpleCondition schema (Expr l) ">" (Expr r)
RenderCondition (Gte l r) schema = SimpleCondition schema (Expr l) ">=" (Expr r)
RenderCondition (IsNull field) schema = Validate field schema (
field `AppendSymbol` " IS NULL"
)
RenderCondition (NotNull field) schema = Validate field schema (
field `AppendSymbol` " IS NOT NULL"
)
RenderCondition a _ = TypeError ('Lit.Text "Invalid condition: " ':<>: 'ShowType a)
type family SimpleCondition schema l op r where
SimpleCondition schema (Expr (?)) op (Expr r) =
Validate r schema (
"? "
`AppendSymbol` op
`AppendSymbol` " "
`AppendSymbol` r
)
SimpleCondition schema (Expr l) op (Expr (?)) =
Validate l schema (
l
`AppendSymbol` " "
`AppendSymbol` op
`AppendSymbol` " ?"
)
SimpleCondition schema (Expr l) op (Expr r) =
Validate l schema (
Validate r schema (
l
`AppendSymbol` " "
`AppendSymbol` op
`AppendSymbol` " "
`AppendSymbol` r
)
)
data Expr (a :: k)
type family RenderJoinConditions a schema where
RenderJoinConditions (Or l r) schema =
"( "
`AppendSymbol` RenderJoinConditions l schema
`AppendSymbol` " ) OR ("
`AppendSymbol` RenderJoinConditions r schema
`AppendSymbol` " )"
RenderJoinConditions (And l r) schema =
"( "
`AppendSymbol` RenderJoinConditions l schema
`AppendSymbol` " ) AND ( "
`AppendSymbol` RenderJoinConditions r schema
`AppendSymbol` " )"
RenderJoinConditions condition schema = RenderJoinCondition condition schema
type family RenderJoinCondition condition schema where
RenderJoinCondition (Equals l r) schema = ClosedCondition schema (Expr l) "=" (Expr r)
RenderJoinCondition (NotEquals l r) schema = ClosedCondition schema (Expr l) "!=" (Expr r)
RenderJoinCondition (Lt l r) schema = ClosedCondition schema (Expr l) "<" (Expr r)
RenderJoinCondition (Lte l r) schema = ClosedCondition schema (Expr l) "<=" (Expr r)
RenderJoinCondition (Gt l r) schema = ClosedCondition schema (Expr l) ">" (Expr r)
RenderJoinCondition (Gte l r) schema = ClosedCondition schema (Expr l) ">=" (Expr r)
RenderJoinCondition (IsNull field) schema = Validate field schema (
field `AppendSymbol` " IS NULL"
)
RenderJoinCondition (NotNull field) schema = Validate field schema (
field `AppendSymbol` " IS NOT NULL"
)
RenderJoinCondition a _ = TypeError ('Lit.Text "Invalid condition: " ':<>: 'ShowType a)
type family ClosedCondition schema l op r where
ClosedCondition schema (Expr l) op (Expr r) =
Validate l schema (
Validate r schema (
l
`AppendSymbol` " "
`AppendSymbol` op
`AppendSymbol` " "
`AppendSymbol` r
)
)
data (?)
type instance ParamsTypeSchema schema (And a b) =
StripUnit (Flatten (ParamsTypeSchema schema a :> ParamsTypeSchema schema b))
type instance ParamsTypeSchema schema (Or a b) =
StripUnit (Flatten (ParamsTypeSchema schema a :> ParamsTypeSchema schema b))
type instance ParamsTypeSchema schema (Equals l r) = CompParams schema (Comparison l r)
type instance ParamsTypeSchema schema (NotEquals l r) = CompParams schema (Comparison l r)
type instance ParamsTypeSchema schema (Lt l r) = CompParams schema (Comparison l r)
type instance ParamsTypeSchema schema (Lte l r) = CompParams schema (Comparison l r)
type instance ParamsTypeSchema schema (Gt l r) = CompParams schema (Comparison l r)
type instance ParamsTypeSchema schema (Gte l r) = CompParams schema (Comparison l r)
type instance ParamsTypeSchema schema (Not a) = ParamsTypeSchema schema a
type instance ResultType (query `Where` conditions) = ResultType query
type family CompParams schema comp where
CompParams schema (Comparison field (?)) = ProjectionType '[field] schema
CompParams schema (Comparison (?) field) = ProjectionType '[field] schema
CompParams schema (Comparison l r) =
If
(ValidField r schema)
(If (ValidField l schema) () (NotInSchema l schema))
(NotInSchema r schema)
data Comparison l r
type family StripUnit a where
StripUnit (() :> a) = StripUnit a
StripUnit (a :> ()) = StripUnit a
StripUnit (a :> b) = a :> StripUnit b
StripUnit a = a