{-# LANGUAGE ScopedTypeVariables #-}

module Ivory.Language.Float where

import Ivory.Language.IBool
import Ivory.Language.Proxy
import Ivory.Language.Ref
import Ivory.Language.Type
import qualified Ivory.Language.Syntax as I


-- | NaN testing.
isnan :: forall a. (IvoryVar a, Floating a) => a -> IBool
isnan a = wrapExpr (I.ExpOp (I.ExpIsNan ty) [unwrapExpr a])
  where
  ty = ivoryType (Proxy :: Proxy a)

-- | Infinite testing.
isinf :: forall a. (IvoryVar a, Floating a) => a -> IBool
isinf a = wrapExpr (I.ExpOp (I.ExpIsInf ty) [unwrapExpr a])
  where
  ty = ivoryType (Proxy :: Proxy a)

-- Floating Point --------------------------------------------------------------

newtype IFloat = IFloat { getIFloat :: I.Expr }

ifloat :: Float -> IFloat
ifloat  = IFloat . I.ExpLit . I.LitFloat

instance IvoryType IFloat where
  ivoryType _ = I.TyFloat

instance IvoryVar IFloat where
  wrapVar    = wrapVarExpr
  unwrapExpr = getIFloat

instance IvoryExpr IFloat where
  wrapExpr = IFloat

instance IvoryEq  IFloat

instance IvoryOrd IFloat

instance IvoryStore IFloat

instance Num IFloat where
  (*)         = exprBinop (*)
  (+)         = exprBinop (+)
  (-)         = exprBinop (-)
  abs         = exprUnary abs
  signum      = exprUnary signum
  negate      = exprUnary negate
  fromInteger = ifloat . fromInteger

instance Fractional IFloat where
  (/)          = exprBinop (/)
  recip        = exprUnary recip
  fromRational = ifloat . fromRational

instance Floating IFloat where
  pi      = ifloat pi
  exp     = exprUnary exp
  sqrt    = exprUnary sqrt
  log     = exprUnary log
  (**)    = exprBinop (**)
  logBase = exprBinop (logBase)
  sin     = exprUnary sin
  tan     = exprUnary tan
  cos     = exprUnary cos
  asin    = exprUnary asin
  atan    = exprUnary atan
  acos    = exprUnary acos
  sinh    = exprUnary sinh
  tanh    = exprUnary tanh
  cosh    = exprUnary cosh
  asinh   = exprUnary asinh
  atanh   = exprUnary atanh
  acosh   = exprUnary acosh

-- Double Precision ------------------------------------------------------------

newtype IDouble = IDouble { getIDouble :: I.Expr }

idouble :: Double -> IDouble
idouble  = IDouble . I.ExpLit . I.LitDouble

instance Fractional IDouble where
  (/)          = exprBinop (/)
  recip        = exprUnary recip
  fromRational = idouble . fromRational

instance IvoryType IDouble where
  ivoryType _ = I.TyDouble

instance IvoryVar IDouble where
  wrapVar    = wrapVarExpr
  unwrapExpr = getIDouble

instance IvoryExpr IDouble where
  wrapExpr = IDouble

instance IvoryEq  IDouble

instance IvoryOrd IDouble

instance IvoryStore IDouble

instance Num IDouble where
  (*)         = exprBinop (*)
  (+)         = exprBinop (+)
  (-)         = exprBinop (-)
  abs         = exprUnary abs
  signum      = exprUnary signum
  negate      = exprUnary negate
  fromInteger = idouble . fromInteger

instance Floating IDouble where
  pi      = idouble pi
  exp     = exprUnary exp
  sqrt    = exprUnary sqrt
  log     = exprUnary log
  (**)    = exprBinop (**)
  logBase = exprBinop (logBase)
  sin     = exprUnary sin
  tan     = exprUnary tan
  cos     = exprUnary cos
  asin    = exprUnary asin
  atan    = exprUnary atan
  acos    = exprUnary acos
  sinh    = exprUnary sinh
  tanh    = exprUnary tanh
  cosh    = exprUnary cosh
  asinh   = exprUnary asinh
  atanh   = exprUnary atanh
  acosh   = exprUnary acosh


-- Rounding --------------------------------------------------------------------

-- XXX do not export
primRound :: IvoryExpr a => I.ExpOp -> a -> a
primRound op a = wrapExpr (I.ExpOp op [unwrapExpr a])

class (Floating a, IvoryExpr a) => IvoryFloat a where
  -- | Round a floating point number.
  roundF :: a -> a
  roundF  = primRound I.ExpRoundF

  -- | Take the ceiling of a floating point number.
  ceilF :: a -> a
  ceilF  = primRound I.ExpCeilF

  -- | Take the floor of a floating point number.
  floorF :: a -> a
  floorF  = primRound I.ExpFloorF

  -- | The arctangent function of two arguments.
  atan2F :: a -> a -> a
  atan2F y x = wrapExpr (I.ExpOp I.ExpFAtan2 [unwrapExpr y, unwrapExpr x])

instance IvoryFloat IFloat
instance IvoryFloat IDouble