llvm-dsl-0.2: src/LLVM/DSL/Expression.hs

{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module LLVM.DSL.Expression where

import qualified LLVM.Extra.ScalarOrVector as SoV
import qualified LLVM.Extra.Nice.Value as NiceValue
import qualified LLVM.Extra.FastMath as FastMath
import qualified LLVM.Extra.Scalar as Scalar
import qualified LLVM.Extra.Arithmetic as A
import qualified LLVM.Extra.Control as C
import qualified LLVM.Core as LLVM
import LLVM.Extra.Nice.Value (PatternTuple, Decomposed, Atom)

import qualified Control.Monad.HT as Monad
import Control.Monad.IO.Class (liftIO)

import qualified Data.Enum.Storable as Enum
import qualified Data.Tuple.HT as TupleHT
import qualified Data.Tuple as Tuple
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Complex (Complex((:+)))
import Data.Bool8 (Bool8)

import qualified Foreign.Storable.Record.Tuple as StTuple

import qualified Algebra.Transcendental as Trans
import qualified Algebra.Algebraic as Algebraic
import qualified Algebra.Absolute as Absolute
import qualified Algebra.Module as Module
import qualified Algebra.Field as Field
import qualified Algebra.Ring as Ring
import qualified Algebra.Additive as Additive

import qualified Number.Complex as Complex

import System.IO.Unsafe (unsafePerformIO)

import qualified Prelude as P
import Prelude hiding
   (fst, snd, min, max, zip, unzip, zip3, unzip3,
    curry, uncurry, recip, pi, sqrt, maybe, toEnum, fromEnum, pred, succ)


newtype Exp a = Exp {unExp :: forall r. LLVM.CodeGenFunction r (NiceValue.T a)}


{-
Using IORef should be thread-safe here,
because you cannot fork within CodeGenFunction.
-}
unique :: (forall r. LLVM.CodeGenFunction r (NiceValue.T a)) -> Exp a
unique = Exp

_unique :: (forall r. LLVM.CodeGenFunction r (NiceValue.T a)) -> Exp a
_unique code = unsafePerformIO $ fmap (withKey code) $ newIORef Nothing

withKey ::
   (forall r. LLVM.CodeGenFunction r (NiceValue.T a)) ->
   IORef (Maybe (NiceValue.T a)) -> Exp a
withKey code ref =
   Exp (do
      ma <- liftIO $ readIORef ref
      case ma of
         Just a -> return a
         Nothing -> do
            a <- code
            liftIO $ writeIORef ref $ Just a
            return a)


with :: Exp a -> (Exp a -> Exp b) -> Exp b
with (Exp code) f =
   Exp (do
      a <- code
      unExp (f (Exp (return a))))


class Value val where
   lift0 :: NiceValue.T a -> val a
   lift1 ::
      (NiceValue.T a -> NiceValue.T b) ->
      val a -> val b
   lift2 ::
      (NiceValue.T a -> NiceValue.T b -> NiceValue.T c) ->
      val a -> val b -> val c

instance Value NiceValue.T where
   lift0 = id
   lift1 = id
   lift2 = id

instance Value Exp where
   lift0 a = unique (return a)
   lift1 f (Exp a) = unique (Monad.lift f a)
   lift2 f (Exp a) (Exp b) = unique (Monad.lift2 f a b)

lift3 ::
   (Value val) =>
   (NiceValue.T a -> NiceValue.T b -> NiceValue.T c -> NiceValue.T d) ->
   val a -> val b -> val c -> val d
lift3 f a b = lift2 (NiceValue.uncurry f) (zip a b)

lift4 ::
   (Value val) =>
   (NiceValue.T a -> NiceValue.T b -> NiceValue.T c -> NiceValue.T d ->
    NiceValue.T e) ->
   val a -> val b -> val c -> val d -> val e
lift4 f a b = lift3 (NiceValue.uncurry f) (zip a b)



liftM ::
   (Aggregate ae am) =>
   (forall r.
    am -> LLVM.CodeGenFunction r (NiceValue.T b)) ->
   (ae -> Exp b)
liftM f a = unique (f =<< bundle a)

liftM2 ::
   (Aggregate ae am) =>
   (Aggregate be bm) =>
   (forall r.
    am -> bm -> LLVM.CodeGenFunction r (NiceValue.T c)) ->
   (ae -> be -> Exp c)
liftM2 f a b = unique (Monad.liftJoin2 f (bundle a) (bundle b))

liftM3 ::
   (Aggregate ae am) =>
   (Aggregate be bm) =>
   (Aggregate ce cm) =>
   (forall r.
    am -> bm -> cm -> LLVM.CodeGenFunction r (NiceValue.T d)) ->
   (ae -> be -> ce -> Exp d)
liftM3 f a b c = unique (Monad.liftJoin3 f (bundle a) (bundle b) (bundle c))


unliftM1 ::
   (Aggregate ae am) =>
   (Aggregate be bm) =>
   (ae -> be) ->
   am -> LLVM.CodeGenFunction r bm
unliftM1 f ix = bundle (f (dissect ix))

unliftM2 ::
   (Aggregate ae am) =>
   (Aggregate be bm) =>
   (Aggregate ce cm) =>
   (ae -> be -> ce) ->
   am -> bm -> LLVM.CodeGenFunction r cm
unliftM2 f ix jx = bundle (f (dissect ix) (dissect jx))

unliftM3 ::
   (Aggregate ae am) =>
   (Aggregate be bm) =>
   (Aggregate ce cm) =>
   (Aggregate de dm) =>
   (ae -> be -> ce -> de) ->
   am -> bm -> cm -> LLVM.CodeGenFunction r dm
unliftM3 f ix jx kx = bundle (f (dissect ix) (dissect jx) (dissect kx))

unliftM4 ::
   (Aggregate ae am) =>
   (Aggregate be bm) =>
   (Aggregate ce cm) =>
   (Aggregate de dm) =>
   (Aggregate ee em) =>
   (ae -> be -> ce -> de -> ee) ->
   am -> bm -> cm -> dm -> LLVM.CodeGenFunction r em
unliftM4 f ix jx kx lx =
   bundle (f (dissect ix) (dissect jx) (dissect kx) (dissect lx))


liftReprM ::
   (forall r.
    NiceValue.Repr a ->
    LLVM.CodeGenFunction r (NiceValue.Repr b)) ->
   (Exp a -> Exp b)
liftReprM f = liftM (NiceValue.liftM f)

liftReprM2 ::
   (forall r.
    NiceValue.Repr a -> NiceValue.Repr b ->
    LLVM.CodeGenFunction r (NiceValue.Repr c)) ->
   (Exp a -> Exp b -> Exp c)
liftReprM2 f = liftM2 (NiceValue.liftM2 f)

liftReprM3 ::
   (forall r.
    NiceValue.Repr a -> NiceValue.Repr b -> NiceValue.Repr c ->
    LLVM.CodeGenFunction r (NiceValue.Repr d)) ->
   (Exp a -> Exp b -> Exp c -> Exp d)
liftReprM3 f = liftM3 (NiceValue.liftM3 f)



zip :: (Value val) => val a -> val b -> val (a, b)
zip = lift2 NiceValue.zip

zip3 :: (Value val) => val a -> val b -> val c -> val (a, b, c)
zip3 = lift3 NiceValue.zip3

zip4 :: (Value val) => val a -> val b -> val c -> val d -> val (a, b, c, d)
zip4 = lift4 NiceValue.zip4

unzip :: (Value val) => val (a, b) -> (val a, val b)
unzip ab = (fst ab, snd ab)

unzip3 :: (Value val) => val (a, b, c) -> (val a, val b, val c)
unzip3 abc = (fst3 abc, snd3 abc, thd3 abc)

unzip4 :: (Value val) => val (a, b, c, d) -> (val a, val b, val c, val d)
unzip4 abcd =
   (lift1 (\(NiceValue.Cons (a,_,_,_)) -> NiceValue.Cons a) abcd,
    lift1 (\(NiceValue.Cons (_,b,_,_)) -> NiceValue.Cons b) abcd,
    lift1 (\(NiceValue.Cons (_,_,c,_)) -> NiceValue.Cons c) abcd,
    lift1 (\(NiceValue.Cons (_,_,_,d)) -> NiceValue.Cons d) abcd)


fst :: (Value val) => val (a, b) -> val a
fst = lift1 NiceValue.fst

snd :: (Value val) => val (a, b) -> val b
snd = lift1 NiceValue.snd

mapFst :: (Exp a -> Exp b) -> Exp (a, c) -> Exp (b, c)
mapFst f = liftM (NiceValue.mapFstF (unliftM1 f))

mapSnd :: (Exp b -> Exp c) -> Exp (a, b) -> Exp (a, c)
mapSnd f = liftM (NiceValue.mapSndF (unliftM1 f))

mapPair :: (Exp a0 -> Exp a1, Exp b0 -> Exp b1) -> Exp (a0, b0) -> Exp (a1, b1)
mapPair (f,g) = mapFst f . mapSnd g

swap :: (Value val) => val (a, b) -> val (b, a)
swap = lift1 NiceValue.swap

curry :: (Exp (a,b) -> c) -> (Exp a -> Exp b -> c)
curry f = Tuple.curry (f . Tuple.uncurry zip)

uncurry :: (Exp a -> Exp b -> c) -> (Exp (a,b) -> c)
uncurry f = Tuple.uncurry f . unzip


fst3 :: (Value val) => val (a,b,c) -> val a
fst3 = lift1 NiceValue.fst3

snd3 :: (Value val) => val (a,b,c) -> val b
snd3 = lift1 NiceValue.snd3

thd3 :: (Value val) => val (a,b,c) -> val c
thd3 = lift1 NiceValue.thd3

mapFst3 :: (Exp a0 -> Exp a1) -> Exp (a0,b,c) -> Exp (a1,b,c)
mapFst3 f = liftM (NiceValue.mapFst3F (unliftM1 f))

mapSnd3 :: (Exp b0 -> Exp b1) -> Exp (a,b0,c) -> Exp (a,b1,c)
mapSnd3 f = liftM (NiceValue.mapSnd3F (unliftM1 f))

mapThd3 :: (Exp c0 -> Exp c1) -> Exp (a,b,c0) -> Exp (a,b,c1)
mapThd3 f = liftM (NiceValue.mapThd3F (unliftM1 f))

mapTriple ::
   (Exp a0 -> Exp a1, Exp b0 -> Exp b1, Exp c0 -> Exp c1) ->
   Exp (a0,b0,c0) -> Exp (a1,b1,c1)
mapTriple (f,g,h) = mapFst3 f . mapSnd3 g . mapThd3 h


tuple :: Exp tuple -> Exp (StTuple.Tuple tuple)
tuple = lift1 NiceValue.tuple

untuple :: Exp (StTuple.Tuple tuple) -> Exp tuple
untuple = lift1 NiceValue.untuple


modifyNiceValue ::
   (Value val,
    NiceValue.Compose a,
    NiceValue.Decompose pattern,
    NiceValue.PatternTuple pattern ~ tuple) =>
   pattern ->
   (Decomposed NiceValue.T pattern -> a) ->
   val tuple -> val (NiceValue.Composed a)
modifyNiceValue p f = lift1 $ NiceValue.modify p f

modifyNiceValue2 ::
   (Value val,
    NiceValue.Compose a,
    NiceValue.Decompose patternA,
    NiceValue.Decompose patternB,
    NiceValue.PatternTuple patternA ~ tupleA,
    NiceValue.PatternTuple patternB ~ tupleB) =>
   patternA ->
   patternB ->
   (Decomposed NiceValue.T patternA ->
    Decomposed NiceValue.T patternB -> a) ->
   val tupleA -> val tupleB -> val (NiceValue.Composed a)
modifyNiceValue2 pa pb f = lift2 $ NiceValue.modify2 pa pb f

modifyNiceValueM ::
   (NiceValue.Compose a,
    NiceValue.Decompose pattern,
    NiceValue.PatternTuple pattern ~ tuple) =>
   pattern ->
   (forall r.
    Decomposed NiceValue.T pattern ->
    LLVM.CodeGenFunction r a) ->
   Exp tuple -> Exp (NiceValue.Composed a)
modifyNiceValueM p f = liftM (NiceValue.modifyF p f)

modifyNiceValueM2 ::
   (NiceValue.Compose a,
    NiceValue.Decompose patternA,
    NiceValue.Decompose patternB,
    NiceValue.PatternTuple patternA ~ tupleA,
    NiceValue.PatternTuple patternB ~ tupleB) =>
   patternA ->
   patternB ->
   (forall r.
    Decomposed NiceValue.T patternA ->
    Decomposed NiceValue.T patternB ->
    LLVM.CodeGenFunction r a) ->
   Exp tupleA -> Exp tupleB -> Exp (NiceValue.Composed a)
modifyNiceValueM2 pa pb f = liftM2 (NiceValue.modifyF2 pa pb f)


class Compose nicetuple where
   type Composed nicetuple
   {- |
   A nested 'zip'.
   -}
   compose :: nicetuple -> Exp (Composed nicetuple)

class
   (Composed (Decomposed Exp pattern) ~ PatternTuple pattern) =>
      Decompose pattern where
   {- |
   Analogous to 'NiceValue.decompose'.
   -}
   decompose :: pattern -> Exp (PatternTuple pattern) -> Decomposed Exp pattern


{- |
Analogus to 'NiceValue.modify'.
-}
modify ::
   (Compose a, Decompose pattern) =>
   pattern ->
   (Decomposed Exp pattern -> a) ->
   Exp (PatternTuple pattern) -> Exp (Composed a)
modify p f = compose . f . decompose p

modify2 ::
   (Compose a, Decompose patternA, Decompose patternB) =>
   patternA ->
   patternB ->
   (Decomposed Exp patternA -> Decomposed Exp patternB -> a) ->
   Exp (PatternTuple patternA) ->
   Exp (PatternTuple patternB) -> Exp (Composed a)
modify2 pa pb f a b = compose $ f (decompose pa a) (decompose pb b)



instance Compose (Exp a) where
   type Composed (Exp a) = a
   compose = id

instance Decompose (Atom a) where
   decompose _ = id



instance Compose () where
   type Composed () = ()
   compose = cons

instance Decompose () where
   decompose _ _ = ()


instance (Compose a, Compose b) => Compose (a,b) where
   type Composed (a,b) = (Composed a, Composed b)
   compose = Tuple.uncurry zip . TupleHT.mapPair (compose, compose)

instance (Decompose pa, Decompose pb) => Decompose (pa,pb) where
   decompose (pa,pb) =
      TupleHT.mapPair (decompose pa, decompose pb) . unzip


instance (Compose a, Compose b, Compose c) => Compose (a,b,c) where
   type Composed (a,b,c) = (Composed a, Composed b, Composed c)
   compose =
      TupleHT.uncurry3 zip3 . TupleHT.mapTriple (compose, compose, compose)

instance
   (Decompose pa, Decompose pb, Decompose pc) =>
      Decompose (pa,pb,pc) where
   decompose (pa,pb,pc) =
      TupleHT.mapTriple (decompose pa, decompose pb, decompose pc) . unzip3


instance (Compose a, Compose b, Compose c, Compose d) => Compose (a,b,c,d) where
   type Composed (a,b,c,d) = (Composed a, Composed b, Composed c, Composed d)
   compose (a,b,c,d) = zip4 (compose a) (compose b) (compose c) (compose d)

instance
   (Decompose pa, Decompose pb, Decompose pc, Decompose pd) =>
      Decompose (pa,pb,pc,pd) where
   decompose (pa,pb,pc,pd) x =
      case unzip4 x of
         (a,b,c,d) ->
            (decompose pa a, decompose pb b, decompose pc c, decompose pd d)


instance (Compose tuple) => Compose (StTuple.Tuple tuple) where
   type Composed (StTuple.Tuple tuple) = StTuple.Tuple (Composed tuple)
   compose (StTuple.Tuple tup) = tuple $ compose tup

instance (Decompose p) => Decompose (StTuple.Tuple p) where
   decompose (StTuple.Tuple p) = StTuple.Tuple . decompose p . untuple


instance (Compose a) => Compose (Complex a) where
   type Composed (Complex a) = Complex (Composed a)
   compose (r:+i) = consComplex (compose r) (compose i)

instance (Decompose p) => Decompose (Complex p) where
   decompose (pr:+pi) =
      Tuple.uncurry (:+) .
      TupleHT.mapPair (decompose pr, decompose pi) . deconsComplex

{- |
You can construct complex numbers this way,
but they will not make you happy,
because the numeric operations require a RealFloat instance
that we could only provide with lots of undefined methods
(also in its superclasses).
You may either define your own arithmetic
or use the NumericPrelude type classes.
-}
consComplex :: Exp a -> Exp a -> Exp (Complex a)
consComplex = lift2 NiceValue.consComplex

deconsComplex :: Exp (Complex a) -> (Exp a, Exp a)
deconsComplex c = (lift1 NiceValue.realPart c, lift1 NiceValue.imagPart c)


class (NiceValuesOf exp ~ nv, ExpressionsOf nv ~ exp) => Aggregate exp nv where
   type NiceValuesOf exp
   type ExpressionsOf nv
   bundle :: exp -> LLVM.CodeGenFunction r nv
   dissect :: nv -> exp

instance Aggregate (Exp a) (NiceValue.T a) where
   type NiceValuesOf (Exp a) = NiceValue.T a
   type ExpressionsOf (NiceValue.T a) = Exp a
   bundle (Exp x) = x
   dissect x = Exp (return x)

instance (Aggregate ae al, Aggregate be bl) => Aggregate (ae,be) (al,bl) where
   type NiceValuesOf (ae,be) = (NiceValuesOf ae, NiceValuesOf be)
   type ExpressionsOf (al,bl) = (ExpressionsOf al, ExpressionsOf bl)
   bundle (a,b) = Monad.lift2 (,) (bundle a) (bundle b)
   dissect (a,b) = (dissect a, dissect b)

instance
   (Aggregate ae al, Aggregate be bl, Aggregate ce cl) =>
      Aggregate (ae,be,ce) (al,bl,cl) where
   type NiceValuesOf (ae,be,ce) =
            (NiceValuesOf ae, NiceValuesOf be, NiceValuesOf ce)
   type ExpressionsOf (al,bl,cl) =
            (ExpressionsOf al, ExpressionsOf bl, ExpressionsOf cl)
   bundle (a,b,c) = Monad.lift3 (,,) (bundle a) (bundle b) (bundle c)
   dissect (a,b,c) = (dissect a, dissect b, dissect c)

instance
   (Aggregate ae al, Aggregate be bl, Aggregate ce cl, Aggregate de dl) =>
      Aggregate (ae,be,ce,de) (al,bl,cl,dl) where
   type NiceValuesOf (ae,be,ce,de) =
            (NiceValuesOf ae, NiceValuesOf be,
             NiceValuesOf ce, NiceValuesOf de)
   type ExpressionsOf (al,bl,cl,dl) =
            (ExpressionsOf al, ExpressionsOf bl,
             ExpressionsOf cl, ExpressionsOf dl)
   bundle (a,b,c,d) =
      Monad.lift4 (,,,) (bundle a) (bundle b) (bundle c) (bundle d)
   dissect (a,b,c,d) = (dissect a, dissect b, dissect c, dissect d)

instance (Aggregate ae al) => Aggregate (Complex.T ae) (Complex.T al) where
   type NiceValuesOf (Complex.T ae) = Complex.T (NiceValuesOf ae)
   type ExpressionsOf (Complex.T al) = Complex.T (ExpressionsOf al)
   dissect = fmap dissect
   bundle c =
      Monad.lift2 (Complex.+:)
         (bundle $ Complex.real c) (bundle $ Complex.imag c)


-- ToDo: move to numericprelude?
newtype Scalar a = Scalar a

instance (Aggregate exp nv) => Aggregate (Scalar exp) (Scalar.T nv) where
   type NiceValuesOf (Scalar exp) = Scalar.T (NiceValuesOf exp)
   type ExpressionsOf (Scalar.T nv)  = Scalar (ExpressionsOf nv)
   bundle (Scalar x) = Scalar.Cons <$> bundle x
   dissect (Scalar.Cons x) = Scalar $ dissect x

instance (Additive.C a) => Additive.C (Scalar a) where
   zero = Scalar Additive.zero
   Scalar a + Scalar b = Scalar (a Additive.+ b)
   Scalar a - Scalar b = Scalar (a Additive.- b)
   negate (Scalar a) = Scalar $ Additive.negate a

instance (Ring.C a) => Ring.C (Scalar a) where
   Scalar a * Scalar b = Scalar (a Ring.* b)
   fromInteger = Scalar . Ring.fromInteger

instance (Ring.C a, a~b) => Module.C (Scalar a) (Scalar b) where
   Scalar a *> Scalar b = Scalar (a Ring.* b)


cons :: (NiceValue.C a) => a -> Exp a
cons = lift0 . NiceValue.cons

unit :: Exp ()
unit = cons ()

zero :: (NiceValue.C a) => Exp a
zero = lift0 NiceValue.zero

add :: (NiceValue.Additive a) => Exp a -> Exp a -> Exp a
add = liftM2 NiceValue.add

sub :: (NiceValue.Additive a) => Exp a -> Exp a -> Exp a
sub = liftM2 NiceValue.sub

neg :: (NiceValue.Additive a) => Exp a -> Exp a
neg = liftM NiceValue.neg

one :: (NiceValue.IntegerConstant a) => Exp a
one = fromInteger' 1

mul :: (NiceValue.PseudoRing a) => Exp a -> Exp a -> Exp a
mul = liftM2 NiceValue.mul

sqr :: (NiceValue.PseudoRing a) => Exp a -> Exp a
sqr = liftM $ \x -> NiceValue.mul x x

recip :: (NiceValue.Field a, NiceValue.IntegerConstant a) => Exp a -> Exp a
recip = fdiv one

fdiv :: (NiceValue.Field a) => Exp a -> Exp a -> Exp a
fdiv = liftM2 NiceValue.fdiv

sqrt :: (NiceValue.Algebraic a) => Exp a -> Exp a
sqrt = liftM NiceValue.sqrt

pow :: (NiceValue.Transcendental a) => Exp a -> Exp a -> Exp a
pow = liftM2 NiceValue.pow

idiv :: (NiceValue.Integral a) => Exp a -> Exp a -> Exp a
idiv = liftM2 NiceValue.idiv

irem :: (NiceValue.Integral a) => Exp a -> Exp a -> Exp a
irem = liftM2 NiceValue.irem

shl :: (NiceValue.BitShift a) => Exp a -> Exp a -> Exp a
shl = liftM2 NiceValue.shl

shr :: (NiceValue.BitShift a) => Exp a -> Exp a -> Exp a
shr = liftM2 NiceValue.shr

fromInteger' :: (NiceValue.IntegerConstant a) => Integer -> Exp a
fromInteger' = lift0 . NiceValue.fromInteger'

fromRational' :: (NiceValue.RationalConstant a) => Rational -> Exp a
fromRational' = lift0 . NiceValue.fromRational'


boolPFrom8 :: Exp Bool8 -> Exp Bool
boolPFrom8 = lift1 NiceValue.boolPFrom8

bool8FromP :: Exp Bool -> Exp Bool8
bool8FromP = lift1 NiceValue.bool8FromP

intFromBool8 :: (NiceValue.NativeInteger i ir) => Exp Bool8 -> Exp i
intFromBool8 = liftM NiceValue.intFromBool8

floatFromBool8 :: (NiceValue.NativeFloating a ar) => Exp Bool8 -> Exp a
floatFromBool8 = liftM NiceValue.floatFromBool8


toEnum ::
   (NiceValue.Repr w ~ LLVM.Value w) =>
   Exp w -> Exp (Enum.T w e)
toEnum = lift1 NiceValue.toEnum

fromEnum ::
   (NiceValue.Repr w ~ LLVM.Value w) =>
   Exp (Enum.T w e) -> Exp w
fromEnum = lift1 NiceValue.fromEnum

succ, pred ::
   (LLVM.IsArithmetic w, SoV.IntegerConstant w) =>
   Exp (Enum.T w e) -> Exp (Enum.T w e)
succ = liftM NiceValue.succ
pred = liftM NiceValue.pred


fromFastMath :: Exp (FastMath.Number flags a) -> Exp a
fromFastMath = lift1 FastMath.nvDenumber

toFastMath :: Exp a -> Exp (FastMath.Number flags a)
toFastMath = lift1 FastMath.nvNumber


minBound, maxBound :: (NiceValue.Bounded a) => Exp a
minBound = lift0 NiceValue.minBound
maxBound = lift0 NiceValue.maxBound


cmp ::
   (NiceValue.Comparison a) =>
   LLVM.CmpPredicate -> Exp a -> Exp a -> Exp Bool
cmp ord = liftM2 (NiceValue.cmp ord)

infix 4 ==*, /=*, <*, <=*, >*, >=*

(==*), (/=*), (<*), (>=*), (>*), (<=*) ::
   (NiceValue.Comparison a) => Exp a -> Exp a -> Exp Bool
(==*) = cmp LLVM.CmpEQ
(/=*) = cmp LLVM.CmpNE
(<*)  = cmp LLVM.CmpLT
(>=*) = cmp LLVM.CmpGE
(>*)  = cmp LLVM.CmpGT
(<=*) = cmp LLVM.CmpLE


min, max :: (NiceValue.Real a) => Exp a -> Exp a -> Exp a
min = liftM2 A.min
max = liftM2 A.max

limit :: (NiceValue.Real a) => (Exp a, Exp a) -> Exp a -> Exp a
limit (l,u) = max l . min u

fraction :: (NiceValue.Fraction a) => Exp a -> Exp a
fraction = liftM NiceValue.fraction


true, false :: Exp Bool
true = cons True
false = cons False

infixr 3 &&*
(&&*) :: Exp Bool -> Exp Bool -> Exp Bool
(&&*) = liftM2 NiceValue.and

infixr 2 ||*
(||*) :: Exp Bool -> Exp Bool -> Exp Bool
(||*) = liftM2 NiceValue.or

not :: Exp Bool -> Exp Bool
not = liftM NiceValue.inv

{- |
Like 'ifThenElse' but computes both alternative expressions
and then uses LLVM's efficient @select@ instruction.
-}
select :: (NiceValue.Select a) => Exp Bool -> Exp a -> Exp a -> Exp a
select = liftM3 NiceValue.select

ifThenElse :: (NiceValue.C a) => Exp Bool -> Exp a -> Exp a -> Exp a
ifThenElse ec ex ey =
   unique (do
      NiceValue.Cons c <- unExp ec
      C.ifThenElse c (unExp ex) (unExp ey))


complement :: (NiceValue.Logic a) => Exp a -> Exp a
complement = liftM NiceValue.inv

infixl 7 .&.*
(.&.*) :: (NiceValue.Logic a) => Exp a -> Exp a -> Exp a
(.&.*) = liftM2 NiceValue.and

infixl 5 .|.*
(.|.*) :: (NiceValue.Logic a) => Exp a -> Exp a -> Exp a
(.|.*) = liftM2 NiceValue.or

infixl 6 `xor`
xor :: (NiceValue.Logic a) => Exp a -> Exp a -> Exp a
xor = liftM2 NiceValue.xor


toMaybe :: Exp Bool -> Exp a -> Exp (Maybe a)
toMaybe = lift2 NiceValue.toMaybe

maybe :: (NiceValue.C b) => Exp b -> (Exp a -> Exp b) -> Exp (Maybe a) -> Exp b
maybe n j = liftM $ \m -> do
   let (NiceValue.Cons b, a) = NiceValue.splitMaybe m
   C.ifThenElse b (unliftM1 j a) (unExp n)


instance
   (NiceValue.PseudoRing a, NiceValue.Real a, NiceValue.IntegerConstant a) =>
      Num (Exp a) where
   fromInteger = fromInteger'
   (+) = add
   (-) = sub
   negate = neg
   (*) = mul
   abs = liftM NiceValue.abs
   signum = liftM NiceValue.signum

instance
   (NiceValue.Field a, NiceValue.Real a, NiceValue.RationalConstant a) =>
      Fractional (Exp a) where
   fromRational = fromRational'
   (/) = fdiv

instance
   (NiceValue.Transcendental a, NiceValue.Real a,
    NiceValue.RationalConstant a) =>
      Floating (Exp a) where
   pi = unique NiceValue.pi
   sin = liftM NiceValue.sin
   cos = liftM NiceValue.cos
   sqrt = sqrt
   (**) = pow
   exp = liftM NiceValue.exp
   log = liftM NiceValue.log

   asin _ = error "LLVM missing intrinsic: asin"
   acos _ = error "LLVM missing intrinsic: acos"
   atan _ = error "LLVM missing intrinsic: atan"

   sinh x  = (exp x - exp (-x)) / 2
   cosh x  = (exp x + exp (-x)) / 2
   asinh x = log (x + sqrt (x*x + 1))
   acosh x = log (x + sqrt (x*x - 1))
   atanh x = (log (1 + x) - log (1 - x)) / 2


{- |
We do not require a numeric prelude superclass,
thus also LLVM only types like vectors are instances.
-}
instance (NiceValue.Additive a) => Additive.C (Exp a) where
   zero = zero
   (+) = add
   (-) = sub
   negate = neg

instance
   (NiceValue.PseudoRing a, NiceValue.IntegerConstant a) =>
      Ring.C (Exp a) where
   one = one
   (*) = mul
   fromInteger = fromInteger'

{-
This instance is enough for Module here.
The difference to Module instances on Haskell tuples is,
that LLVM vectors cannot be nested.
-}
instance
   (a ~ NiceValue.Scalar v,
    NiceValue.PseudoModule v, NiceValue.IntegerConstant a) =>
      Module.C (Exp a) (Exp v) where
   (*>) = liftM2 NiceValue.scale

instance
   (NiceValue.Field a, NiceValue.RationalConstant a) =>
      Field.C (Exp a) where
   (/) = fdiv
   fromRational' = fromRational' . Field.fromRational'

instance
   (NiceValue.Transcendental a, NiceValue.RationalConstant a) =>
      Algebraic.C (Exp a) where
   sqrt = sqrt
   root n x = pow x (recip $ fromInteger' n)
   x^/r = pow x (Field.fromRational' r)


tau :: (NiceValue.Transcendental a, NiceValue.RationalConstant a) => Exp a
tau = mul (fromInteger' 2) Trans.pi

instance
   (NiceValue.Transcendental a, NiceValue.RationalConstant a) =>
      Trans.C (Exp a) where
   pi = unique NiceValue.pi
   sin = liftM NiceValue.sin
   cos = liftM NiceValue.cos
   (**) = pow
   exp = liftM NiceValue.exp
   log = liftM NiceValue.log

   asin _ = error "LLVM missing intrinsic: asin"
   acos _ = error "LLVM missing intrinsic: acos"
   atan _ = error "LLVM missing intrinsic: atan"


instance
   (NiceValue.Real a, NiceValue.PseudoRing a, NiceValue.IntegerConstant a) =>
      Absolute.C (Exp a) where
   abs = liftM NiceValue.abs
   signum = liftM NiceValue.signum


fromIntegral ::
   (NiceValue.NativeInteger i ir, NiceValue.NativeFloating a ar) =>
   Exp i -> Exp a
fromIntegral = liftM NiceValue.fromIntegral

truncateToInt ::
   (NiceValue.NativeInteger i ir, NiceValue.NativeFloating a ar) =>
   Exp a -> Exp i
truncateToInt = liftM NiceValue.truncateToInt

floorToInt ::
   (NiceValue.NativeInteger i ir, NiceValue.NativeFloating a ar) =>
   Exp a -> Exp i
floorToInt = liftM NiceValue.floorToInt

ceilingToInt ::
   (NiceValue.NativeInteger i ir, NiceValue.NativeFloating a ar) =>
   Exp a -> Exp i
ceilingToInt = liftM NiceValue.ceilingToInt

roundToIntFast ::
   (NiceValue.NativeInteger i ir, NiceValue.NativeFloating a ar) =>
   Exp a -> Exp i
roundToIntFast = liftM NiceValue.roundToIntFast

splitFractionToInt ::
   (NiceValue.NativeInteger i ir, NiceValue.NativeFloating a ar) =>
   Exp a -> (Exp i, Exp a)
splitFractionToInt = unzip . liftM NiceValue.splitFractionToInt