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

module Rel8.Expr.Function
  ( Arguments
  , function
  , primFunction
  , rawFunction
  , binaryOperator
  , rawBinaryOperator
  )
where

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

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

-- rel8
import {-# SOURCE #-} Rel8.Expr (Expr)
import Rel8.Expr.Opaleye
  ( castExpr
  , fromPrimExpr, toPrimExpr, zipPrimExprsWith
  )
import Rel8.Schema.HTable (hfoldMap)
import Rel8.Schema.Null ( Sql )
import Rel8.Schema.QualifiedName
  ( QualifiedName (..)
  , showQualifiedName
  , showQualifiedOperator
  
  )
import Rel8.Table (Table, toColumns)
import Rel8.Type ( DBType )


-- | This type class is basically @'Table' 'Expr'@, where each column of the
-- 'Table' is an argument to the function, but it also has an additional
-- instance for @()@ for calling functions with no arguments.
type Arguments :: Type -> Constraint
class Arguments a where
  arguments :: a -> [Opaleye.PrimExpr]


instance Table Expr a => Arguments a where
  arguments :: a -> [PrimExpr]
arguments = (forall a. Expr a -> [PrimExpr]) -> Columns a Expr -> [PrimExpr]
forall (t :: HTable) s (context :: Context).
(HTable t, Semigroup s) =>
(forall a. context a -> s) -> t context -> s
hfoldMap (PrimExpr -> [PrimExpr]
forall a. a -> [a]
forall (f :: Context) a. Applicative f => a -> f a
pure (PrimExpr -> [PrimExpr])
-> (Expr a -> PrimExpr) -> Expr a -> [PrimExpr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr a -> PrimExpr
forall a. Expr a -> PrimExpr
toPrimExpr) (Columns a Expr -> [PrimExpr])
-> (a -> Columns a Expr) -> a -> [PrimExpr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Columns a Expr
forall (context :: Context) a.
Table context a =>
a -> Columns a context
toColumns


instance {-# OVERLAPS #-} Arguments () where
  arguments :: () -> [PrimExpr]
arguments ()
_ = []


-- | @'function' name arguments@ runs the PostgreSQL function @name@ with
-- the arguments @arguments@ returning an @'Expr' a@.
function :: (Arguments arguments, Sql DBType a)
  => QualifiedName -> arguments -> Expr a
function :: forall arguments a.
(Arguments arguments, Sql DBType a) =>
QualifiedName -> arguments -> Expr a
function QualifiedName
qualified = Expr a -> Expr a
forall a. Sql DBType a => Expr a -> Expr a
castExpr (Expr a -> Expr a) -> (arguments -> Expr a) -> arguments -> Expr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualifiedName -> arguments -> Expr a
forall arguments a.
Arguments arguments =>
QualifiedName -> arguments -> Expr a
rawFunction QualifiedName
qualified


-- | A less safe version of 'function' that does not wrap the return value in
-- a cast.
rawFunction :: Arguments arguments => QualifiedName -> arguments -> Expr a
rawFunction :: forall arguments a.
Arguments arguments =>
QualifiedName -> arguments -> Expr a
rawFunction QualifiedName
qualified = PrimExpr -> Expr a
forall a. PrimExpr -> Expr a
fromPrimExpr (PrimExpr -> Expr a)
-> (arguments -> PrimExpr) -> arguments -> Expr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualifiedName -> arguments -> PrimExpr
forall arguments.
Arguments arguments =>
QualifiedName -> arguments -> PrimExpr
primFunction QualifiedName
qualified


primFunction :: Arguments arguments
  => QualifiedName -> arguments -> Opaleye.PrimExpr
primFunction :: forall arguments.
Arguments arguments =>
QualifiedName -> arguments -> PrimExpr
primFunction QualifiedName
qualified = Name -> [PrimExpr] -> PrimExpr
Opaleye.FunExpr Name
name ([PrimExpr] -> PrimExpr)
-> (arguments -> [PrimExpr]) -> arguments -> PrimExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. arguments -> [PrimExpr]
forall a. Arguments a => a -> [PrimExpr]
arguments
  where
    name :: Name
name = QualifiedName -> Name
showQualifiedName QualifiedName
qualified


-- | Construct an expression by applying an infix binary operator to two
-- operands.
binaryOperator :: Sql DBType c => QualifiedName -> Expr a -> Expr b -> Expr c
binaryOperator :: forall c a b.
Sql DBType c =>
QualifiedName -> Expr a -> Expr b -> Expr c
binaryOperator QualifiedName
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
$ QualifiedName -> Expr a -> Expr b -> Expr c
forall a b c. QualifiedName -> Expr a -> Expr b -> Expr c
rawBinaryOperator QualifiedName
operator Expr a
a Expr b
b


-- | A less safe version of 'binaryOperator' that does not wrap the return
-- value in a cast.
rawBinaryOperator :: QualifiedName -> Expr a -> Expr b -> Expr c
rawBinaryOperator :: forall a b c. QualifiedName -> Expr a -> Expr b -> Expr c
rawBinaryOperator QualifiedName
operator Expr a
a Expr b
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 (Name -> BinOp
Opaleye.OpOther Name
name)) Expr a
a Expr b
b
  where
    name :: Name
name = QualifiedName -> Name
showQualifiedOperator QualifiedName
operator