Class.hs

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

import qualified LLVM.Extra.EitherPrivate as Either
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 Type.Data.Num.Decimal as TypeNum

import qualified Control.Applicative as App
import Control.Applicative (pure, liftA2, )

import qualified Data.Foldable as Fold
import qualified Data.Traversable as Trav

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

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

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


-- * 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

instance (Undefined a, Undefined b) => Undefined (Either.T a b) where
   undefTuple = Either.Cons undefTuple 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 a, MakeValueTuple b) =>
      MakeValueTuple (Either a b) where
   type ValueTuple (Either a b) = Either.T (ValueTuple a) (ValueTuple b)
   valueTupleOf =
      either
         (Either.left undefTuple . valueTupleOf)
         (Either.right undefTuple . 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 LLVM.IsFunction a => MakeValueTuple (FunPtr a) where
   type ValueTuple (FunPtr a) = Value (FunPtr 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 . castTuplePtr

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.Positive 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)