{-# LANGUAGE
  QuasiQuotes,
  MultiParamTypeClasses
  #-}
module LLVM.Internal.Type where

import LLVM.Prelude

import Control.Monad.AnyCont
import Control.Monad.Catch
import Control.Monad.State

import qualified Data.Map as Map
import qualified Data.Set as Set

import Foreign.Ptr

import qualified LLVM.Internal.FFI.LLVMCTypes as FFI
import LLVM.Internal.FFI.LLVMCTypes (typeKindP)
import qualified LLVM.Internal.FFI.Type as FFI
import qualified LLVM.Internal.FFI.PtrHierarchy as FFI

import qualified LLVM.AST as A
import qualified LLVM.AST.AddrSpace as A
import LLVM.Exception

import LLVM.Internal.Context
import LLVM.Internal.Coding
import LLVM.Internal.DecodeAST
import LLVM.Internal.EncodeAST

getStructure :: Ptr FFI.Type -> DecodeAST A.Type
getStructure :: Ptr Type -> DecodeAST Type
getStructure t :: Ptr Type
t = DecodeAST Type -> DecodeAST Type
forall (m :: * -> *) a. ScopeAnyCont m => m a -> m a
scopeAnyCont (DecodeAST Type -> DecodeAST Type)
-> DecodeAST Type -> DecodeAST Type
forall a b. (a -> b) -> a -> b
$ do
  (Bool -> [Type] -> Type) -> DecodeAST (Bool -> [Type] -> Type)
forall (m :: * -> *) a. Monad m => a -> m a
return Bool -> [Type] -> Type
A.StructureType
   DecodeAST (Bool -> [Type] -> Type)
-> DecodeAST Bool -> DecodeAST ([Type] -> Type)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` (LLVMBool -> DecodeAST Bool
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM (LLVMBool -> DecodeAST Bool)
-> DecodeAST LLVMBool -> DecodeAST Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO LLVMBool -> DecodeAST LLVMBool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr Type -> IO LLVMBool
FFI.isPackedStruct Ptr Type
t))
   DecodeAST ([Type] -> Type) -> DecodeAST [Type] -> DecodeAST Type
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` do
       CUInt
n <- IO CUInt -> DecodeAST CUInt
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr Type -> IO CUInt
FFI.countStructElementTypes Ptr Type
t)
       Ptr (Ptr Type)
ts <- CUInt -> DecodeAST (Ptr (Ptr Type))
forall i a (m :: * -> *).
(Integral i, Storable a, MonadAnyCont IO m) =>
i -> m (Ptr a)
allocaArray CUInt
n
       IO () -> DecodeAST ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> DecodeAST ()) -> IO () -> DecodeAST ()
forall a b. (a -> b) -> a -> b
$ Ptr Type -> Ptr (Ptr Type) -> IO ()
FFI.getStructElementTypes Ptr Type
t Ptr (Ptr Type)
ts
       (CUInt, Ptr (Ptr Type)) -> DecodeAST [Type]
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM (CUInt
n, Ptr (Ptr Type)
ts)

getStructDefinitions :: DecodeAST [A.Definition]
getStructDefinitions :: DecodeAST [Definition]
getStructDefinitions = do
  let getStructDefinition :: Ptr Type -> DecodeAST (Maybe Type)
getStructDefinition t :: Ptr Type
t = do
       Bool
opaque <- LLVMBool -> DecodeAST Bool
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM (LLVMBool -> DecodeAST Bool)
-> DecodeAST LLVMBool -> DecodeAST Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO LLVMBool -> DecodeAST LLVMBool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr Type -> IO LLVMBool
FFI.structIsOpaque Ptr Type
t)
       if Bool
opaque then Maybe Type -> DecodeAST (Maybe Type)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Type
forall a. Maybe a
Nothing else Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> DecodeAST Type -> DecodeAST (Maybe Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Type -> DecodeAST Type
getStructure Ptr Type
t
  (((Set (Ptr Type) -> DecodeAST [Definition])
  -> Set (Ptr Type) -> DecodeAST [Definition])
 -> Set (Ptr Type) -> DecodeAST [Definition])
-> Set (Ptr Type)
-> ((Set (Ptr Type) -> DecodeAST [Definition])
    -> Set (Ptr Type) -> DecodeAST [Definition])
-> DecodeAST [Definition]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Set (Ptr Type) -> DecodeAST [Definition])
 -> Set (Ptr Type) -> DecodeAST [Definition])
-> Set (Ptr Type) -> DecodeAST [Definition]
forall a. (a -> a) -> a
fix Set (Ptr Type)
forall a. Set a
Set.empty (((Set (Ptr Type) -> DecodeAST [Definition])
  -> Set (Ptr Type) -> DecodeAST [Definition])
 -> DecodeAST [Definition])
-> ((Set (Ptr Type) -> DecodeAST [Definition])
    -> Set (Ptr Type) -> DecodeAST [Definition])
-> DecodeAST [Definition]
forall a b. (a -> b) -> a -> b
$ \continue :: Set (Ptr Type) -> DecodeAST [Definition]
continue done :: Set (Ptr Type)
done -> do
    Maybe (Ptr Type)
t <- DecodeAST (Maybe (Ptr Type))
takeTypeToDefine
    ((Ptr Type -> DecodeAST [Definition])
 -> Maybe (Ptr Type) -> DecodeAST [Definition])
-> Maybe (Ptr Type)
-> (Ptr Type -> DecodeAST [Definition])
-> DecodeAST [Definition]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (DecodeAST [Definition]
-> (Ptr Type -> DecodeAST [Definition])
-> Maybe (Ptr Type)
-> DecodeAST [Definition]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Definition] -> DecodeAST [Definition]
forall (m :: * -> *) a. Monad m => a -> m a
return [])) Maybe (Ptr Type)
t ((Ptr Type -> DecodeAST [Definition]) -> DecodeAST [Definition])
-> (Ptr Type -> DecodeAST [Definition]) -> DecodeAST [Definition]
forall a b. (a -> b) -> a -> b
$ \t :: Ptr Type
t -> do
      if Ptr Type
t Ptr Type -> Set (Ptr Type) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (Ptr Type)
done
        then
          Set (Ptr Type) -> DecodeAST [Definition]
continue Set (Ptr Type)
done
        else
          (Definition -> [Definition] -> [Definition])
-> DecodeAST (Definition -> [Definition] -> [Definition])
forall (m :: * -> *) a. Monad m => a -> m a
return (:)
            DecodeAST (Definition -> [Definition] -> [Definition])
-> DecodeAST Definition -> DecodeAST ([Definition] -> [Definition])
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` ((Name -> Maybe Type -> Definition)
-> DecodeAST (Name -> Maybe Type -> Definition)
forall (m :: * -> *) a. Monad m => a -> m a
return Name -> Maybe Type -> Definition
A.TypeDefinition DecodeAST (Name -> Maybe Type -> Definition)
-> DecodeAST Name -> DecodeAST (Maybe Type -> Definition)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` Ptr Type -> DecodeAST Name
getTypeName Ptr Type
t DecodeAST (Maybe Type -> Definition)
-> DecodeAST (Maybe Type) -> DecodeAST Definition
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` Ptr Type -> DecodeAST (Maybe Type)
getStructDefinition Ptr Type
t)
            DecodeAST ([Definition] -> [Definition])
-> DecodeAST [Definition] -> DecodeAST [Definition]
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` (Set (Ptr Type) -> DecodeAST [Definition]
continue (Set (Ptr Type) -> DecodeAST [Definition])
-> Set (Ptr Type) -> DecodeAST [Definition]
forall a b. (a -> b) -> a -> b
$ Ptr Type -> Set (Ptr Type) -> Set (Ptr Type)
forall a. Ord a => a -> Set a -> Set a
Set.insert Ptr Type
t Set (Ptr Type)
done)

isArrayType :: Ptr FFI.Type -> IO Bool
isArrayType :: Ptr Type -> IO Bool
isArrayType t :: Ptr Type
t = do
  TypeKind
k <- IO TypeKind -> IO TypeKind
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TypeKind -> IO TypeKind) -> IO TypeKind -> IO TypeKind
forall a b. (a -> b) -> a -> b
$ Ptr Type -> IO TypeKind
FFI.getTypeKind Ptr Type
t
  Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TypeKind
k TypeKind -> TypeKind -> Bool
forall a. Eq a => a -> a -> Bool
== TypeKind
FFI.typeKindArray

instance Monad m => EncodeM m A.AddrSpace FFI.AddrSpace where
  encodeM :: AddrSpace -> m AddrSpace
encodeM (A.AddrSpace a :: Word32
a) = (CUInt -> AddrSpace) -> m (CUInt -> AddrSpace)
forall (m :: * -> *) a. Monad m => a -> m a
return CUInt -> AddrSpace
FFI.AddrSpace m (CUInt -> AddrSpace) -> m CUInt -> m AddrSpace
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` Word32 -> m CUInt
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Word32
a

instance Monad m => DecodeM m A.AddrSpace FFI.AddrSpace where
  decodeM :: AddrSpace -> m AddrSpace
decodeM (FFI.AddrSpace a :: CUInt
a) = (Word32 -> AddrSpace) -> m (Word32 -> AddrSpace)
forall (m :: * -> *) a. Monad m => a -> m a
return Word32 -> AddrSpace
A.AddrSpace m (Word32 -> AddrSpace) -> m Word32 -> m AddrSpace
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` CUInt -> m Word32
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM CUInt
a

instance EncodeM EncodeAST A.Type (Ptr FFI.Type) where
  encodeM :: Type -> EncodeAST (Ptr Type)
encodeM f :: Type
f = EncodeAST (Ptr Type) -> EncodeAST (Ptr Type)
forall (m :: * -> *) a. ScopeAnyCont m => m a -> m a
scopeAnyCont (EncodeAST (Ptr Type) -> EncodeAST (Ptr Type))
-> EncodeAST (Ptr Type) -> EncodeAST (Ptr Type)
forall a b. (a -> b) -> a -> b
$ do
    Context context :: Ptr Context
context <- (EncodeState -> Context) -> EncodeAST Context
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets EncodeState -> Context
encodeStateContext
    case Type
f of
      A.IntegerType bits :: Word32
bits -> do
        CUInt
bits <- Word32 -> EncodeAST CUInt
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Word32
bits
        IO (Ptr Type) -> EncodeAST (Ptr Type)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Type) -> EncodeAST (Ptr Type))
-> IO (Ptr Type) -> EncodeAST (Ptr Type)
forall a b. (a -> b) -> a -> b
$ Ptr Context -> CUInt -> IO (Ptr Type)
FFI.intTypeInContext Ptr Context
context CUInt
bits
      A.FunctionType returnTypeAST :: Type
returnTypeAST argTypeASTs :: [Type]
argTypeASTs isVarArg :: Bool
isVarArg -> do
        Ptr Type
returnType <- Type -> EncodeAST (Ptr Type)
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Type
returnTypeAST
        (CUInt, Ptr (Ptr Type))
argTypes <- [Type] -> EncodeAST (CUInt, Ptr (Ptr Type))
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM [Type]
argTypeASTs
        LLVMBool
isVarArg <- Bool -> EncodeAST LLVMBool
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Bool
isVarArg
        IO (Ptr Type) -> EncodeAST (Ptr Type)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Type) -> EncodeAST (Ptr Type))
-> IO (Ptr Type) -> EncodeAST (Ptr Type)
forall a b. (a -> b) -> a -> b
$ Ptr Type -> (CUInt, Ptr (Ptr Type)) -> LLVMBool -> IO (Ptr Type)
FFI.functionType Ptr Type
returnType (CUInt, Ptr (Ptr Type))
argTypes LLVMBool
isVarArg
      A.PointerType elementType :: Type
elementType addressSpace :: AddrSpace
addressSpace -> do
        Ptr Type
e <- Type -> EncodeAST (Ptr Type)
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Type
elementType
        AddrSpace
a <- AddrSpace -> EncodeAST AddrSpace
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM AddrSpace
addressSpace
        IO (Ptr Type) -> EncodeAST (Ptr Type)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Type) -> EncodeAST (Ptr Type))
-> IO (Ptr Type) -> EncodeAST (Ptr Type)
forall a b. (a -> b) -> a -> b
$ Ptr Type -> AddrSpace -> IO (Ptr Type)
FFI.pointerType Ptr Type
e AddrSpace
a
      A.VoidType -> IO (Ptr Type) -> EncodeAST (Ptr Type)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Type) -> EncodeAST (Ptr Type))
-> IO (Ptr Type) -> EncodeAST (Ptr Type)
forall a b. (a -> b) -> a -> b
$ Ptr Context -> IO (Ptr Type)
FFI.voidTypeInContext Ptr Context
context
      A.FloatingPointType A.HalfFP      -> IO (Ptr Type) -> EncodeAST (Ptr Type)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Type) -> EncodeAST (Ptr Type))
-> IO (Ptr Type) -> EncodeAST (Ptr Type)
forall a b. (a -> b) -> a -> b
$ Ptr Context -> IO (Ptr Type)
FFI.halfTypeInContext Ptr Context
context
      A.FloatingPointType A.FloatFP     -> IO (Ptr Type) -> EncodeAST (Ptr Type)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Type) -> EncodeAST (Ptr Type))
-> IO (Ptr Type) -> EncodeAST (Ptr Type)
forall a b. (a -> b) -> a -> b
$ Ptr Context -> IO (Ptr Type)
FFI.floatTypeInContext Ptr Context
context
      A.FloatingPointType A.DoubleFP    -> IO (Ptr Type) -> EncodeAST (Ptr Type)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Type) -> EncodeAST (Ptr Type))
-> IO (Ptr Type) -> EncodeAST (Ptr Type)
forall a b. (a -> b) -> a -> b
$ Ptr Context -> IO (Ptr Type)
FFI.doubleTypeInContext Ptr Context
context
      A.FloatingPointType A.X86_FP80FP  -> IO (Ptr Type) -> EncodeAST (Ptr Type)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Type) -> EncodeAST (Ptr Type))
-> IO (Ptr Type) -> EncodeAST (Ptr Type)
forall a b. (a -> b) -> a -> b
$ Ptr Context -> IO (Ptr Type)
FFI.x86FP80TypeInContext Ptr Context
context
      A.FloatingPointType A.FP128FP     -> IO (Ptr Type) -> EncodeAST (Ptr Type)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Type) -> EncodeAST (Ptr Type))
-> IO (Ptr Type) -> EncodeAST (Ptr Type)
forall a b. (a -> b) -> a -> b
$ Ptr Context -> IO (Ptr Type)
FFI.fP128TypeInContext Ptr Context
context
      A.FloatingPointType A.PPC_FP128FP -> IO (Ptr Type) -> EncodeAST (Ptr Type)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Type) -> EncodeAST (Ptr Type))
-> IO (Ptr Type) -> EncodeAST (Ptr Type)
forall a b. (a -> b) -> a -> b
$ Ptr Context -> IO (Ptr Type)
FFI.ppcFP128TypeInContext Ptr Context
context
      A.VectorType sz :: Word32
sz e :: Type
e -> do
        Ptr Type
e <- Type -> EncodeAST (Ptr Type)
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Type
e
        CUInt
sz <- Word32 -> EncodeAST CUInt
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Word32
sz
        IO (Ptr Type) -> EncodeAST (Ptr Type)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Type) -> EncodeAST (Ptr Type))
-> IO (Ptr Type) -> EncodeAST (Ptr Type)
forall a b. (a -> b) -> a -> b
$ Ptr Type -> CUInt -> IO (Ptr Type)
FFI.vectorType Ptr Type
e CUInt
sz
      A.ArrayType sz :: Word64
sz e :: Type
e -> do
        Ptr Type
e <- Type -> EncodeAST (Ptr Type)
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Type
e
        Word64
sz <- Word64 -> EncodeAST Word64
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Word64
sz
        IO (Ptr Type) -> EncodeAST (Ptr Type)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Type) -> EncodeAST (Ptr Type))
-> IO (Ptr Type) -> EncodeAST (Ptr Type)
forall a b. (a -> b) -> a -> b
$ Ptr Type -> Word64 -> IO (Ptr Type)
FFI.arrayType Ptr Type
e Word64
sz
      A.StructureType packed :: Bool
packed ets :: [Type]
ets -> do
        (CUInt, Ptr (Ptr Type))
ets <- [Type] -> EncodeAST (CUInt, Ptr (Ptr Type))
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM [Type]
ets
        LLVMBool
packed <- Bool -> EncodeAST LLVMBool
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Bool
packed
        IO (Ptr Type) -> EncodeAST (Ptr Type)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Type) -> EncodeAST (Ptr Type))
-> IO (Ptr Type) -> EncodeAST (Ptr Type)
forall a b. (a -> b) -> a -> b
$ Ptr Context -> (CUInt, Ptr (Ptr Type)) -> LLVMBool -> IO (Ptr Type)
FFI.structTypeInContext Ptr Context
context (CUInt, Ptr (Ptr Type))
ets LLVMBool
packed
      A.NamedTypeReference n :: Name
n -> Name -> EncodeAST (Ptr Type)
lookupNamedType Name
n
      A.MetadataType -> IO (Ptr Type) -> EncodeAST (Ptr Type)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Type) -> EncodeAST (Ptr Type))
-> IO (Ptr Type) -> EncodeAST (Ptr Type)
forall a b. (a -> b) -> a -> b
$ Ptr Context -> IO (Ptr Type)
FFI.metadataTypeInContext Ptr Context
context
      A.TokenType -> IO (Ptr Type) -> EncodeAST (Ptr Type)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Type) -> EncodeAST (Ptr Type))
-> IO (Ptr Type) -> EncodeAST (Ptr Type)
forall a b. (a -> b) -> a -> b
$ Ptr Context -> IO (Ptr Type)
FFI.tokenTypeInContext Ptr Context
context
      A.LabelType -> IO (Ptr Type) -> EncodeAST (Ptr Type)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Type) -> EncodeAST (Ptr Type))
-> IO (Ptr Type) -> EncodeAST (Ptr Type)
forall a b. (a -> b) -> a -> b
$ Ptr Context -> IO (Ptr Type)
FFI.labelTypeInContext Ptr Context
context

instance DecodeM DecodeAST A.Type (Ptr FFI.Type) where
  decodeM :: Ptr Type -> DecodeAST Type
decodeM t :: Ptr Type
t = DecodeAST Type -> DecodeAST Type
forall (m :: * -> *) a. ScopeAnyCont m => m a -> m a
scopeAnyCont (DecodeAST Type -> DecodeAST Type)
-> DecodeAST Type -> DecodeAST Type
forall a b. (a -> b) -> a -> b
$ do
    TypeKind
k <- IO TypeKind -> DecodeAST TypeKind
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TypeKind -> DecodeAST TypeKind)
-> IO TypeKind -> DecodeAST TypeKind
forall a b. (a -> b) -> a -> b
$ Ptr Type -> IO TypeKind
FFI.getTypeKind Ptr Type
t
    case TypeKind
k of
      [typeKindP|Void|] -> Type -> DecodeAST Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
A.VoidType
      [typeKindP|Integer|] -> Word32 -> Type
A.IntegerType (Word32 -> Type) -> DecodeAST Word32 -> DecodeAST Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CUInt -> DecodeAST Word32
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM (CUInt -> DecodeAST Word32) -> DecodeAST CUInt -> DecodeAST Word32
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO CUInt -> DecodeAST CUInt
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr Type -> IO CUInt
FFI.getIntTypeWidth Ptr Type
t))
      [typeKindP|Function|] ->
          (Type -> [Type] -> Bool -> Type)
-> DecodeAST (Type -> [Type] -> Bool -> Type)
forall (m :: * -> *) a. Monad m => a -> m a
return Type -> [Type] -> Bool -> Type
A.FunctionType
               DecodeAST (Type -> [Type] -> Bool -> Type)
-> DecodeAST Type -> DecodeAST ([Type] -> Bool -> Type)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` (Ptr Type -> DecodeAST Type
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM (Ptr Type -> DecodeAST Type)
-> DecodeAST (Ptr Type) -> DecodeAST Type
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Ptr Type) -> DecodeAST (Ptr Type)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr Type -> IO (Ptr Type)
FFI.getReturnType Ptr Type
t))
               DecodeAST ([Type] -> Bool -> Type)
-> DecodeAST [Type] -> DecodeAST (Bool -> Type)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` (do
                      CUInt
n <- IO CUInt -> DecodeAST CUInt
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr Type -> IO CUInt
FFI.countParamTypes Ptr Type
t)
                      Ptr (Ptr Type)
ts <- CUInt -> DecodeAST (Ptr (Ptr Type))
forall i a (m :: * -> *).
(Integral i, Storable a, MonadAnyCont IO m) =>
i -> m (Ptr a)
allocaArray CUInt
n
                      IO () -> DecodeAST ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> DecodeAST ()) -> IO () -> DecodeAST ()
forall a b. (a -> b) -> a -> b
$ Ptr Type -> Ptr (Ptr Type) -> IO ()
FFI.getParamTypes Ptr Type
t Ptr (Ptr Type)
ts
                      (CUInt, Ptr (Ptr Type)) -> DecodeAST [Type]
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM (CUInt
n, Ptr (Ptr Type)
ts)
                   )
               DecodeAST (Bool -> Type) -> DecodeAST Bool -> DecodeAST Type
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` (LLVMBool -> DecodeAST Bool
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM (LLVMBool -> DecodeAST Bool)
-> DecodeAST LLVMBool -> DecodeAST Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO LLVMBool -> DecodeAST LLVMBool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr Type -> IO LLVMBool
FFI.isFunctionVarArg Ptr Type
t))
      [typeKindP|Pointer|] ->
          (Type -> AddrSpace -> Type)
-> DecodeAST (Type -> AddrSpace -> Type)
forall (m :: * -> *) a. Monad m => a -> m a
return Type -> AddrSpace -> Type
A.PointerType
             DecodeAST (Type -> AddrSpace -> Type)
-> DecodeAST Type -> DecodeAST (AddrSpace -> Type)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` (Ptr Type -> DecodeAST Type
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM (Ptr Type -> DecodeAST Type)
-> DecodeAST (Ptr Type) -> DecodeAST Type
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Ptr Type) -> DecodeAST (Ptr Type)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr Type -> IO (Ptr Type)
FFI.getElementType Ptr Type
t))
             DecodeAST (AddrSpace -> Type)
-> DecodeAST AddrSpace -> DecodeAST Type
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` (AddrSpace -> DecodeAST AddrSpace
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM (AddrSpace -> DecodeAST AddrSpace)
-> DecodeAST AddrSpace -> DecodeAST AddrSpace
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO AddrSpace -> DecodeAST AddrSpace
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr Type -> IO AddrSpace
FFI.getPointerAddressSpace Ptr Type
t))
      [typeKindP|Half|]      -> Type -> DecodeAST Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> DecodeAST Type) -> Type -> DecodeAST Type
forall a b. (a -> b) -> a -> b
$ FloatingPointType -> Type
A.FloatingPointType FloatingPointType
A.HalfFP
      [typeKindP|Float|]     -> Type -> DecodeAST Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> DecodeAST Type) -> Type -> DecodeAST Type
forall a b. (a -> b) -> a -> b
$ FloatingPointType -> Type
A.FloatingPointType FloatingPointType
A.FloatFP
      [typeKindP|Double|]    -> Type -> DecodeAST Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> DecodeAST Type) -> Type -> DecodeAST Type
forall a b. (a -> b) -> a -> b
$ FloatingPointType -> Type
A.FloatingPointType FloatingPointType
A.DoubleFP
      [typeKindP|FP128|]     -> Type -> DecodeAST Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> DecodeAST Type) -> Type -> DecodeAST Type
forall a b. (a -> b) -> a -> b
$ FloatingPointType -> Type
A.FloatingPointType FloatingPointType
A.FP128FP
      [typeKindP|X86_FP80|]  -> Type -> DecodeAST Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> DecodeAST Type) -> Type -> DecodeAST Type
forall a b. (a -> b) -> a -> b
$ FloatingPointType -> Type
A.FloatingPointType FloatingPointType
A.X86_FP80FP
      [typeKindP|PPC_FP128|] -> Type -> DecodeAST Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> DecodeAST Type) -> Type -> DecodeAST Type
forall a b. (a -> b) -> a -> b
$ FloatingPointType -> Type
A.FloatingPointType FloatingPointType
A.PPC_FP128FP
      [typeKindP|Vector|] ->
        (Word32 -> Type -> Type) -> DecodeAST (Word32 -> Type -> Type)
forall (m :: * -> *) a. Monad m => a -> m a
return Word32 -> Type -> Type
A.VectorType
         DecodeAST (Word32 -> Type -> Type)
-> DecodeAST Word32 -> DecodeAST (Type -> Type)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` (CUInt -> DecodeAST Word32
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM (CUInt -> DecodeAST Word32) -> DecodeAST CUInt -> DecodeAST Word32
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO CUInt -> DecodeAST CUInt
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr Type -> IO CUInt
FFI.getVectorSize Ptr Type
t))
         DecodeAST (Type -> Type) -> DecodeAST Type -> DecodeAST Type
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` (Ptr Type -> DecodeAST Type
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM (Ptr Type -> DecodeAST Type)
-> DecodeAST (Ptr Type) -> DecodeAST Type
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Ptr Type) -> DecodeAST (Ptr Type)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr Type -> IO (Ptr Type)
FFI.getElementType Ptr Type
t))
      [typeKindP|Struct|] -> do
        let ifM :: m Bool -> m b -> m b -> m b
ifM c :: m Bool
c a :: m b
a b :: m b
b = m Bool
c m Bool -> (Bool -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \x :: Bool
x -> if Bool
x then m b
a else m b
b
        DecodeAST Bool
-> DecodeAST Type -> DecodeAST Type -> DecodeAST Type
forall (m :: * -> *) b. Monad m => m Bool -> m b -> m b -> m b
ifM (LLVMBool -> DecodeAST Bool
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM (LLVMBool -> DecodeAST Bool)
-> DecodeAST LLVMBool -> DecodeAST Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO LLVMBool -> DecodeAST LLVMBool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr Type -> IO LLVMBool
FFI.structIsLiteral Ptr Type
t))
            (Ptr Type -> DecodeAST Type
getStructure Ptr Type
t)
            (Ptr Type -> DecodeAST ()
saveNamedType Ptr Type
t DecodeAST () -> DecodeAST Type -> DecodeAST Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Name -> Type) -> DecodeAST (Name -> Type)
forall (m :: * -> *) a. Monad m => a -> m a
return Name -> Type
A.NamedTypeReference DecodeAST (Name -> Type) -> DecodeAST Name -> DecodeAST Type
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` Ptr Type -> DecodeAST Name
getTypeName Ptr Type
t)
      [typeKindP|Metadata|] -> Type -> DecodeAST Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
A.MetadataType
      [typeKindP|Array|] ->
        (Word64 -> Type -> Type) -> DecodeAST (Word64 -> Type -> Type)
forall (m :: * -> *) a. Monad m => a -> m a
return Word64 -> Type -> Type
A.ArrayType
         DecodeAST (Word64 -> Type -> Type)
-> DecodeAST Word64 -> DecodeAST (Type -> Type)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` (Word64 -> DecodeAST Word64
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM (Word64 -> DecodeAST Word64)
-> DecodeAST Word64 -> DecodeAST Word64
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Word64 -> DecodeAST Word64
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr Type -> IO Word64
FFI.getArrayLength Ptr Type
t))
         DecodeAST (Type -> Type) -> DecodeAST Type -> DecodeAST Type
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` (Ptr Type -> DecodeAST Type
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM (Ptr Type -> DecodeAST Type)
-> DecodeAST (Ptr Type) -> DecodeAST Type
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Ptr Type) -> DecodeAST (Ptr Type)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr Type -> IO (Ptr Type)
FFI.getElementType Ptr Type
t))
      [typeKindP|Token|] -> Type -> DecodeAST Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
A.TokenType
      [typeKindP|Label|] -> Type -> DecodeAST Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
A.LabelType
      _ -> [Char] -> DecodeAST Type
forall a. HasCallStack => [Char] -> a
error ([Char] -> DecodeAST Type) -> [Char] -> DecodeAST Type
forall a b. (a -> b) -> a -> b
$ "unhandled type kind " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ TypeKind -> [Char]
forall a. Show a => a -> [Char]
show TypeKind
k

createNamedType :: A.Name -> EncodeAST (Ptr FFI.Type, Maybe ShortByteString)
createNamedType :: Name -> EncodeAST (Ptr Type, Maybe ShortByteString)
createNamedType n :: Name
n = do
  Context c :: Ptr Context
c <- (EncodeState -> Context) -> EncodeAST Context
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets EncodeState -> Context
encodeStateContext
  Ptr CChar
n <- case Name
n of { A.Name n :: ShortByteString
n -> ShortByteString -> EncodeAST (Ptr CChar)
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM ShortByteString
n; _ -> Ptr CChar -> EncodeAST (Ptr CChar)
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr CChar
forall a. Ptr a
nullPtr }
  Ptr (OwnerTransfered (Ptr CChar))
renamedName <- EncodeAST (Ptr (OwnerTransfered (Ptr CChar)))
forall a (m :: * -> *).
(Storable a, MonadAnyCont IO m) =>
m (Ptr a)
alloca
  Ptr Type
t <- IO (Ptr Type) -> EncodeAST (Ptr Type)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Type) -> EncodeAST (Ptr Type))
-> IO (Ptr Type) -> EncodeAST (Ptr Type)
forall a b. (a -> b) -> a -> b
$ Ptr Context
-> Ptr CChar -> Ptr (OwnerTransfered (Ptr CChar)) -> IO (Ptr Type)
FFI.structCreateNamed Ptr Context
c Ptr CChar
n Ptr (OwnerTransfered (Ptr CChar))
renamedName
  OwnerTransfered (Ptr CChar)
p <- Ptr (OwnerTransfered (Ptr CChar))
-> EncodeAST (OwnerTransfered (Ptr CChar))
forall a (m :: * -> *). (Storable a, MonadIO m) => Ptr a -> m a
peek Ptr (OwnerTransfered (Ptr CChar))
renamedName
  if OwnerTransfered (Ptr CChar)
p OwnerTransfered (Ptr CChar) -> OwnerTransfered (Ptr CChar) -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr CChar -> OwnerTransfered (Ptr CChar)
forall a. a -> OwnerTransfered a
FFI.OwnerTransfered Ptr CChar
forall a. Ptr a
nullPtr
    then (Ptr Type, Maybe ShortByteString)
-> EncodeAST (Ptr Type, Maybe ShortByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ptr Type
t, Maybe ShortByteString
forall a. Maybe a
Nothing)
    else do
      ShortByteString
n' <- OwnerTransfered (Ptr CChar) -> EncodeAST ShortByteString
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM OwnerTransfered (Ptr CChar)
p
      (Ptr Type, Maybe ShortByteString)
-> EncodeAST (Ptr Type, Maybe ShortByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ptr Type
t, ShortByteString -> Maybe ShortByteString
forall a. a -> Maybe a
Just ShortByteString
n')

renameType :: A.Type -> EncodeAST A.Type
renameType :: Type -> EncodeAST Type
renameType A.VoidType = Type -> EncodeAST Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
A.VoidType
renameType t :: Type
t@(A.IntegerType _) = Type -> EncodeAST Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t
renameType (A.PointerType r :: Type
r a :: AddrSpace
a) = (Type -> Type) -> EncodeAST Type -> EncodeAST Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\r' :: Type
r' -> Type -> AddrSpace -> Type
A.PointerType Type
r' AddrSpace
a) (Type -> EncodeAST Type
renameType Type
r)
renameType t :: Type
t@(A.FloatingPointType _) = Type -> EncodeAST Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t
renameType (A.FunctionType r :: Type
r as :: [Type]
as varArg :: Bool
varArg) =
  (Type -> [Type] -> Type)
-> EncodeAST Type -> EncodeAST [Type] -> EncodeAST Type
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2
    (\r' :: Type
r' as' :: [Type]
as' -> Type -> [Type] -> Bool -> Type
A.FunctionType Type
r' [Type]
as' Bool
varArg)
    (Type -> EncodeAST Type
renameType Type
r)
    ((Type -> EncodeAST Type) -> [Type] -> EncodeAST [Type]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type -> EncodeAST Type
renameType [Type]
as)
renameType (A.VectorType n :: Word32
n t :: Type
t) = Word32 -> Type -> Type
A.VectorType Word32
n (Type -> Type) -> EncodeAST Type -> EncodeAST Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> EncodeAST Type
renameType Type
t
renameType (A.StructureType packed :: Bool
packed ts :: [Type]
ts) = Bool -> [Type] -> Type
A.StructureType Bool
packed ([Type] -> Type) -> EncodeAST [Type] -> EncodeAST Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> EncodeAST Type) -> [Type] -> EncodeAST [Type]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type -> EncodeAST Type
renameType [Type]
ts
renameType (A.ArrayType n :: Word64
n t :: Type
t) = Word64 -> Type -> Type
A.ArrayType Word64
n (Type -> Type) -> EncodeAST Type -> EncodeAST Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> EncodeAST Type
renameType Type
t
renameType t :: Type
t@(A.NamedTypeReference n :: Name
n) = do
  Map Name ShortByteString
renamedTypes <- (EncodeState -> Map Name ShortByteString)
-> EncodeAST (Map Name ShortByteString)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets EncodeState -> Map Name ShortByteString
encodeStateRenamedTypes
  case Name -> Map Name ShortByteString -> Maybe ShortByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n Map Name ShortByteString
renamedTypes of
    Just n' :: ShortByteString
n' -> Type -> EncodeAST Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Type
A.NamedTypeReference (ShortByteString -> Name
A.Name ShortByteString
n'))
    Nothing -> Type -> EncodeAST Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t
renameType A.MetadataType = Type -> EncodeAST Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
A.MetadataType
renameType A.LabelType = Type -> EncodeAST Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
A.LabelType
renameType A.TokenType = Type -> EncodeAST Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
A.TokenType

setNamedType :: Ptr FFI.Type -> A.Type -> EncodeAST ()
setNamedType :: Ptr Type -> Type -> EncodeAST ()
setNamedType t :: Ptr Type
t (A.StructureType packed :: Bool
packed ets :: [Type]
ets) = do
  (CUInt, Ptr (Ptr Type))
ets <- [Type] -> EncodeAST (CUInt, Ptr (Ptr Type))
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM [Type]
ets
  LLVMBool
packed <- Bool -> EncodeAST LLVMBool
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Bool
packed
  IO () -> EncodeAST ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> EncodeAST ()) -> IO () -> EncodeAST ()
forall a b. (a -> b) -> a -> b
$ Ptr Type -> (CUInt, Ptr (Ptr Type)) -> LLVMBool -> IO ()
FFI.structSetBody Ptr Type
t (CUInt, Ptr (Ptr Type))
ets LLVMBool
packed
setNamedType _ ty :: Type
ty =
  EncodeException -> EncodeAST ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM
    ([Char] -> EncodeException
EncodeException
       ("A type definition requires a structure type but got: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Show a => a -> [Char]
show Type
ty))