Class.hs

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
module LLVM.Extra.Class where

import qualified LLVM.Extra.MaybePrivate as Maybe
import qualified LLVM.Core as LLVM
import LLVM.Core
   (Value, value, valueOf, undef,
    ConstValue,
    Vector,
    IsConst, IsType, IsFirstClass, IsPrimitive,
    CodeGenFunction, BasicBlock, )
import LLVM.Util.Loop (Phi, phis, addPhis, )
import qualified Types.Data.Num as TypeNum

import Control.Applicative (pure, liftA2, )
import qualified Control.Applicative as App
import qualified Data.Foldable as Fold
import qualified Data.Traversable as Trav

import Foreign.StablePtr (StablePtr, )
import Foreign.Ptr (Ptr, )

import Data.Word (Word8, Word16, Word32, Word64, )
import Data.Int  (Int8,  Int16,  Int32,  Int64, )

import Prelude hiding (and, iterate, map, zipWith, writeFile, )


-- * class for tuples of undefined values

class Undefined a where
   undefTuple :: a

instance Undefined () where
   undefTuple = ()

instance (IsFirstClass a) => Undefined (Value a) where
   undefTuple = value undef

instance (IsFirstClass a) => Undefined (ConstValue a) where
   undefTuple = undef

instance (Undefined a, Undefined b) => Undefined (a, b) where
   undefTuple = (undefTuple, undefTuple)

instance (Undefined a, Undefined b, Undefined c) => Undefined (a, b, c) where
   undefTuple = (undefTuple, undefTuple, undefTuple)

instance (Undefined a) => Undefined (Maybe.T a) where
   undefTuple = Maybe.Cons undefTuple undefTuple


-- * class for tuples of zero values

class Zero a where
   zeroTuple :: a

instance Zero () where
   zeroTuple = ()

instance (LLVM.IsFirstClass a) => Zero (Value a) where
   zeroTuple = LLVM.value LLVM.zero

instance (LLVM.IsFirstClass a) => Zero (ConstValue a) where
   zeroTuple = LLVM.zero

instance (Zero a, Zero b) => Zero (a, b) where
   zeroTuple = (zeroTuple, zeroTuple)

instance (Zero a, Zero b, Zero c) => Zero (a, b, c) where
   zeroTuple = (zeroTuple, zeroTuple, zeroTuple)

zeroTuplePointed ::
   (Zero a, App.Applicative f) =>
   f a
zeroTuplePointed =
   pure zeroTuple


-- * class for creating tuples of constant values

class (Undefined (ValueTuple haskellValue)) =>
      MakeValueTuple haskellValue where
   type ValueTuple haskellValue :: *
   valueTupleOf :: haskellValue -> ValueTuple haskellValue

instance (MakeValueTuple ah, MakeValueTuple bh) =>
      MakeValueTuple (ah,bh) where
   type ValueTuple (ah,bh) = (ValueTuple ah, ValueTuple bh)
   valueTupleOf ~(a,b) = (valueTupleOf a, valueTupleOf b)

instance (MakeValueTuple ah, MakeValueTuple bh, MakeValueTuple ch) =>
      MakeValueTuple (ah,bh,ch) where
   type ValueTuple (ah,bh,ch) = (ValueTuple ah, ValueTuple bh, ValueTuple ch)
   valueTupleOf ~(a,b,c) = (valueTupleOf a, valueTupleOf b, valueTupleOf c)

instance (MakeValueTuple a) => MakeValueTuple (Maybe a) where
   type ValueTuple (Maybe a) = Maybe.T (ValueTuple a)
   valueTupleOf = maybe (Maybe.nothing undefTuple) (Maybe.just . valueTupleOf)

instance MakeValueTuple Float  where type ValueTuple Float  = Value Float  ; valueTupleOf = valueOf
instance MakeValueTuple Double where type ValueTuple Double = Value Double ; valueTupleOf = valueOf
-- instance MakeValueTuple FP128  where type ValueTuple FP128  = Value FP128  ; valueTupleOf = valueOf
instance MakeValueTuple Bool   where type ValueTuple Bool   = Value Bool   ; valueTupleOf = valueOf
instance MakeValueTuple Int8   where type ValueTuple Int8   = Value Int8   ; valueTupleOf = valueOf
instance MakeValueTuple Int16  where type ValueTuple Int16  = Value Int16  ; valueTupleOf = valueOf
instance MakeValueTuple Int32  where type ValueTuple Int32  = Value Int32  ; valueTupleOf = valueOf
instance MakeValueTuple Int64  where type ValueTuple Int64  = Value Int64  ; valueTupleOf = valueOf
instance MakeValueTuple Word8  where type ValueTuple Word8  = Value Word8  ; valueTupleOf = valueOf
instance MakeValueTuple Word16 where type ValueTuple Word16 = Value Word16 ; valueTupleOf = valueOf
instance MakeValueTuple Word32 where type ValueTuple Word32 = Value Word32 ; valueTupleOf = valueOf
instance MakeValueTuple Word64 where type ValueTuple Word64 = Value Word64 ; valueTupleOf = valueOf
instance MakeValueTuple ()     where type ValueTuple ()     = ()           ; valueTupleOf = id

{-
I'm not sure about this instance.
Maybe it is better to convert the pointer target type
according to a class that maps Haskell tuples to LLVM structs.
-}
instance IsType a => MakeValueTuple (Ptr a) where
   type ValueTuple (Ptr a) = (Value (Ptr a))
   valueTupleOf = valueOf

instance MakeValueTuple (StablePtr a) where
   type ValueTuple (StablePtr a) = Value (StablePtr a)
   valueTupleOf = valueOf

{-
instance (MakeValueTuple haskellValue llvmValue, Memory llvmValue llvmStruct) =>
         MakeValueTuple (Ptr haskellValue) (Value (Ptr llvmStruct)) where
   valueTupleOf = valueOf . castStorablePtr

instance (Pos n) => MakeValueTuple (IntN n) where
   type ValueTuple (IntN n) = (Value (IntN n))
instance (Pos n) => MakeValueTuple (WordN n) where
   type ValueTuple (WordN n) = (Value (WordN n))
-}
instance (TypeNum.PositiveT n, IsPrimitive a, IsConst a) =>
         MakeValueTuple (Vector n a) where
   type ValueTuple (Vector n a) = Value (Vector n a)
   valueTupleOf = valueOf


-- * default methods for LLVM classes

{-
buildTupleTraversable ::
   (Undefined a, Trav.Traversable f, App.Applicative f) =>
   FunctionRef -> State Int (f a)
buildTupleTraversable f =
   Trav.sequence (pure (buildTuple f))
-}
{-
buildTupleTraversable ::
   (Trav.Traversable f, App.Applicative f) =>
   State Int a ->
   State Int (f a)
buildTupleTraversable build =
   Trav.sequence (pure build)
-}
{- this is the version I used
buildTupleTraversable ::
   (Monad m, Trav.Traversable f, App.Applicative f) =>
   m a ->
   m (f a)
buildTupleTraversable build =
   Trav.sequence (pure build)
-}

undefTuplePointed ::
   (Undefined a, App.Applicative f) =>
   f a
undefTuplePointed =
   pure undefTuple

valueTupleOfFunctor ::
   (MakeValueTuple h, Functor f) =>
   f h -> f (ValueTuple h)
valueTupleOfFunctor =
   fmap valueTupleOf

{-
tupleDescFoldable ::
   (IsTuple a, Fold.Foldable f) =>
   f a -> [TypeDesc]
tupleDescFoldable =
   Fold.foldMap tupleDesc
-}

phisTraversable ::
   (Phi a, Trav.Traversable f) =>
   BasicBlock -> f a -> CodeGenFunction r (f a)
phisTraversable bb x =
   Trav.mapM (phis bb) x

addPhisFoldable ::
   (Phi a, Fold.Foldable f, App.Applicative f) =>
   BasicBlock -> f a -> f a -> CodeGenFunction r ()
addPhisFoldable bb x y =
   Fold.sequence_ (liftA2 (addPhis bb) x y)