content: {-# 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)
  