content: {-# LANGUAGE ViewPatterns #-}
  
  module Data.LLVM.BitCode.IR.Types (
      resolveTypeDecls
    , parseTypeBlock
    ) where
  
  import qualified Data.LLVM.BitCode.Assert as Assert
  import           Data.LLVM.BitCode.Bitstream
  import           Data.LLVM.BitCode.Match
  import           Data.LLVM.BitCode.Parse
  import           Data.LLVM.BitCode.Record
  import           Text.LLVM.AST
  
  import qualified Codec.Binary.UTF8.String as UTF8 (decode)
  import           Control.Monad (when,unless,mplus,(<=<))
  import qualified Data.IntMap as IntMap
  import           Data.List (sortBy)
  import           Data.Maybe (catMaybes)
  import           Data.Ord (comparing)
  
  
  -- Type Block ------------------------------------------------------------------
  
  -- | Pattern match the TYPE_CODE_NUMENTRY unabbreviated record.
  numEntry :: Match Entry Record
  numEntry  = hasRecordCode 1 <=< fromUnabbrev <=< unabbrev
  
  resolveTypeDecls :: Parse [TypeDecl]
  resolveTypeDecls  = do
    symtab <- getTypeSymtab
    decls  <- mapM mkTypeDecl (IntMap.toList (tsById symtab))
    return (sortBy (comparing typeName) decls)
    where
    mkTypeDecl (ix,alias) = do
      ty <- getType' ix
      return TypeDecl
        { typeName  = alias
        , typeValue = ty
        }
  
  
  -- Type Block Parsing ----------------------------------------------------------
  
  -- | Parsing the type block only modifies internal state, introducing a number
  -- of entries to the type table.
  parseTypeBlock :: [Entry] -> Parse TypeSymtab
  parseTypeBlock es = label "TYPE_BLOCK" $ do
  
    -- drop everything until we hit TYPE_CODE_NUMENTRY
    (r,ents) <- match (dropUntil numEntry) es
    setTypeTableSize =<< label "type-table size" (parseField r 0 numeric)
  
    -- verify that the type table hasn't been set already
    isEmpty <- isTypeTableEmpty
    unless isEmpty (fail "Multiple TYPE_BLOCKs found!")
  
    -- resolve the type table, and the type symbol table
    tys <- mapM parseTypeBlockEntry ents
    cxt <- getContext
    let (tt,sym) = deriveTypeTables cxt (catMaybes tys)
    setTypeTable tt
    return sym
  
  deriveTypeTables :: [String] -> [(PType,Maybe Ident)] -> (TypeTable,TypeSymtab)
  deriveTypeTables cxt tys = (tt,sym)
    where
    ixs = zip [0 ..] tys
  
    -- symbol table entries aren't very common
    sym = foldl mkSym mempty ixs
    mkSym sym' (ix,(_,mb)) = case mb of
      Nothing    -> sym'
      Just alias -> addTypeSymbol ix alias sym'
  
    -- recursively resolve the type table, if they don't already exist in the
    -- symbol table.  if the index entry doesn't exist, throw an error, as that
    -- should be impossible.
    tt = IntMap.fromList [ (ix, updateAliases resolve ty) | (ix, (ty, _)) <- ixs ]
    resolve ix = case IntMap.lookup ix (tsById sym) of
      Nothing    -> lookupTypeRef cxt ix tt
      Just ident -> Alias ident
  
  
  type PType = Type' Int
  
  type ParseType = Parse (Maybe (PType,Maybe Ident))
  
  typeRef :: Match Field PType
  typeRef  = return . Alias <=< numeric
  
  -- | Parsing the type table will only ever effect internal state.
  parseTypeBlockEntry :: Entry -> ParseType
  
  parseTypeBlockEntry (fromEntry -> Just r) = case recordCode r of
  
    1 -> label "TYPE_CODE_NUMENTRY" noType
  
    2 -> label "TYPE_CODE_VOID" (addType (PrimType Void))
  
    3 -> label "TYPE_CODE_FLOAT" (addType (PrimType (FloatType Float)))
  
    4 -> label "TYPE_CODE_DOUBLE" (addType (PrimType (FloatType Double)))
  
    5 -> label "TYPE_CODE_LABEL" (addType (PrimType Label))
  
    6 -> label "TYPE_CODE_OPAQUE" $ do
      do ident    <- getTypeName
         addTypeWithAlias Opaque ident
  
    7 -> label "TYPE_CODE_INTEGER" $ do
      let field = parseField r
      width <- field 0 numeric
      addType (PrimType (Integer width))
  
    8 -> label "TYPE_CODE_POINTER" $ do
      let field = parseField r
      ty <- field 0 typeRef
      when (length (recordFields r) == 2) $ do
        -- We do not currently store address spaces in the @llvm-pretty@ AST.
        _space <- field 1 keep
        return ()
      addType (PtrTo ty)
  
    -- [vararg, attrid, [retty, paramty x N]]
    9 -> label "TYPE_CODE_FUNCTION_OLD" $ do
      let field = parseField r
      va  <- field 0 boolean
      tys <- field 2 (fieldArray typeRef)
      case tys of
        rty:ptys -> addType (FunTy rty ptys va)
        _        -> fail "function expects a return type"
  
    10 -> label "TYPE_CODE_FP_HALF" (addType (PrimType (FloatType Half)))
  
    11 -> label "TYPE_CODE_ARRAY" $ do
      let field = parseField r
      numelts <- field 0 numeric
      eltty   <- field 1 typeRef
      addType (Array numelts eltty)
  
    12 -> label "TYPE_CODE_VECTOR" $ do
      let field = parseField r
      numelts <- field 0 numeric
      eltty   <- field 1 typeRef
      addType (Vector numelts eltty)
  
    13 -> label "TYPE_CODE_X86_FP80" (addType (PrimType (FloatType X86_fp80)))
  
    14 -> label "TYPE_CODE_FP128" (addType (PrimType (FloatType Fp128)))
  
    15 -> label "TYPE_CODE_PPC_FP128" (addType (PrimType (FloatType PPC_fp128)))
  
    16 -> label "TYPE_CODE_METADATA" (addType (PrimType Metadata))
  
    17 -> label "TYPE_CODE_X86_MMX" (addType (PrimType X86mmx))
  
    -- [ispacked, eltty x N]
    18 -> label "TYPE_CODE_STRUCT_ANON" $ do
      let field = parseField r
      ispacked <- label "is packed"     (field 0 boolean)
      tys      <- label "struct fields" (field 1 (fieldArray typeRef))
      if ispacked
         then addType (PackedStruct tys)
         else addType (Struct tys)
  
    19 -> label "TYPE_CODE_STRUCT_NAME" $ do
      name <- label "struct name" $ parseField r 0 cstring
          `mplus` fmap UTF8.decode (parseFields r 0 char)
      setTypeName name
      noType
  
    -- [ispacked, eltty x N]
    20 -> label "TYPE_CODE_STRUCT_NAMED" $ do
      let field = parseField r
  
      ident    <- getTypeName
      ispacked <- label "ispacked"      (field 0 boolean)
      tys      <- label "element types" (field 1 (fieldArray typeRef))
      if ispacked
         then addTypeWithAlias (PackedStruct tys) ident
         else addTypeWithAlias (Struct tys) ident
  
    -- [vararg, [retty, paramty x N]]
    21 -> label "TYPE_CODE_FUNCTION" $ do
      let field = parseField r
      vararg <- label "vararg"     (field 0 boolean)
      tys    <- label "parameters" (field 1 (fieldArray typeRef))
      case tys of
        rty:ptys -> addType (FunTy rty ptys vararg)
        []       -> fail "function expects a return type"
  
    22 -> label "TYPE_CODE_TOKEN" $ do
      notImplemented
  
    23 -> label "TYPE_CODE_BFLOAT" $ do
      notImplemented
  
    24 -> label "TYPE_CODE_X86_AMX" $ do
      notImplemented
  
    25 -> label "TYPE_CODE_OPAQUE_POINTER" $ do
      let field = parseField r
      when (length (recordFields r) /= 1) $
        fail "Invalid opaque pointer record"
      -- We do not currently store address spaces in the @llvm-pretty@ AST.
      _space <- field 0 keep
      addType PtrOpaque
  
    26 -> label "TYPE_CODE_TARGET_TYPE" $ do
      notImplemented
  
    code -> Assert.unknownEntity "type code " code
  
  -- skip blocks
  parseTypeBlockEntry (block -> Just _) =
    return Nothing
  
  -- skip abbrevs
  parseTypeBlockEntry (abbrevDef -> Just _) =
    return Nothing
  
  parseTypeBlockEntry e =
    fail ("type block: unexpected: " ++ show e)
  
  
  
  -- | Add a type to the type table.
  addType :: PType -> ParseType
  addType ty = return (Just (ty,Nothing))
  
  -- | Add a type and an alias to the type table
  addTypeWithAlias :: PType -> Ident -> ParseType
  addTypeWithAlias ty i = return (Just (ty,Just i))
  
  -- | Return no type for addition to the type table
  noType :: ParseType
  noType  = return Nothing
  