{-# 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 s = do
    Context c <- gets encodeStateContext
    s <- encodeM s
    liftIO $ FFI.getMDKindIDInContext c s

getMetadataKindNames :: Context -> DecodeAST ()
getMetadataKindNames (Context c) = scopeAnyCont $ do
  let g n = do
        ps <- allocaArray n
        ls <- allocaArray n
        n' <- liftIO $ FFI.getMDKindNames c ps ls n
        if n' > n
         then g n'
         else do
           csls <- return zip
                   `ap` liftIO (FMA.peekArray (fromIntegral n') ps)
                   `ap` liftIO (FMA.peekArray (fromIntegral n') ls)
           mapM decodeM csls
  strs <- g 16
  modify $ \s -> s { metadataKinds = Array.listArray (0, fromIntegral (length strs) - 1) strs }

instance DecodeM DecodeAST ShortByteString FFI.MDKindID where
  decodeM (FFI.MDKindID k) = gets $ (Array.! (fromIntegral k)) . 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 = getByteStringFromFFI FFI.getMDStringValue

getByteStringFromFFI :: (Ptr a -> Ptr CUInt -> IO CString) -> Ptr a -> DecodeAST ShortByteString
getByteStringFromFFI _ p | nullPtr == p = return mempty
getByteStringFromFFI f p = do
  np <- alloca
  s <- liftIO $ f p np
  n <- peek np
  decodeM (s, n)