{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}

module Data.LLVM.BitCode.IR where

import Data.LLVM.BitCode.Bitstream
import Data.LLVM.BitCode.BitString
import Data.LLVM.BitCode.IR.Blocks
import Data.LLVM.BitCode.IR.Module (parseModuleBlock)
import Data.LLVM.BitCode.Match
import Data.LLVM.BitCode.Parse
import Data.LLVM.BitCode.Record
import Text.LLVM.AST

import Control.Monad (unless,forM_)
import Data.Word (Word16)


-- Module Parsing --------------------------------------------------------------

-- | The magic number that identifies a @Bitstream@ structure as LLVM IR.
llvmIrMagic :: Word16
llvmIrMagic  = fromBitString (toBitString (Bits' 8) 0xc0
                              `joinBitString`
                              toBitString (Bits' 8) 0xde)

-- | Parse an LLVM Module out of a Bitstream object.
parseModule :: Bitstream -> Parse Module
parseModule Bitstream { bsAppMagic, bsEntries } = label "Bitstream" $ do
  unless (bsAppMagic == llvmIrMagic) (fail "Bitstream is not an llvm-ir")
  parseTopLevel bsEntries

findTables :: [Entry] -> Parse ()
findTables es = forM_ es $ \e ->
  case e of
    (strtabBlockId -> Just [ abbrevDef -> Just _
                           , abbrev -> Just (fromAbbrev -> Just r)
                           ]) -> do
      st <- mkStrtab <$> parseField r 0 fieldBlob
      setStringTable st
    --(symtabBlockId -> Just _) -> fail "Found symbol table."
    _ -> return ()

-- | The only top-level block that we parse currently is the module block. The
-- Identification block that's introduced in 3.8 is ignored. In the future, it
-- might be advantageous to parse it, as it could include information that would
-- aid error reporting.
parseTopLevel :: [Entry] -> Parse Module

parseTopLevel ((moduleBlockId -> Just blockEntries) : rest) = do
  findTables rest
  parseModuleBlock blockEntries

parseTopLevel (_ : rest) =
  parseTopLevel rest

parseTopLevel [] =
  fail "MODULE_BLOCK missing"