{-# 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 Database.Ribbit.Table (Validate)
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 (?)