Value.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
module Synthesizer.LLVM.Parameterized.Value where

import qualified Synthesizer.LLVM.Simple.Value as Value

import LLVM.Core hiding (zero, )
import LLVM.Util.Arithmetic (TValue, )
import qualified LLVM.Util.Arithmetic as Arith

{-
import qualified Synthesizer.Basic.Phase as Phase
import qualified Synthesizer.LLVM.Frame.Stereo as Stereo

import Control.Monad (liftM2, liftM3, )
-}

import qualified Algebra.Transcendental as Trans
import qualified Algebra.Algebraic as Algebraic
-- import qualified Algebra.RealRing as RealRing
import qualified Algebra.Field as Field
import qualified Algebra.Ring as Ring
import qualified Algebra.Additive as Additive

import NumericPrelude.Numeric
import NumericPrelude.Base hiding (map, zipWith, writeFile, )


newtype T p a = Cons {decons :: forall r. p -> TValue r a}

instance (Additive.C a, IsArithmetic a, IsConst a) =>
      Additive.C (T p a) where
   zero = lift0 zero
   (+) = lift2 (+)
   (-) = lift2 (-)
   negate = lift1 negate

instance (Ring.C a, IsArithmetic a, IsConst a) =>
      Ring.C (T p a) where
   one = lift0 one
   (*) = lift2 (*)
   fromInteger = constant . fromInteger

instance (Ring.C a, IsArithmetic a, IsConst a) => Enum (T p a) where
   succ x = x + one
   pred x = x - one
   fromEnum _ = error "CodeGenFunction Value: fromEnum"
   toEnum = fromIntegral

{-
instance (IsArithmetic a, Cmp a b, Num a, IsConst a) => Real (T p a) where
   toRational _ = error "CodeGenFunction Value: toRational"

instance (Cmp a b, Num a, IsConst a, IsInteger a) => Integral (T p a) where
   quot = binop (if (isSigned (undefined :: a)) then sdiv else udiv)
   rem  = binop (if (isSigned (undefined :: a)) then srem else urem)
   quotRem x y = (quot x y, rem x y)
   toInteger _ = error "CodeGenFunction Value: toInteger"
-}

instance (Field.C a, IsConst a, IsFloating a) => Field.C (T p a) where
   (/) = lift2 (/)
   fromRational' = constant . fromRational'

{-
instance (Cmp a b, Fractional a, IsConst a, IsFloating a) => RealFrac (T p a) where
   properFraction _ = error "CodeGenFunction Value: properFraction"
-}

instance (Algebraic.C a, IsConst a, IsFloating a) => Algebraic.C (T p a) where
   sqrt = lift1 sqrt

instance (Trans.C a, IsConst a, IsFloating a) => Trans.C (T p a) where
   pi = constant pi
   sin = lift1 sin
   cos = lift1 cos
   tan = lift1 tan

   asin = lift1 asin
   acos = lift1 acos
   atan = lift1 atan

   sinh  = lift1 sinh
   cosh  = lift1 cosh
   asinh = lift1 asinh
   acosh = lift1 acosh
   atanh = lift1 atanh

   (**) = lift2 (**)
   exp = lift1 exp
   log = lift1 log


twoPi ::
   (Trans.C a, IsConst a, IsFloating a) =>
   T p a
twoPi = 2*pi
{-
twoPi ::
   (Cmp a b, P.Floating a, IsConst a, IsFloating a) =>
   TValue r a
twoPi = P.fromInteger 2 P.* P.pi
-}


lift0 :: Value.T a -> T p a
lift0 x =
   Cons $ const $ Value.decons x

lift1 :: (Value.T a -> Value.T b) -> (T p a -> T p b)
lift1 f x =
   Cons (\p -> Value.decons $ f (Value.Cons $ decons x p))

lift2 :: (Value.T a -> Value.T b -> Value.T c) -> (T p a -> T p b -> T p c)
lift2 f x y =
   Cons $ \p -> Value.decons $
      f (Value.Cons $ decons x p) (Value.Cons $ decons y p)


constantValue :: Value a -> T p a
constantValue x =
   Cons (const $ return x)

constant :: (IsConst a) => a -> T p a
constant = constantValue . valueOf

choose :: (IsConst a) => (p -> a) -> T p a
choose x =
   Cons (return . valueOf . x)