{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
{-# language MultiParamTypeClasses #-}
{-# language StandaloneKindSignatures #-}
{-# language TypeFamilies #-}
{-# language UndecidableInstances #-}

module Rel8.Expr.Function
  ( Function, function
  , nullaryFunction
  , binaryOperator
  )
where

-- base
import Data.Kind ( Constraint, Type )
import Prelude

-- opaleye
import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

-- rel8
import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
import Rel8.Expr.Opaleye
  ( castExpr
  , fromPrimExpr, toPrimExpr, zipPrimExprsWith
  )
import Rel8.Schema.Null ( Sql )
import Rel8.Type ( DBType )


-- | This type class exists to allow 'function' to have arbitrary arity. It's
-- mostly an implementation detail, and typical uses of 'Function' shouldn't
-- need this to be specified.
type Function :: Type -> Type -> Constraint
class Function arg res where
  applyArgument :: ([Opaleye.PrimExpr] -> Opaleye.PrimExpr) -> arg -> res


instance (arg ~ Expr a, Sql DBType b) => Function arg (Expr b) where
  applyArgument :: ([PrimExpr] -> PrimExpr) -> arg -> Expr b
applyArgument [PrimExpr] -> PrimExpr
f arg
a = Expr b -> Expr b
forall a. Sql DBType a => Expr a -> Expr a
castExpr (Expr b -> Expr b) -> Expr b -> Expr b
forall a b. (a -> b) -> a -> b
$ PrimExpr -> Expr b
forall a. PrimExpr -> Expr a
fromPrimExpr (PrimExpr -> Expr b) -> PrimExpr -> Expr b
forall a b. (a -> b) -> a -> b
$ [PrimExpr] -> PrimExpr
f [Expr a -> PrimExpr
forall a. Expr a -> PrimExpr
toPrimExpr arg
Expr a
a]


instance (arg ~ Expr a, Function args res) => Function arg (args -> res) where
  applyArgument :: ([PrimExpr] -> PrimExpr) -> arg -> args -> res
applyArgument [PrimExpr] -> PrimExpr
f arg
a = ([PrimExpr] -> PrimExpr) -> args -> res
forall arg res.
Function arg res =>
([PrimExpr] -> PrimExpr) -> arg -> res
applyArgument ([PrimExpr] -> PrimExpr
f ([PrimExpr] -> PrimExpr)
-> ([PrimExpr] -> [PrimExpr]) -> [PrimExpr] -> PrimExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Expr a -> PrimExpr
forall a. Expr a -> PrimExpr
toPrimExpr arg
Expr a
a PrimExpr -> [PrimExpr] -> [PrimExpr]
forall a. a -> [a] -> [a]
:))


-- | Construct an n-ary function that produces an 'Expr' that when called runs
-- a SQL function.
function :: Function args result => String -> args -> result
function :: String -> args -> result
function = ([PrimExpr] -> PrimExpr) -> args -> result
forall arg res.
Function arg res =>
([PrimExpr] -> PrimExpr) -> arg -> res
applyArgument (([PrimExpr] -> PrimExpr) -> args -> result)
-> (String -> [PrimExpr] -> PrimExpr) -> String -> args -> result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [PrimExpr] -> PrimExpr
Opaleye.FunExpr


-- | Construct a function call for functions with no arguments.
nullaryFunction :: Sql DBType a => String -> Expr a
nullaryFunction :: String -> Expr a
nullaryFunction String
name = Expr a -> Expr a
forall a. Sql DBType a => Expr a -> Expr a
castExpr (Expr a -> Expr a) -> Expr a -> Expr a
forall a b. (a -> b) -> a -> b
$ PrimExpr -> Expr a
forall k (a :: k). (k ~ *) => PrimExpr -> Expr a
Expr (String -> [PrimExpr] -> PrimExpr
Opaleye.FunExpr String
name [])


-- | Construct an expression by applying an infix binary operator to two
-- operands.
binaryOperator :: Sql DBType c => String -> Expr a -> Expr b -> Expr c
binaryOperator :: String -> Expr a -> Expr b -> Expr c
binaryOperator String
operator Expr a
a Expr b
b =
  Expr c -> Expr c
forall a. Sql DBType a => Expr a -> Expr a
castExpr (Expr c -> Expr c) -> Expr c -> Expr c
forall a b. (a -> b) -> a -> b
$ (PrimExpr -> PrimExpr -> PrimExpr) -> Expr a -> Expr b -> Expr c
forall a b c.
(PrimExpr -> PrimExpr -> PrimExpr) -> Expr a -> Expr b -> Expr c
zipPrimExprsWith (BinOp -> PrimExpr -> PrimExpr -> PrimExpr
Opaleye.BinExpr (String -> BinOp
Opaleye.OpOther String
operator)) Expr a
a Expr b
b