{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
{-# language MultiParamTypeClasses #-}
{-# language RecordWildCards #-}
{-# language StandaloneKindSignatures #-}
{-# language TypeFamilies #-}
{-# language TypeOperators #-}
{-# language UndecidableInstances #-}
module Rel8.Expr.Function
( Arguments
, function
, primFunction
, binaryOperator
)
where
import Data.Kind ( Constraint, Type )
import Prelude
import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
import Text.PrettyPrint (parens, text)
import {-# SOURCE #-} Rel8.Expr (Expr)
import Rel8.Expr.Opaleye
( castExpr
, fromPrimExpr, toPrimExpr, zipPrimExprsWith
)
import Rel8.Schema.Escape (escape)
import Rel8.Schema.HTable (hfoldMap)
import Rel8.Schema.Null ( Sql )
import Rel8.Schema.QualifiedName (QualifiedName (..), showQualifiedName)
import Rel8.Table (Table, toColumns)
import Rel8.Type ( DBType )
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 :: (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
. 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
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
$ (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
showQualifiedOperator :: QualifiedName -> String
showQualifiedOperator :: QualifiedName -> Name
showQualifiedOperator QualifiedName {$sel:schema:QualifiedName :: QualifiedName -> Maybe Name
schema = Maybe Name
mschema, Name
name :: Name
$sel:name:QualifiedName :: QualifiedName -> Name
..} = case Maybe Name
mschema of
Maybe Name
Nothing -> Name
name
Just Name
schema ->
Doc -> Name
forall a. Show a => a -> Name
show (Doc -> Name) -> Doc -> Name
forall a b. (a -> b) -> a -> b
$ Name -> Doc
text Name
"OPERATOR" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens (Name -> Doc
escape Name
schema Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Name -> Doc
text Name
"." Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Name -> Doc
text Name
name)