{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

-- | This module provides mechanism for flexible and typesafe usage of plain data values and fields.
-- The expressions can used in conditions and right part of Update statement.
-- Example:
--
-- @
-- StringField ==. \"abc\" &&. NumberField >. (0 :: Int) ||. MaybeField ==. (Nothing :: Maybe String) ||. MaybeField ==. Just \"def\"
-- @
--
-- Note that polymorphic values like numbers or Nothing must have a type annotation.
-- Comparison operators specific for SQL such as IN and LIKE are defined in "Database.Groundhog.Generic.Sql.Functions".
module Database.Groundhog.Expression
  ( Expression (..),
    Unifiable,
    ExpressionOf,
    (=.),
    (&&.),
    (||.),
    (==.),
    (/=.),
    (<.),
    (<=.),
    (>.),
    (>=.),
    isFieldNothing,
    liftExpr,
    toArith,
  )
where

import Database.Groundhog.Core
import Database.Groundhog.Instances ()

-- | Instances of this type can be converted to 'UntypedExpr'. It is useful for uniform manipulation over fields, constant values, etc.
class Expression db r a where
  toExpr :: a -> UntypedExpr db r

fieldHelper :: (FieldLike f a, DbDescriptor db, ProjectionDb f db) => f -> UntypedExpr db r
fieldHelper :: f -> UntypedExpr db r
fieldHelper f
f = UntypedExpr db r
result
  where
    result :: UntypedExpr db r
result = FieldChain -> UntypedExpr db r
forall db r. FieldChain -> UntypedExpr db r
ExprField (FieldChain -> UntypedExpr db r) -> FieldChain -> UntypedExpr db r
forall a b. (a -> b) -> a -> b
$ Any db -> f -> FieldChain
forall f a db (proxy :: * -> *).
(FieldLike f a, DbDescriptor db, ProjectionDb f db) =>
proxy db -> f -> FieldChain
fieldChain Any db
db f
f
    db :: Any db
db = (forall db r (proxy :: * -> *). UntypedExpr db r -> proxy db
forall a. HasCallStack => a
undefined :: UntypedExpr db r -> proxy db) UntypedExpr db r
result

instance {-# OVERLAPPING #-} (EntityConstr v c, DbDescriptor db, PersistField a, RestrictionHolder v c ~ r') => Expression db r' (Field v c a) where
  toExpr :: Field v c a -> UntypedExpr db r'
toExpr = Field v c a -> UntypedExpr db r'
forall f a db r.
(FieldLike f a, DbDescriptor db, ProjectionDb f db) =>
f -> UntypedExpr db r
fieldHelper

instance {-# OVERLAPPING #-} (EntityConstr v c, DbDescriptor db, PersistField a, db' ~ db, RestrictionHolder v c ~ r') => Expression db' r' (SubField db v c a) where
  toExpr :: SubField db v c a -> UntypedExpr db' r'
toExpr = SubField db v c a -> UntypedExpr db' r'
forall f a db r.
(FieldLike f a, DbDescriptor db, ProjectionDb f db) =>
f -> UntypedExpr db r
fieldHelper

instance {-# OVERLAPPING #-} (EntityConstr v c, DbDescriptor db, RestrictionHolder v c ~ r') => Expression db r' (AutoKeyField v c) where
  toExpr :: AutoKeyField v c -> UntypedExpr db r'
toExpr = AutoKeyField v c -> UntypedExpr db r'
forall f a db r.
(FieldLike f a, DbDescriptor db, ProjectionDb f db) =>
f -> UntypedExpr db r
fieldHelper

instance
  {-# OVERLAPPING #-}
  (PersistEntity v, DbDescriptor db, IsUniqueKey k, k ~ Key v (Unique u), RestrictionHolder v c ~ r') =>
  Expression db r' (u (UniqueMarker v))
  where
  toExpr :: u (UniqueMarker v) -> UntypedExpr db r'
toExpr = u (UniqueMarker v) -> UntypedExpr db r'
forall f a db r.
(FieldLike f a, DbDescriptor db, ProjectionDb f db) =>
f -> UntypedExpr db r
fieldHelper

instance {-# OVERLAPPING #-} (db' ~ db, r' ~ r) => Expression db' r' (Cond db r) where
  toExpr :: Cond db r -> UntypedExpr db' r'
toExpr = Cond db r -> UntypedExpr db' r'
forall db r. Cond db r -> UntypedExpr db r
ExprCond

-- Let's call "plain type" the types that uniquely define type of a Field it is compared to.
-- Example: Int -> Field v c Int, but Entity -> Field v c (Entity / Key Entity)
class Unifiable a b

instance {-# OVERLAPPING #-} Unifiable a a

-- Tie a type-level knot. Knowing if another type is plain helps to avoid indirection. In practice, it enables to infer type of polymorphic field when it is compared to a plain type.
instance {-# OVERLAPPABLE #-} (Normalize bk a (ak, r), Normalize ak b (bk, r)) => Unifiable a b

-- | This helper class can make type signatures more concise
class (Expression db r a, PersistField a') => ExpressionOf db r a a' | a -> a'

instance (Expression db r a, Normalize HTrue a (flag, a'), PersistField a') => ExpressionOf db r a a'

instance {-# OVERLAPPABLE #-} PurePersistField a => Expression db r a where
  toExpr :: a -> UntypedExpr db r
toExpr = a -> UntypedExpr db r
forall db r a. PurePersistField a => a -> UntypedExpr db r
ExprPure

instance {-# OVERLAPPING #-} (PersistField a, db' ~ db, r' ~ r) => Expression db' r' (Expr db r a) where
  toExpr :: Expr db r a -> UntypedExpr db' r'
toExpr (Expr UntypedExpr db r
e) = UntypedExpr db' r'
UntypedExpr db r
e

class Normalize counterpart t r | t -> r

instance {-# OVERLAPPING #-} NormalizeValue a (isPlain, r) => Normalize HFalse (Field v c a) (HFalse, r)

instance {-# OVERLAPS #-} r ~ (HFalse, a) => Normalize HTrue (Field v c a) r

instance {-# OVERLAPPING #-} NormalizeValue a (isPlain, r) => Normalize HFalse (SubField db v c a) (HFalse, r)

instance {-# OVERLAPS #-} r ~ (HFalse, a) => Normalize HTrue (SubField db v c a) r

instance {-# OVERLAPPING #-} NormalizeValue a (isPlain, r) => Normalize HFalse (Expr db r' a) (HFalse, r)

instance {-# OVERLAPS #-} r ~ (HFalse, a) => Normalize HTrue (Expr db r' a) r

instance {-# OVERLAPPING #-} NormalizeValue (Key v (Unique u)) (isPlain, r) => Normalize HFalse (u (UniqueMarker v)) (HFalse, r)

instance {-# OVERLAPS #-} r ~ (HFalse, Key v (Unique u)) => Normalize HTrue (u (UniqueMarker v)) r

instance {-# OVERLAPPING #-} NormalizeValue (Key v BackendSpecific) (isPlain, r) => Normalize HFalse (AutoKeyField v c) (HFalse, r)

instance {-# OVERLAPS #-} r ~ (HFalse, Key v BackendSpecific) => Normalize HTrue (AutoKeyField v c) r

instance {-# OVERLAPPING #-} r ~ (HTrue, Bool) => Normalize HFalse (Cond db r') r

instance {-# OVERLAPPING #-} r ~ (HTrue, Bool) => Normalize HTrue (Cond db r') r

instance {-# OVERLAPPABLE #-} NormalizeValue t r => Normalize HFalse t r

instance {-# OVERLAPPABLE #-} r ~ (HTrue, t) => Normalize HTrue t r

class NormalizeValue t r | t -> r

-- Normalize @Key v u@ to @v@ only if this key is used for storing @v@.

instance
  {-# OVERLAPPING #-}
  ( TypeEq (DefaultKey v) (Key v u) isDef,
    NormalizeKey isDef v u k,
    r ~ (Not isDef, Maybe k)
  ) =>
  NormalizeValue (Maybe (Key v u)) r

instance
  {-# OVERLAPPING #-}
  ( TypeEq (DefaultKey v) (Key v u) isDef,
    NormalizeKey isDef v u k,
    r ~ (Not isDef, k)
  ) =>
  NormalizeValue (Key v u) r

instance {-# OVERLAPPABLE #-} r ~ (HTrue, a) => NormalizeValue a r

class TypeEq x y b | x y -> b

instance {-# OVERLAPPABLE #-} b ~ HFalse => TypeEq x y b

instance {-# OVERLAPPING #-} TypeEq x x HTrue

class NormalizeKey isDef v u k | isDef v u -> k, k -> v

instance k ~ v => NormalizeKey HTrue v u k

instance k ~ Key v u => NormalizeKey HFalse v u k

type family Not bool

type instance Not HTrue = HFalse

type instance Not HFalse = HTrue

-- | Update field
infixr 3 =.

(=.) ::
  ( Assignable f a',
    ProjectionDb f db,
    ProjectionRestriction f r,
    Expression db r b,
    Unifiable f b
  ) =>
  f ->
  b ->
  Update db r
f
f =. :: f -> b -> Update db r
=. b
b = f -> UntypedExpr db r -> Update db r
forall db r f a.
(Assignable f a, Projection' f db r a) =>
f -> UntypedExpr db r -> Update db r
Update f
f (b -> UntypedExpr db r
forall db r a. Expression db r a => a -> UntypedExpr db r
toExpr b
b)

-- | Boolean \"and\" operator.
(&&.) :: Cond db r -> Cond db r -> Cond db r

-- | Boolean \"or\" operator.
(||.) :: Cond db r -> Cond db r -> Cond db r

infixr 3 &&.

Cond db r
a &&. :: Cond db r -> Cond db r -> Cond db r
&&. Cond db r
b = Cond db r -> Cond db r -> Cond db r
forall db r. Cond db r -> Cond db r -> Cond db r
And Cond db r
a Cond db r
b

infixr 2 ||.

Cond db r
a ||. :: Cond db r -> Cond db r -> Cond db r
||. Cond db r
b = Cond db r -> Cond db r -> Cond db r
forall db r. Cond db r -> Cond db r -> Cond db r
Or Cond db r
a Cond db r
b

(==.),
  (/=.) ::
    ( Expression db r a,
      Expression db r b,
      Unifiable a b
    ) =>
    a ->
    b ->
    Cond db r
(<.),
  (<=.),
  (>.),
  (>=.) ::
    ( Expression db r a,
      Expression db r b,
      Unifiable a b
    ) =>
    a ->
    b ->
    Cond db r

infix 4 ==., /=., <., <=., >., >=.

a
a ==. :: a -> b -> Cond db r
==. b
b = ExprRelation -> UntypedExpr db r -> UntypedExpr db r -> Cond db r
forall db r.
ExprRelation -> UntypedExpr db r -> UntypedExpr db r -> Cond db r
Compare ExprRelation
Eq (a -> UntypedExpr db r
forall db r a. Expression db r a => a -> UntypedExpr db r
toExpr a
a) (b -> UntypedExpr db r
forall db r a. Expression db r a => a -> UntypedExpr db r
toExpr b
b)

a
a /=. :: a -> b -> Cond db r
/=. b
b = ExprRelation -> UntypedExpr db r -> UntypedExpr db r -> Cond db r
forall db r.
ExprRelation -> UntypedExpr db r -> UntypedExpr db r -> Cond db r
Compare ExprRelation
Ne (a -> UntypedExpr db r
forall db r a. Expression db r a => a -> UntypedExpr db r
toExpr a
a) (b -> UntypedExpr db r
forall db r a. Expression db r a => a -> UntypedExpr db r
toExpr b
b)

a
a <. :: a -> b -> Cond db r
<. b
b = ExprRelation -> UntypedExpr db r -> UntypedExpr db r -> Cond db r
forall db r.
ExprRelation -> UntypedExpr db r -> UntypedExpr db r -> Cond db r
Compare ExprRelation
Lt (a -> UntypedExpr db r
forall db r a. Expression db r a => a -> UntypedExpr db r
toExpr a
a) (b -> UntypedExpr db r
forall db r a. Expression db r a => a -> UntypedExpr db r
toExpr b
b)

a
a <=. :: a -> b -> Cond db r
<=. b
b = ExprRelation -> UntypedExpr db r -> UntypedExpr db r -> Cond db r
forall db r.
ExprRelation -> UntypedExpr db r -> UntypedExpr db r -> Cond db r
Compare ExprRelation
Le (a -> UntypedExpr db r
forall db r a. Expression db r a => a -> UntypedExpr db r
toExpr a
a) (b -> UntypedExpr db r
forall db r a. Expression db r a => a -> UntypedExpr db r
toExpr b
b)

a
a >. :: a -> b -> Cond db r
>. b
b = ExprRelation -> UntypedExpr db r -> UntypedExpr db r -> Cond db r
forall db r.
ExprRelation -> UntypedExpr db r -> UntypedExpr db r -> Cond db r
Compare ExprRelation
Gt (a -> UntypedExpr db r
forall db r a. Expression db r a => a -> UntypedExpr db r
toExpr a
a) (b -> UntypedExpr db r
forall db r a. Expression db r a => a -> UntypedExpr db r
toExpr b
b)

a
a >=. :: a -> b -> Cond db r
>=. b
b = ExprRelation -> UntypedExpr db r -> UntypedExpr db r -> Cond db r
forall db r.
ExprRelation -> UntypedExpr db r -> UntypedExpr db r -> Cond db r
Compare ExprRelation
Ge (a -> UntypedExpr db r
forall db r a. Expression db r a => a -> UntypedExpr db r
toExpr a
a) (b -> UntypedExpr db r
forall db r a. Expression db r a => a -> UntypedExpr db r
toExpr b
b)

-- | This function more limited than (==.), but has better type inference.
-- If you want to compare your value to Nothing with @(==.)@ operator, you have to write the types explicitly @myExpr ==. (Nothing :: Maybe Int)@.
-- TODO: restrict db r
isFieldNothing :: (Expression db r f, Projection f (Maybe a), PrimitivePersistField (Maybe a), Unifiable f (Maybe a)) => f -> Cond db r
isFieldNothing :: f -> Cond db r
isFieldNothing f
a = f
a f -> Maybe a -> Cond db r
forall db r f a.
(Expression db r f, Expression db r a, Projection f a,
 Unifiable f a) =>
f -> a -> Cond db r
`eq` Maybe a
forall a. Maybe a
Nothing
  where
    eq :: (Expression db r f, Expression db r a, Projection f a, Unifiable f a) => f -> a -> Cond db r
    eq :: f -> a -> Cond db r
eq = f -> a -> Cond db r
forall db r a b.
(Expression db r a, Expression db r b, Unifiable a b) =>
a -> b -> Cond db r
(==.)

-- | Converts value to 'Expr'. It can help to pass values of different types into functions which expect arguments of the same type, like (+).
liftExpr :: ExpressionOf db r a a' => a -> Expr db r a'
liftExpr :: a -> Expr db r a'
liftExpr a
a = UntypedExpr db r -> Expr db r a'
forall db r a. UntypedExpr db r -> Expr db r a
Expr (UntypedExpr db r -> Expr db r a')
-> UntypedExpr db r -> Expr db r a'
forall a b. (a -> b) -> a -> b
$ a -> UntypedExpr db r
forall db r a. Expression db r a => a -> UntypedExpr db r
toExpr a
a

{-# DEPRECATED toArith "Please use liftExpr instead" #-}

-- | It is kept for compatibility with older Groundhog versions and can be replaced with "liftExpr".
toArith :: ExpressionOf db r a a' => a -> Expr db r a'
toArith :: a -> Expr db r a'
toArith = a -> Expr db r a'
forall db r a a'. ExpressionOf db r a a' => a -> Expr db r a'
liftExpr