{-# LANGUAGE
  MultiParamTypeClasses
  #-}
module LLVM.Internal.Metadata where

import LLVM.Prelude

import Control.Monad.State hiding (mapM, forM)
import Control.Monad.AnyCont

import Foreign.Ptr

import qualified Foreign.Marshal.Array as FMA
import qualified Data.Array as Array

import qualified LLVM.Internal.FFI.LLVMCTypes as FFI
import qualified LLVM.Internal.FFI.Metadata as FFI
import qualified LLVM.Internal.FFI.PtrHierarchy as FFI

import LLVM.Internal.Context
import LLVM.Internal.Coding
import LLVM.Internal.EncodeAST
import LLVM.Internal.DecodeAST
import LLVM.Internal.Value ()

import Foreign.C

instance EncodeM EncodeAST ShortByteString FFI.MDKindID where
  encodeM :: ShortByteString -> EncodeAST MDKindID
encodeM s :: ShortByteString
s = 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, CUInt)
s <- ShortByteString -> EncodeAST (Ptr CChar, CUInt)
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM ShortByteString
s
    IO MDKindID -> EncodeAST MDKindID
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO MDKindID -> EncodeAST MDKindID)
-> IO MDKindID -> EncodeAST MDKindID
forall a b. (a -> b) -> a -> b
$ Ptr Context -> (Ptr CChar, CUInt) -> IO MDKindID
FFI.getMDKindIDInContext Ptr Context
c (Ptr CChar, CUInt)
s

getMetadataKindNames :: Context -> DecodeAST ()
getMetadataKindNames :: Context -> DecodeAST ()
getMetadataKindNames (Context c :: Ptr Context
c) = DecodeAST () -> DecodeAST ()
forall (m :: * -> *) a. ScopeAnyCont m => m a -> m a
scopeAnyCont (DecodeAST () -> DecodeAST ()) -> DecodeAST () -> DecodeAST ()
forall a b. (a -> b) -> a -> b
$ do
  let g :: CUInt -> m [b]
g n :: CUInt
n = do
        Ptr (Ptr CChar)
ps <- CUInt -> m (Ptr (Ptr CChar))
forall i a (m :: * -> *).
(Integral i, Storable a, MonadAnyCont IO m) =>
i -> m (Ptr a)
allocaArray CUInt
n
        Ptr CUInt
ls <- CUInt -> m (Ptr CUInt)
forall i a (m :: * -> *).
(Integral i, Storable a, MonadAnyCont IO m) =>
i -> m (Ptr a)
allocaArray CUInt
n
        CUInt
n' <- IO CUInt -> m CUInt
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CUInt -> m CUInt) -> IO CUInt -> m CUInt
forall a b. (a -> b) -> a -> b
$ Ptr Context -> Ptr (Ptr CChar) -> Ptr CUInt -> CUInt -> IO CUInt
FFI.getMDKindNames Ptr Context
c Ptr (Ptr CChar)
ps Ptr CUInt
ls CUInt
n
        if CUInt
n' CUInt -> CUInt -> Bool
forall a. Ord a => a -> a -> Bool
> CUInt
n
         then CUInt -> m [b]
g CUInt
n'
         else do
           [(Ptr CChar, CUInt)]
csls <- ([Ptr CChar] -> [CUInt] -> [(Ptr CChar, CUInt)])
-> m ([Ptr CChar] -> [CUInt] -> [(Ptr CChar, CUInt)])
forall (m :: * -> *) a. Monad m => a -> m a
return [Ptr CChar] -> [CUInt] -> [(Ptr CChar, CUInt)]
forall a b. [a] -> [b] -> [(a, b)]
zip
                   m ([Ptr CChar] -> [CUInt] -> [(Ptr CChar, CUInt)])
-> m [Ptr CChar] -> m ([CUInt] -> [(Ptr CChar, CUInt)])
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` IO [Ptr CChar] -> m [Ptr CChar]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> Ptr (Ptr CChar) -> IO [Ptr CChar]
forall a. Storable a => Int -> Ptr a -> IO [a]
FMA.peekArray (CUInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CUInt
n') Ptr (Ptr CChar)
ps)
                   m ([CUInt] -> [(Ptr CChar, CUInt)])
-> m [CUInt] -> m [(Ptr CChar, CUInt)]
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` IO [CUInt] -> m [CUInt]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> Ptr CUInt -> IO [CUInt]
forall a. Storable a => Int -> Ptr a -> IO [a]
FMA.peekArray (CUInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CUInt
n') Ptr CUInt
ls)
           ((Ptr CChar, CUInt) -> m b) -> [(Ptr CChar, CUInt)] -> m [b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Ptr CChar, CUInt) -> m b
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM [(Ptr CChar, CUInt)]
csls
  [ShortByteString]
strs <- CUInt -> DecodeAST [ShortByteString]
forall (m :: * -> *) b.
(MonadAnyCont IO m, MonadIO m, DecodeM m b (Ptr CChar, CUInt)) =>
CUInt -> m [b]
g 16
  (DecodeState -> DecodeState) -> DecodeAST ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((DecodeState -> DecodeState) -> DecodeAST ())
-> (DecodeState -> DecodeState) -> DecodeAST ()
forall a b. (a -> b) -> a -> b
$ \s :: DecodeState
s -> DecodeState
s { metadataKinds :: Array Word ShortByteString
metadataKinds = (Word, Word) -> [ShortByteString] -> Array Word ShortByteString
forall i e. Ix i => (i, i) -> [e] -> Array i e
Array.listArray (0, Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([ShortByteString] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ShortByteString]
strs) Word -> Word -> Word
forall a. Num a => a -> a -> a
- 1) [ShortByteString]
strs }

instance DecodeM DecodeAST ShortByteString FFI.MDKindID where
  decodeM :: MDKindID -> DecodeAST ShortByteString
decodeM (FFI.MDKindID k :: CUInt
k) = (DecodeState -> ShortByteString) -> DecodeAST ShortByteString
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((DecodeState -> ShortByteString) -> DecodeAST ShortByteString)
-> (DecodeState -> ShortByteString) -> DecodeAST ShortByteString
forall a b. (a -> b) -> a -> b
$ (Array Word ShortByteString -> Word -> ShortByteString
forall i e. Ix i => Array i e -> i -> e
Array.! (CUInt -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral CUInt
k)) (Array Word ShortByteString -> ShortByteString)
-> (DecodeState -> Array Word ShortByteString)
-> DecodeState
-> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecodeState -> Array Word ShortByteString
metadataKinds

instance DecodeM DecodeAST ShortByteString (Ptr FFI.MDString) where
  -- LLVM appears to use null pts to indicate empty byte string fields
  -- including literal empty strings
  decodeM :: Ptr MDString -> DecodeAST ShortByteString
decodeM = (Ptr MDString -> Ptr CUInt -> IO (Ptr CChar))
-> Ptr MDString -> DecodeAST ShortByteString
forall a.
(Ptr a -> Ptr CUInt -> IO (Ptr CChar))
-> Ptr a -> DecodeAST ShortByteString
getByteStringFromFFI Ptr MDString -> Ptr CUInt -> IO (Ptr CChar)
FFI.getMDStringValue

getByteStringFromFFI :: (Ptr a -> Ptr CUInt -> IO CString) -> Ptr a -> DecodeAST ShortByteString
getByteStringFromFFI :: (Ptr a -> Ptr CUInt -> IO (Ptr CChar))
-> Ptr a -> DecodeAST ShortByteString
getByteStringFromFFI _ p :: Ptr a
p | Ptr a
forall a. Ptr a
nullPtr Ptr a -> Ptr a -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr a
p = ShortByteString -> DecodeAST ShortByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ShortByteString
forall a. Monoid a => a
mempty
getByteStringFromFFI f :: Ptr a -> Ptr CUInt -> IO (Ptr CChar)
f p :: Ptr a
p = do
  Ptr CUInt
np <- DecodeAST (Ptr CUInt)
forall a (m :: * -> *).
(Storable a, MonadAnyCont IO m) =>
m (Ptr a)
alloca
  Ptr CChar
s <- IO (Ptr CChar) -> DecodeAST (Ptr CChar)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr CChar) -> DecodeAST (Ptr CChar))
-> IO (Ptr CChar) -> DecodeAST (Ptr CChar)
forall a b. (a -> b) -> a -> b
$ Ptr a -> Ptr CUInt -> IO (Ptr CChar)
f Ptr a
p Ptr CUInt
np
  CUInt
n <- Ptr CUInt -> DecodeAST CUInt
forall a (m :: * -> *). (Storable a, MonadIO m) => Ptr a -> m a
peek Ptr CUInt
np
  (Ptr CChar, CUInt) -> DecodeAST ShortByteString
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM (Ptr CChar
s, CUInt
n)