content: {-# LANGUAGE CPP, DeriveDataTypeable, EmptyDataDecls, FlexibleContexts,
    FlexibleInstances, FunctionalDependencies, IncoherentInstances,
    MultiParamTypeClasses, ScopedTypeVariables, TypeOperators,
    TypeSynonymInstances, UndecidableInstances #-}
  -- |The LLVM type system is captured with a number of Haskell type classes.
  -- In general, an LLVM type @T@ is represented as @Value T@, where @T@ is some Haskell type.
  -- The various types @T@ are classified by various type classes, e.g., 'IsFirstClass' for
  -- those types that are LLVM first class types (passable as arguments etc).
  -- All valid LLVM types belong to the 'IsType' class.
  module LLVM.Core.Type(
      -- * Type classifier
      IsType(..),
      -- * StructFields classifier
      StructFields,
      -- ** Special type classifiers
      Nat,
      Pos,
      IsArithmetic(arithmeticType),
      ArithmeticType(IntegerType,FloatingType),
      IsInteger,
      IsIntegerOrPointer,
      IsFloating,
      IsPrimitive,
      IsFirstClass,
      IsSized,
      IsFunction,
      -- ** Others
      NumberOfElements,
      UnknownSize, -- needed for arrays of structs
      -- ** Structs
      (:&), (&),
      -- ** Type tests
      TypeDesc(..),
      isFloating,
      isSigned,
      typeRef,
      typeName,
      typeDesc2,
      VarArgs, CastVarArgs,
      ) where
  import Data.Data
  import Data.List(intercalate)
  import Data.Int
  import Data.Word
  import Data.TypeLevel hiding (Bool, Eq)
  import Foreign.StablePtr (StablePtr, )
  import LLVM.Core.Util(functionType, structType)
  import LLVM.Core.Data
  import qualified LLVM.FFI.Core as FFI
  
  #include "MachDeps.h"
  
  -- TODO:
  -- Move IntN, WordN to a special module that implements those types
  --   properly in Haskell.
  -- Also more Array and Vector to a Haskell module to implement them.
  -- Add Label?
  -- Add structures (using tuples, maybe nested).
  
  -- |The 'IsType' class classifies all types that have an LLVM representation.
  class IsType a where
      typeDesc :: a -> TypeDesc
  
  typeRef :: (IsType a) => a -> FFI.TypeRef  -- ^The argument is never evaluated
  typeRef = code . typeDesc
    where code TDFloat  = FFI.floatType
          code TDDouble = FFI.doubleType
          code TDFP128  = FFI.fp128Type
          code TDVoid   = FFI.voidType
          code (TDInt _ n)  = FFI.integerType (fromInteger n)
          code (TDArray n a) = FFI.arrayType (code a) (fromInteger n)
          code (TDVector n a) = FFI.vectorType (code a) (fromInteger n)
          code (TDPtr a) = FFI.pointerType (code a) 0
          code (TDFunction va as b) = functionType va (code b) (map code as)
          code TDLabel = FFI.labelType
          code (TDStruct ts packed) = structType (map code ts) packed
          code TDInvalidType = error "typeRef TDInvalidType"
  
  typeName :: (IsType a) => a -> String
  typeName = code . typeDesc
    where code TDFloat  = "f32"
          code TDDouble = "f64"
          code TDFP128  = "f128"
          code TDVoid   = "void"
          code (TDInt _ n)  = "i" ++ show n
          code (TDArray n a) = "[" ++ show n ++ " x " ++ code a ++ "]"
          code (TDVector n a) = "<" ++ show n ++ " x " ++ code a ++ ">"
          code (TDPtr a) = code a ++ "*"
          code (TDFunction _ as b) = code b ++ "(" ++ intercalate "," (map code as) ++ ")"
          code TDLabel = "label"
          code (TDStruct as packed) = (if packed then "<{" else "{") ++
                                      intercalate "," (map code as) ++
                                      (if packed then "}>" else "}")
          code TDInvalidType = error "typeName TDInvalidType"
  
  typeDesc2 :: FFI.TypeRef -> IO TypeDesc
  typeDesc2 t = do
      tk <- FFI.getTypeKind t
      case tk of
        FFI.VoidTypeKind -> return TDVoid
        FFI.FloatTypeKind -> return TDFloat
        FFI.DoubleTypeKind -> return TDDouble
        -- FIXME: FFI.X86_FP80TypeKind -> return "X86_FP80"
        FFI.FP128TypeKind -> return TDFP128
        -- FIXME: FFI.PPC_FP128TypeKind -> return "PPC_FP128"
        FFI.LabelTypeKind -> return TDLabel
        FFI.IntegerTypeKind -> do
                  n <- FFI.getIntTypeWidth t
                  return $ TDInt False (fromIntegral n)
        -- FIXME: FFI.FunctionTypeKind
        -- FIXME: FFI.StructTypeKind -> return "(Struct ...)"
        FFI.ArrayTypeKind -> do
                  n <- FFI.getArrayLength t
                  et <- FFI.getElementType t
                  etd <- typeDesc2 et
                  return $ TDArray (fromIntegral n) etd
        FFI.PointerTypeKind -> do
                  et <- FFI.getElementType t
                  etd <- typeDesc2 et
                  return $ TDPtr etd
        -- FIXME: FFI.OpaqueTypeKind -> return "Opaque"
        FFI.VectorTypeKind -> do
                  n <- FFI.getVectorSize t
                  et <- FFI.getElementType t
                  etd <- typeDesc2 et
                  return $ TDVector (fromIntegral n) etd
        -- FIXME: LLVMMetadataTypeKind,    /**< Metadata */
        -- FIXME: LLVMX86_MMXTypeKind      /**< X86 MMX */
        _ -> return TDInvalidType
  
  -- |Type descriptor, used to convey type information through the LLVM API.
  data TypeDesc = TDFloat | TDDouble | TDFP128 | TDVoid | TDInt Bool Integer
                | TDArray Integer TypeDesc | TDVector Integer TypeDesc
                | TDPtr TypeDesc | TDFunction Bool [TypeDesc] TypeDesc | TDLabel
                | TDStruct [TypeDesc] Bool | TDInvalidType
      deriving (Eq, Ord, Show, Typeable, Data)
  
  -- XXX isFloating and typeName could be extracted from typeRef
  -- Usage:
  --   superclass of IsConst
  --   add, sub, mul, neg context
  --   used to get type name to call intrinsic
  -- |Arithmetic types, i.e., integral and floating types.
  class IsFirstClass a => IsArithmetic a where
      arithmeticType :: ArithmeticType a
  
  data ArithmeticType a = IntegerType | FloatingType
  
  instance Functor ArithmeticType where
      fmap _ IntegerType  = IntegerType
      fmap _ FloatingType = FloatingType
  
  -- Usage:
  --  constI, allOnes
  --  many instructions.  XXX some need vector
  --  used to find signedness in Arithmetic
  -- |Integral types.
  class (IsArithmetic a, IsIntegerOrPointer a) => IsInteger a
  
  -- Usage:
  --  icmp
  -- |Integral or pointer type.
  class IsIntegerOrPointer a
  
  isSigned :: (IsInteger a) => a -> Bool
  isSigned = is . typeDesc
    where is (TDInt s _) = s
          is (TDVector _ a) = is a
          is _ = error "isSigned got impossible input"
  
  -- Usage:
  --  constF
  --  many instructions
  -- |Floating types.
  class IsArithmetic a => IsFloating a
  
  isFloating :: (IsArithmetic a) => a -> Bool
  isFloating = is . typeDesc
    where is TDFloat = True
          is TDDouble = True
          is TDFP128 = True
          is (TDVector _ a) = is a
          is _ = False
  
  -- Usage:
  --  Precondition for Vector
  -- |Primitive types.
  class (NumberOfElements D1 a) => IsPrimitive a
  
  -- |Number of elements for instructions that handle both primitive and vector types
  class (IsType a) => NumberOfElements n a | a -> n
  
  
  -- Usage:
  --  Precondition for function args and result.
  --  Used by some instructions, like ret and phi.
  --  XXX IsSized as precondition?
  -- |First class types, i.e., the types that can be passed as arguments, etc.
  class IsType a => IsFirstClass a
  
  -- Usage:
  --  Context for Array being a type
  --  thus, allocation instructions
  -- |Types with a fixed size.
  class (IsType a, Pos s) => IsSized a s | a -> s
  
  -- |Function type.
  class (IsType a) => IsFunction a where
      funcType :: [TypeDesc] -> a -> TypeDesc
  
  -- Only make instances for types that make sense in Haskell
  -- (i.e., some floating types are excluded).
  
  -- Floating point types.
  instance IsType Float  where typeDesc _ = TDFloat
  instance IsType Double where typeDesc _ = TDDouble
  instance IsType FP128  where typeDesc _ = TDFP128
  
  -- Void type
  instance IsType ()     where typeDesc _ = TDVoid
  
  -- Label type
  instance IsType Label  where typeDesc _ = TDLabel
  
  -- Variable size integer types
  instance (Pos n) => IsType (IntN n)
      where typeDesc _ = TDInt True  (toNum (undefined :: n))
  
  instance (Pos n) => IsType (WordN n)
      where typeDesc _ = TDInt False (toNum (undefined :: n))
  
  -- Fixed size integer types.
  instance IsType Bool   where typeDesc _ = TDInt False  1
  instance IsType Word8  where typeDesc _ = TDInt False  8
  instance IsType Word16 where typeDesc _ = TDInt False 16
  instance IsType Word32 where typeDesc _ = TDInt False 32
  instance IsType Word64 where typeDesc _ = TDInt False 64
  instance IsType Int8   where typeDesc _ = TDInt True   8
  instance IsType Int16  where typeDesc _ = TDInt True  16
  instance IsType Int32  where typeDesc _ = TDInt True  32
  instance IsType Int64  where typeDesc _ = TDInt True  64
  
  -- Sequence types
  instance (Nat n, IsSized a s) => IsType (Array n a)
      where typeDesc _ = TDArray (toNum (undefined :: n))
                                 (typeDesc (undefined :: a))
  instance (Pos n, IsPrimitive a) => IsType (Vector n a)
      where typeDesc _ = TDVector (toNum (undefined :: n))
                                  (typeDesc (undefined :: a))
  
  -- Pointer type.
  instance (IsType a) => IsType (Ptr a) where
      typeDesc _ = TDPtr (typeDesc (undefined :: a))
  
  instance IsType (StablePtr a) where
      typeDesc _ = TDPtr (typeDesc (undefined :: Int8))
  {-
      typeDesc _ = TDPtr TDVoid
  
  List: Type.cpp:1311: static llvm::PointerType* llvm::PointerType::get(const llvm::Type*, unsigned int): Assertion `ValueType != Type::VoidTy && "Pointer to void is not valid, use sbyte* instead!"' failed.
  -}
  
  
  -- Functions.
  instance (IsFirstClass a, IsFunction b) => IsType (a->b) where
      typeDesc = funcType []
  
  -- Function base type, always IO.
  instance (IsFirstClass a) => IsType (IO a) where
      typeDesc = funcType []
  
  -- Struct types, basically a list of component types.
  instance (StructFields a) => IsType (Struct a) where
      typeDesc ~(Struct a) = TDStruct (fieldTypes a) False
  
  instance (StructFields a) => IsType (PackedStruct a) where
      typeDesc ~(PackedStruct a) = TDStruct (fieldTypes a) True
  
  -- Use a nested tuples for struct fields.
  class StructFields as where
      fieldTypes :: as -> [TypeDesc]
  
  instance (IsSized a sa, StructFields as) => StructFields (a :& as) where
      fieldTypes ~(a, as) = typeDesc a : fieldTypes as
  instance StructFields () where
      fieldTypes _ = []
  
  -- An alias for pairs to make structs look nicer
  infixr :&
  type (:&) a as = (a, as)
  infixr &
  (&) :: a -> as -> a :& as
  a & as = (a, as)
  
  --- Instances to classify types
  instance IsArithmetic Float  where arithmeticType = FloatingType
  instance IsArithmetic Double where arithmeticType = FloatingType
  instance IsArithmetic FP128  where arithmeticType = FloatingType
  instance (Pos n) => IsArithmetic (IntN n)  where arithmeticType = IntegerType
  instance (Pos n) => IsArithmetic (WordN n) where arithmeticType = IntegerType
  instance IsArithmetic Bool   where arithmeticType = IntegerType
  instance IsArithmetic Int8   where arithmeticType = IntegerType
  instance IsArithmetic Int16  where arithmeticType = IntegerType
  instance IsArithmetic Int32  where arithmeticType = IntegerType
  instance IsArithmetic Int64  where arithmeticType = IntegerType
  instance IsArithmetic Word8  where arithmeticType = IntegerType
  instance IsArithmetic Word16 where arithmeticType = IntegerType
  instance IsArithmetic Word32 where arithmeticType = IntegerType
  instance IsArithmetic Word64 where arithmeticType = IntegerType
  instance (Pos n, IsPrimitive a, IsArithmetic a) =>
           IsArithmetic (Vector n a) where
     arithmeticType = fmap (undefined :: a -> Vector n a) arithmeticType
  
  instance IsFloating Float
  instance IsFloating Double
  instance IsFloating FP128
  instance (Pos n, IsPrimitive a, IsFloating a) => IsFloating (Vector n a)
  
  instance (Pos n) => IsInteger (IntN n)
  instance (Pos n) => IsInteger (WordN n)
  instance IsInteger Bool
  instance IsInteger Int8
  instance IsInteger Int16
  instance IsInteger Int32
  instance IsInteger Int64
  instance IsInteger Word8
  instance IsInteger Word16
  instance IsInteger Word32
  instance IsInteger Word64
  instance (Pos n, IsPrimitive a, IsInteger a) => IsInteger (Vector n a)
  
  instance (Pos n) => IsIntegerOrPointer (IntN n)
  instance (Pos n) => IsIntegerOrPointer (WordN n)
  instance IsIntegerOrPointer Bool
  instance IsIntegerOrPointer Int8
  instance IsIntegerOrPointer Int16
  instance IsIntegerOrPointer Int32
  instance IsIntegerOrPointer Int64
  instance IsIntegerOrPointer Word8
  instance IsIntegerOrPointer Word16
  instance IsIntegerOrPointer Word32
  instance IsIntegerOrPointer Word64
  instance (Pos n, IsPrimitive a, IsInteger a) => IsIntegerOrPointer (Vector n a)
  instance (IsType a) => IsIntegerOrPointer (Ptr a)
  
  instance IsFirstClass Float
  instance IsFirstClass Double
  instance IsFirstClass FP128
  instance (Pos n) => IsFirstClass (IntN n)
  instance (Pos n) => IsFirstClass (WordN n)
  instance IsFirstClass Bool
  instance IsFirstClass Int8
  instance IsFirstClass Int16
  instance IsFirstClass Int32
  instance IsFirstClass Int64
  instance IsFirstClass Word8
  instance IsFirstClass Word16
  instance IsFirstClass Word32
  instance IsFirstClass Word64
  instance (Pos n, IsPrimitive a) => IsFirstClass (Vector n a)
  instance (Nat n, IsType a, IsSized a s) => IsFirstClass (Array n a)
  instance (IsType a) => IsFirstClass (Ptr a)
  instance IsFirstClass (StablePtr a)
  instance IsFirstClass Label
  instance IsFirstClass () -- XXX This isn't right, but () can be returned
  instance (StructFields as) => IsFirstClass (Struct as)
  
  instance IsSized Float D32
  instance IsSized Double D64
  instance IsSized FP128 D128
  instance (Pos n) => IsSized (IntN n) n
  instance (Pos n) => IsSized (WordN n) n
  instance IsSized Bool D1
  instance IsSized Int8 D8
  instance IsSized Int16 D16
  instance IsSized Int32 D32
  instance IsSized Int64 D64
  instance IsSized Word8 D8
  instance IsSized Word16 D16
  instance IsSized Word32 D32
  instance IsSized Word64 D64
  instance (Nat n, IsSized a s, Mul n s ns, Pos ns) => IsSized (Array n a) ns
  instance (Pos n, IsPrimitive a, IsSized a s, Mul n s ns, Pos ns) => IsSized (Vector n a) ns
  instance (IsType a) => IsSized (Ptr a) PtrSize
  instance IsSized (StablePtr a) PtrSize
  -- instance IsSized Label PtrSize -- labels are not quite first classed
  -- We cannot compute the sizes statically :(
  instance (StructFields as) => IsSized (Struct as) UnknownSize
  instance (StructFields as) => IsSized (PackedStruct as) UnknownSize
  
  type UnknownSize = D99   -- XXX this is wrong!
  
  #if WORD_SIZE_IN_BITS == 32
  type PtrSize = D32
  #elif WORD_SIZE_IN_BITS == 64
  type PtrSize = D64
  #else
  #error cannot determine type of PtrSize
  #endif
  
  instance IsPrimitive Float
  instance IsPrimitive Double
  instance IsPrimitive FP128
  instance (Pos n) => IsPrimitive (IntN n)
  instance (Pos n) => IsPrimitive (WordN n)
  instance IsPrimitive Bool
  instance IsPrimitive Int8
  instance IsPrimitive Int16
  instance IsPrimitive Int32
  instance IsPrimitive Int64
  instance IsPrimitive Word8
  instance IsPrimitive Word16
  instance IsPrimitive Word32
  instance IsPrimitive Word64
  instance IsPrimitive Label
  instance IsPrimitive ()
  
  
  instance NumberOfElements D1 Float
  instance NumberOfElements D1 Double
  instance NumberOfElements D1 FP128
  instance (Pos n) => NumberOfElements D1 (IntN n)
  instance (Pos n) => NumberOfElements D1 (WordN n)
  instance NumberOfElements D1 Bool
  instance NumberOfElements D1 Int8
  instance NumberOfElements D1 Int16
  instance NumberOfElements D1 Int32
  instance NumberOfElements D1 Int64
  instance NumberOfElements D1 Word8
  instance NumberOfElements D1 Word16
  instance NumberOfElements D1 Word32
  instance NumberOfElements D1 Word64
  instance NumberOfElements D1 Label
  instance NumberOfElements D1 ()
  
  instance (Pos n, IsPrimitive a) =>
           NumberOfElements n (Vector n a)
  
  
  -- Functions.
  instance (IsFirstClass a, IsFunction b) => IsFunction (a->b) where
      funcType ts _ = funcType (typeDesc (undefined :: a) : ts) (undefined :: b)
  instance (IsFirstClass a) => IsFunction (IO a) where
      funcType ts _ = TDFunction False (reverse ts) (typeDesc (undefined :: a))
  instance (IsFirstClass a) => IsFunction (VarArgs a) where
      funcType ts _ = TDFunction True  (reverse ts) (typeDesc (undefined :: a))
  
  -- |The 'VarArgs' type is a placeholder for the real 'IO' type that
  -- can be obtained with 'castVarArgs'.
  data VarArgs a
      deriving (Typeable)
  instance IsType (VarArgs a) where
      typeDesc _ = error "typeDesc: Dummy type VarArgs used incorrectly"
  
  -- |Define what vararg types are permissible.
  class CastVarArgs a b
  instance (CastVarArgs b c) => CastVarArgs (a -> b) (a -> c)
  instance CastVarArgs (VarArgs a) (IO a)
  instance (IsFirstClass a, CastVarArgs (VarArgs b) c) => CastVarArgs (VarArgs b) (a -> c)
  
  
  
  
  -- XXX Structures not implemented.  Tuples is probably an easy way.
  
  