Functions.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | This module has common SQL functions and operators which are supported in the most SQL databases
module Database.Groundhog.Generic.Sql.Functions
  ( like,
    notLike,
    in_,
    notIn_,
    lower,
    upper,
    case_,
    SqlDb (..),
    cot,
    atan2,
    radians,
    degrees,
  )
where

import Data.Int (Int64)
import Data.String
import Database.Groundhog.Core
import Database.Groundhog.Expression
import Database.Groundhog.Generic.Sql

in_ ::
  (SqlDb db, Expression db r a, Expression db r b, PrimitivePersistField b, Unifiable a b) =>
  a ->
  [b] ->
  Cond db r
in_ _ [] = Not CondEmpty
in_ a bs = CondRaw $ Snippet $ \conf p -> [parens 45 p $ renderExpr conf (toExpr a) <> " IN (" <> commasJoin (map (renderExpr conf . toExpr) bs) <> ")"]

notIn_ ::
  (SqlDb db, Expression db r a, Expression db r b, PrimitivePersistField b, Unifiable a b) =>
  a ->
  [b] ->
  Cond db r
notIn_ _ [] = CondEmpty
notIn_ a bs = CondRaw $ Snippet $ \conf p -> [parens 45 p $ renderExpr conf (toExpr a) <> " NOT IN (" <> commasJoin (map (renderExpr conf . toExpr) bs) <> ")"]

like :: (SqlDb db, ExpressionOf db r a a', IsString a') => a -> String -> Cond db r
like a b = CondRaw $ operator 40 " LIKE " a b

notLike :: (SqlDb db, ExpressionOf db r a a', IsString a') => a -> String -> Cond db r
notLike a b = CondRaw $ operator 40 " NOT LIKE " a b

lower :: (SqlDb db, ExpressionOf db r a a', IsString a') => a -> Expr db r a'
lower a = mkExpr $ function "lower" [toExpr a]

upper :: (SqlDb db, ExpressionOf db r a a', IsString a') => a -> Expr db r a'
upper a = mkExpr $ function "upper" [toExpr a]

cot :: (FloatingSqlDb db, ExpressionOf db r a a', Floating a') => a -> Expr db r a'
cot a = mkExpr $ function "cot" [toExpr a]

radians, degrees :: (FloatingSqlDb db, ExpressionOf db r a a', Floating a') => a -> Expr db r a'
radians x = mkExpr $ function "radians" [toExpr x]
degrees x = mkExpr $ function "degrees" [toExpr x]

instance (SqlDb db, PersistField a, Num a) => Num (Expr db r a) where
  a + b = mkExpr $ operator 60 "+" a b
  a - b = mkExpr $ operator 60 "-" a b
  a * b = mkExpr $ operator 70 "*" a b
  signum a = signum' a
  abs a = mkExpr $ function "abs" [toExpr a]
  fromInteger a = Expr $ toExpr (fromIntegral a :: Int64)

instance (SqlDb db, PersistField a, Fractional a) => Fractional (Expr db r a) where
  a / b = mkExpr $ operator 70 "/" a b
  fromRational a = Expr $ toExpr (fromRational a :: Double)

instance (FloatingSqlDb db, PersistField a, Floating a) => Floating (Expr db r a) where
  pi = mkExpr $ function "pi" []
  exp x = mkExpr $ function "exp" [toExpr x]
  sqrt x = mkExpr $ function "sqrt" [toExpr x]
  log x = log' x
  x ** y = mkExpr $ function "pow" [toExpr x, toExpr y]
  logBase b x = logBase' b x
  sin x = mkExpr $ function "sin" [toExpr x]
  tan x = mkExpr $ function "tan" [toExpr x]
  cos x = mkExpr $ function "cos" [toExpr x]
  asin x = mkExpr $ function "asin" [toExpr x]
  atan x = mkExpr $ function "atan" [toExpr x]
  acos x = mkExpr $ function "acos" [toExpr x]
  sinh x = (exp x - exp (- x)) / 2
  tanh x = (exp (2 * x) - 1) / (exp (2 * x) + 1)
  cosh x = (exp x + exp (- x)) / 2
  asinh x = log $ x + sqrt (x * x + 1)
  atanh x = log ((1 + x) / (1 - x)) / 2
  acosh x = log $ x + sqrt (x * x - 1)

instance (SqlDb db, PersistField a, Ord a) => Ord (Expr db r a) where
  compare = error "compare: instance Ord (Expr db r a) does not have implementation"
  (<=) = error "(<=): instance Ord (Expr db r a) does not have implementation"
  max a b = mkExpr $ function "max" [toExpr a, toExpr b]
  min a b = mkExpr $ function "min" [toExpr a, toExpr b]

instance (SqlDb db, PersistField a, Real a) => Real (Expr db r a) where
  toRational = error "toRational: instance Real (Expr db r a) is made only for Integral superclass constraint"

instance (SqlDb db, PersistField a, Enum a) => Enum (Expr db r a) where
  toEnum = error "toEnum: instance Enum (Expr db r a) is made only for Integral superclass constraint"
  fromEnum = error "fromEnum: instance Enum (Expr db r a) is made only for Integral superclass constraint"

instance (SqlDb db, PurePersistField a, Integral a) => Integral (Expr db r a) where
  quotRem x y = quotRem' x y
  divMod x y = (div', mod')
    where
      div' = mkExprWithConf $ \conf _ ->
        let x' = prerenderExpr conf x
            y' = prerenderExpr conf y
         in case_
              [ (x' >. zero &&. y' <. zero, (x' - y' - 1) `quot` y'),
                (x' <. zero &&. y' >. zero, (x' - y' + 1) `quot` y')
              ]
              (x' `quot` y')
      mod' = mkExprWithConf $ \conf _ ->
        let x' = prerenderExpr conf x
            y' = prerenderExpr conf y
         in case_
              [ ( x' >. zero &&. y' <. zero ||. x' <. zero &&. y' >. zero,
                  case_ [((x' `rem` y') /=. zero, x' `rem` y' + y')] zero
                )
              ]
              (x' `rem` y')
      zero = 0 `asTypeOf` (undefined :: Expr db r a -> a) x
  toInteger = error "toInteger: instance Integral (Expr db r a) does not have implementation"

case_ ::
  (SqlDb db, ExpressionOf db r a a', ExpressionOf db r b a') =>
  -- | Conditions
  [(Cond db r, a)] ->
  -- | It is returned when none of conditions is true
  b ->
  Expr db r a'
case_ [] else_ = Expr $ toExpr else_
case_ cases else_ = mkExpr $
  Snippet $ \conf _ ->
    [ "case "
        <> intercalateS (fromChar ' ') (map (rend conf) cases)
        <> " else "
        <> renderExpr conf (toExpr else_)
        <> " end"
    ]
  where
    rend conf (cond, a) = case renderCond conf cond of
      Nothing -> error "case_: empty condition"
      Just cond' -> "when " <> cond' <> " then " <> renderExpr conf (toExpr a)