{-# language DataKinds #-}
{-# language DerivingStrategies #-}
{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
{-# language MultiParamTypeClasses #-}
{-# language OverloadedStrings #-}
{-# language ScopedTypeVariables #-}
{-# language StandaloneKindSignatures #-}
{-# language TypeApplications #-}
{-# language TypeFamilies #-}
{-# language UndecidableInstances #-}

module Rel8.Expr
  ( Expr(..)
  )
where

-- base
import Data.Functor.Identity ( Identity( Identity ) )
import Data.Ratio (denominator, numerator)
import Data.String ( IsString, fromString )
import Prelude hiding ( null )

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

-- rel8
import Rel8.Expr.Function (function)
import Rel8.Expr.Null ( liftOpNull, nullify )
import Rel8.Expr.Opaleye
  ( castExpr
  , fromPrimExpr
  , mapPrimExpr
  , zipPrimExprsWith
  )
import Rel8.Expr.Serialize ( litExpr )
import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
import qualified Rel8.Schema.Kind as K
import Rel8.Schema.Null ( Nullity( Null, NotNull ), Sql, nullable )
import Rel8.Table
  ( Table, Columns, Context, fromColumns, toColumns
  , FromExprs, fromResult, toResult
  , Transpose
  )
import Rel8.Type ( DBType )
import Rel8.Type.Monoid ( DBMonoid, memptyExpr )
import Rel8.Type.Num ( DBFloating, DBFractional, DBNum )
import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )

-- scientific
import Data.Scientific (fromRationalRepetendLimited)


-- | Typed SQL expressions.
type Expr :: K.Context
newtype Expr a = Expr Opaleye.PrimExpr
  deriving stock Int -> Expr a -> ShowS
[Expr a] -> ShowS
Expr a -> String
(Int -> Expr a -> ShowS)
-> (Expr a -> String) -> ([Expr a] -> ShowS) -> Show (Expr a)
forall a. Int -> Expr a -> ShowS
forall a. [Expr a] -> ShowS
forall a. Expr a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Int -> Expr a -> ShowS
showsPrec :: Int -> Expr a -> ShowS
$cshow :: forall a. Expr a -> String
show :: Expr a -> String
$cshowList :: forall a. [Expr a] -> ShowS
showList :: [Expr a] -> ShowS
Show


instance Sql DBSemigroup a => Semigroup (Expr a) where
  <> :: Expr a -> Expr a -> Expr a
(<>) = case forall a. Nullable a => Nullity a
nullable @a of
    Nullity a
Null -> (Expr a1 -> Expr a1 -> Expr a1)
-> Expr (Maybe a1) -> Expr (Maybe a1) -> Expr (Maybe a1)
forall c a b.
DBType c =>
(Expr a -> Expr b -> Expr c)
-> Expr (Maybe a) -> Expr (Maybe b) -> Expr (Maybe c)
liftOpNull Expr a1 -> Expr a1 -> Expr a1
forall a. DBSemigroup a => Expr a -> Expr a -> Expr a
(<>.)
    Nullity a
NotNull -> Expr a -> Expr a -> Expr a
forall a. DBSemigroup a => Expr a -> Expr a -> Expr a
(<>.)
  {-# INLINABLE (<>) #-}


instance Sql DBMonoid a => Monoid (Expr a) where
  mempty :: Expr a
mempty = case forall a. Nullable a => Nullity a
nullable @a of
    Nullity a
Null -> Expr a1 -> Expr (Maybe a1)
forall a. NotNull a => Expr a -> Expr (Maybe a)
nullify Expr a1
forall a. DBMonoid a => Expr a
memptyExpr
    Nullity a
NotNull -> Expr a
forall a. DBMonoid a => Expr a
memptyExpr
  {-# INLINABLE mempty #-}


instance (Sql IsString a, Sql DBType a) => IsString (Expr a) where
  fromString :: String -> Expr a
fromString = a -> Expr a
forall a. Sql DBType a => a -> Expr a
litExpr (a -> Expr a) -> (String -> a) -> String -> Expr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. case forall a. Nullable a => Nullity a
nullable @a of
    Nullity a
Null -> a1 -> a
a1 -> Maybe a1
forall a. a -> Maybe a
Just (a1 -> a) -> (String -> a1) -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> a1
forall a. IsString a => String -> a
fromString
    Nullity a
NotNull -> String -> a
forall a. IsString a => String -> a
fromString


instance Sql DBNum a => Num (Expr a) where
  + :: Expr a -> Expr a -> Expr a
(+) = (PrimExpr -> PrimExpr -> PrimExpr) -> Expr a -> Expr a -> Expr a
forall a b c.
(PrimExpr -> PrimExpr -> PrimExpr) -> Expr a -> Expr b -> Expr c
zipPrimExprsWith (BinOp -> PrimExpr -> PrimExpr -> PrimExpr
Opaleye.BinExpr BinOp
(Opaleye.:+))
  * :: Expr a -> Expr a -> Expr a
(*) = (PrimExpr -> PrimExpr -> PrimExpr) -> Expr a -> Expr a -> Expr a
forall a b c.
(PrimExpr -> PrimExpr -> PrimExpr) -> Expr a -> Expr b -> Expr c
zipPrimExprsWith (BinOp -> PrimExpr -> PrimExpr -> PrimExpr
Opaleye.BinExpr BinOp
(Opaleye.:*))
  (-) = (PrimExpr -> PrimExpr -> PrimExpr) -> Expr a -> Expr a -> Expr a
forall a b c.
(PrimExpr -> PrimExpr -> PrimExpr) -> Expr a -> Expr b -> Expr c
zipPrimExprsWith (BinOp -> PrimExpr -> PrimExpr -> PrimExpr
Opaleye.BinExpr BinOp
(Opaleye.:-))

  abs :: Expr a -> Expr a
abs = (PrimExpr -> PrimExpr) -> Expr a -> Expr a
forall a b. (PrimExpr -> PrimExpr) -> Expr a -> Expr b
mapPrimExpr (UnOp -> PrimExpr -> PrimExpr
Opaleye.UnExpr UnOp
Opaleye.OpAbs)
  negate :: Expr a -> Expr a
negate = (PrimExpr -> PrimExpr) -> Expr a -> Expr a
forall a b. (PrimExpr -> PrimExpr) -> Expr a -> Expr b
mapPrimExpr (UnOp -> PrimExpr -> PrimExpr
Opaleye.UnExpr UnOp
Opaleye.OpNegate)

  signum :: Expr a -> Expr a
signum = Expr a -> Expr a
forall a. Sql DBType a => Expr a -> Expr a
castExpr (Expr a -> Expr a) -> (Expr a -> Expr a) -> Expr a -> Expr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PrimExpr -> PrimExpr) -> Expr a -> Expr a
forall a b. (PrimExpr -> PrimExpr) -> Expr a -> Expr b
mapPrimExpr (UnOp -> PrimExpr -> PrimExpr
Opaleye.UnExpr (String -> UnOp
Opaleye.UnOpOther String
"SIGN"))

  fromInteger :: Integer -> Expr a
fromInteger = Expr a -> Expr a
forall a. Sql DBType a => Expr a -> Expr a
castExpr (Expr a -> Expr a) -> (Integer -> Expr a) -> Integer -> Expr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimExpr -> Expr a
forall a. PrimExpr -> Expr a
fromPrimExpr (PrimExpr -> Expr a) -> (Integer -> PrimExpr) -> Integer -> Expr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Literal -> PrimExpr
Opaleye.ConstExpr (Literal -> PrimExpr)
-> (Integer -> Literal) -> Integer -> PrimExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Literal
Opaleye.IntegerLit


instance Sql DBFractional a => Fractional (Expr a) where
  / :: Expr a -> Expr a -> Expr a
(/) = (PrimExpr -> PrimExpr -> PrimExpr) -> Expr a -> Expr a -> Expr a
forall a b c.
(PrimExpr -> PrimExpr -> PrimExpr) -> Expr a -> Expr b -> Expr c
zipPrimExprsWith (BinOp -> PrimExpr -> PrimExpr -> PrimExpr
Opaleye.BinExpr BinOp
(Opaleye.:/))

  fromRational :: Rational -> Expr a
fromRational = Expr a -> Expr a
forall a. Sql DBType a => Expr a -> Expr a
castExpr (Expr a -> Expr a) -> (Rational -> Expr a) -> Rational -> Expr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimExpr -> Expr a
forall a. PrimExpr -> Expr a
Expr (PrimExpr -> Expr a)
-> (Rational -> PrimExpr) -> Rational -> Expr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> PrimExpr
toScientific
    where
      toScientific :: Rational -> PrimExpr
toScientific Rational
r = case Int
-> Rational
-> Either (Scientific, Rational) (Scientific, Maybe Int)
fromRationalRepetendLimited Int
20 Rational
r of
        Right (Scientific
s, Maybe Int
Nothing) -> Literal -> PrimExpr
Opaleye.ConstExpr (Scientific -> Literal
Opaleye.NumericLit Scientific
s)
        Either (Scientific, Rational) (Scientific, Maybe Int)
_ -> BinOp -> PrimExpr -> PrimExpr -> PrimExpr
Opaleye.BinExpr BinOp
(Opaleye.:/) (Integer -> PrimExpr
int Integer
n) (Integer -> PrimExpr
int Integer
d)
          where
            int :: Integer -> PrimExpr
int = Literal -> PrimExpr
Opaleye.ConstExpr (Literal -> PrimExpr)
-> (Integer -> Literal) -> Integer -> PrimExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> Literal
Opaleye.NumericLit (Scientific -> Literal)
-> (Integer -> Scientific) -> Integer -> Literal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Scientific
forall a. Num a => Integer -> a
fromInteger
            n :: Integer
n = Rational -> Integer
forall a. Ratio a -> a
numerator Rational
r
            d :: Integer
d = Rational -> Integer
forall a. Ratio a -> a
denominator Rational
r


instance Sql DBFloating a => Floating (Expr a) where
  pi :: Expr a
pi = QualifiedName -> () -> Expr a
forall arguments a.
(Arguments arguments, Sql DBType a) =>
QualifiedName -> arguments -> Expr a
function QualifiedName
"pi" ()
  exp :: Expr a -> Expr a
exp = QualifiedName -> Expr a -> Expr a
forall arguments a.
(Arguments arguments, Sql DBType a) =>
QualifiedName -> arguments -> Expr a
function QualifiedName
"exp"
  log :: Expr a -> Expr a
log = QualifiedName -> Expr a -> Expr a
forall arguments a.
(Arguments arguments, Sql DBType a) =>
QualifiedName -> arguments -> Expr a
function QualifiedName
"ln"
  sqrt :: Expr a -> Expr a
sqrt = QualifiedName -> Expr a -> Expr a
forall arguments a.
(Arguments arguments, Sql DBType a) =>
QualifiedName -> arguments -> Expr a
function QualifiedName
"sqrt"
  ** :: Expr a -> Expr a -> Expr a
(**) = (PrimExpr -> PrimExpr -> PrimExpr) -> Expr a -> Expr a -> Expr a
forall a b c.
(PrimExpr -> PrimExpr -> PrimExpr) -> Expr a -> Expr b -> Expr c
zipPrimExprsWith (BinOp -> PrimExpr -> PrimExpr -> PrimExpr
Opaleye.BinExpr BinOp
(Opaleye.:^))
  logBase :: Expr a -> Expr a -> Expr a
logBase Expr a
a Expr a
b = QualifiedName -> (Expr a, Expr a) -> Expr a
forall arguments a.
(Arguments arguments, Sql DBType a) =>
QualifiedName -> arguments -> Expr a
function QualifiedName
"log" (Expr a
a, Expr a
b)
  sin :: Expr a -> Expr a
sin = QualifiedName -> Expr a -> Expr a
forall arguments a.
(Arguments arguments, Sql DBType a) =>
QualifiedName -> arguments -> Expr a
function QualifiedName
"sin"
  cos :: Expr a -> Expr a
cos = QualifiedName -> Expr a -> Expr a
forall arguments a.
(Arguments arguments, Sql DBType a) =>
QualifiedName -> arguments -> Expr a
function QualifiedName
"cos"
  tan :: Expr a -> Expr a
tan = QualifiedName -> Expr a -> Expr a
forall arguments a.
(Arguments arguments, Sql DBType a) =>
QualifiedName -> arguments -> Expr a
function QualifiedName
"tan"
  asin :: Expr a -> Expr a
asin = QualifiedName -> Expr a -> Expr a
forall arguments a.
(Arguments arguments, Sql DBType a) =>
QualifiedName -> arguments -> Expr a
function QualifiedName
"asin"
  acos :: Expr a -> Expr a
acos = QualifiedName -> Expr a -> Expr a
forall arguments a.
(Arguments arguments, Sql DBType a) =>
QualifiedName -> arguments -> Expr a
function QualifiedName
"acos"
  atan :: Expr a -> Expr a
atan = QualifiedName -> Expr a -> Expr a
forall arguments a.
(Arguments arguments, Sql DBType a) =>
QualifiedName -> arguments -> Expr a
function QualifiedName
"atan"
  sinh :: Expr a -> Expr a
sinh = QualifiedName -> Expr a -> Expr a
forall arguments a.
(Arguments arguments, Sql DBType a) =>
QualifiedName -> arguments -> Expr a
function QualifiedName
"sinh"
  cosh :: Expr a -> Expr a
cosh = QualifiedName -> Expr a -> Expr a
forall arguments a.
(Arguments arguments, Sql DBType a) =>
QualifiedName -> arguments -> Expr a
function QualifiedName
"cosh"
  tanh :: Expr a -> Expr a
tanh = QualifiedName -> Expr a -> Expr a
forall arguments a.
(Arguments arguments, Sql DBType a) =>
QualifiedName -> arguments -> Expr a
function QualifiedName
"tanh"
  asinh :: Expr a -> Expr a
asinh = QualifiedName -> Expr a -> Expr a
forall arguments a.
(Arguments arguments, Sql DBType a) =>
QualifiedName -> arguments -> Expr a
function QualifiedName
"asinh"
  acosh :: Expr a -> Expr a
acosh = QualifiedName -> Expr a -> Expr a
forall arguments a.
(Arguments arguments, Sql DBType a) =>
QualifiedName -> arguments -> Expr a
function QualifiedName
"acosh"
  atanh :: Expr a -> Expr a
atanh = QualifiedName -> Expr a -> Expr a
forall arguments a.
(Arguments arguments, Sql DBType a) =>
QualifiedName -> arguments -> Expr a
function QualifiedName
"atanh"


instance Sql DBType a => Table Expr (Expr a) where
  type Columns (Expr a) = HIdentity a
  type Context (Expr a) = Expr
  type FromExprs (Expr a) = a
  type Transpose to (Expr a) = to a

  toColumns :: Expr a -> Columns (Expr a) Expr
toColumns Expr a
a = Expr a -> HIdentity a Expr
forall a (context :: Context). context a -> HIdentity a context
HIdentity Expr a
a
  fromColumns :: Columns (Expr a) Expr -> Expr a
fromColumns (HIdentity Expr a
a) = Expr a
a
  toResult :: FromExprs (Expr a) -> Columns (Expr a) Result
toResult FromExprs (Expr a)
a = Identity a -> HIdentity a Result
forall a (context :: Context). context a -> HIdentity a context
HIdentity (a -> Identity a
forall a. a -> Identity a
Identity a
FromExprs (Expr a)
a)
  fromResult :: Columns (Expr a) Result -> FromExprs (Expr a)
fromResult (HIdentity (Identity a
a)) = a
FromExprs (Expr a)
a