Expr.hs

{-# 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 Show


instance Sql DBSemigroup a => Semigroup (Expr a) where
  (<>) = case nullable @a of
    Null -> liftOpNull (<>.)
    NotNull -> (<>.)
  {-# INLINABLE (<>) #-}


instance Sql DBMonoid a => Monoid (Expr a) where
  mempty = case nullable @a of
    Null -> nullify memptyExpr
    NotNull -> memptyExpr
  {-# INLINABLE mempty #-}


instance (Sql IsString a, Sql DBType a) => IsString (Expr a) where
  fromString = litExpr . case nullable @a of
    Null -> Just . fromString
    NotNull -> fromString


instance Sql DBNum a => Num (Expr a) where
  (+) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:+))
  (*) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:*))
  (-) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:-))

  abs = mapPrimExpr (Opaleye.UnExpr Opaleye.OpAbs)
  negate = mapPrimExpr (Opaleye.UnExpr Opaleye.OpNegate)

  signum = castExpr . mapPrimExpr (Opaleye.UnExpr (Opaleye.UnOpOther "SIGN"))

  fromInteger = castExpr . fromPrimExpr . Opaleye.ConstExpr . Opaleye.IntegerLit


instance Sql DBFractional a => Fractional (Expr a) where
  (/) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:/))

  fromRational = castExpr . Expr . toScientific
    where
      toScientific r = case fromRationalRepetendLimited 20 r of
        Right (s, Nothing) -> Opaleye.ConstExpr (Opaleye.NumericLit s)
        _ -> Opaleye.BinExpr (Opaleye.:/) (int n) (int d)
          where
            int = Opaleye.ConstExpr . Opaleye.NumericLit . fromInteger
            n = numerator r
            d = denominator r


instance Sql DBFloating a => Floating (Expr a) where
  pi = function "pi" ()
  exp = function "exp"
  log = function "ln"
  sqrt = function "sqrt"
  (**) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:^))
  logBase a b = function "log" (a, b)
  sin = function "sin"
  cos = function "cos"
  tan = function "tan"
  asin = function "asin"
  acos = function "acos"
  atan = function "atan"
  sinh = function "sinh"
  cosh = function "cosh"
  tanh = function "tanh"
  asinh = function "asinh"
  acosh = function "acosh"
  atanh = function "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 a = HIdentity a
  fromColumns (HIdentity a) = a
  toResult a = HIdentity (Identity a)
  fromResult (HIdentity (Identity a)) = a