{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- This defines data structures for parsing Dwarf debug information from
-- binaries.
module Data.Macaw.Dwarf
  ( -- * Compile units and declarations
    Data.Macaw.Memory.Endianness (..),
    Dwarf.Sections,
    Dwarf.mkSections,
    Dwarf.CUContext,
    Dwarf.CUOffset (..),
    firstCUContext,
    Dwarf.nextCUContext,
    getCompileUnit,
    dwarfCompileUnits,
    CompileUnit,
    cuRanges,
    cuSubprograms,
    lookupSubprogram,
    dwarfGlobals,

    -- ** Utility function
    dwarfInfoFromElf,

    -- * Variables
    Variable,
    varName,
    varType,
    varOrigin,

    -- * Sub programs
    Subprogram (..),
    SubprogramDef (..),

    -- * Inlineing
    SubprogramRef,
    VariableRef,

    -- * Locations
    Location (..),
    DeclLoc, -- (..)

    -- * Type information
    TypeRef,
    typeRefFileOffset,
    AbsType,
    TypeApp (..),
    StructDecl (..),
    UnionDecl (..),
    Member (..),
    EnumDecl (..),
    Enumerator, -- (..)
    SubroutineTypeDecl (..),
    Subrange (..),
    Typedef (..),
    TypeQual (..),
    TypeQualAnn (..),

    -- * Name and Description
    Name (..),
    Description (..),

    -- * Low-level access
    DwarfExpr (..),

    -- * Exports of "Data.Dwarf"
    Dwarf.DieID,
    Dwarf.DW_OP (..),
    Dwarf.Range (..),
  )
where

import Control.Lens
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
import Data.Binary.Get
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import Data.Dwarf as Dwarf hiding (Endianess (..), firstCUContext)
import qualified Data.Dwarf as Dwarf
import qualified Data.ElfEdit as Elf
import Data.Foldable
import Data.Int
import Data.List (sortOn)
import Data.Macaw.Memory (Endianness (..))
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import Data.Set (Set)
import qualified Data.Set as Set
import Data.String
import qualified Data.Vector as V
import Data.Word
import Numeric (showHex)
import Prettyprinter
import Text.Printf

hasAttribute :: DW_AT -> DIE -> Bool
hasAttribute :: DW_AT -> DIE -> Bool
hasAttribute DW_AT
a DIE
d = ((DW_AT, DW_ATVAL) -> Bool) -> [(DW_AT, DW_ATVAL)] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any (\(DW_AT, DW_ATVAL)
p -> (DW_AT, DW_ATVAL) -> DW_AT
forall a b. (a, b) -> a
fst (DW_AT, DW_ATVAL)
p DW_AT -> DW_AT -> Bool
forall a. Eq a => a -> a -> Bool
== DW_AT
a) (DIE -> [(DW_AT, DW_ATVAL)]
dieAttributes DIE
d)

------------------------------------------------------------------------
-- WarnMonad

-- A monad that allows one to collect warnings with a given type during execution.
class Monad m => WarnMonad s m | m -> s where
  -- Emit the given warning
  warn :: s -> m ()

  -- Run a computation in a context where all warnings are transformed by the given
  -- function.
  runInContext :: (s -> s) -> m r -> m r

instance WarnMonad s m => WarnMonad s (ReaderT r m) where
  warn :: s -> ReaderT r m ()
warn s
s = (r -> m ()) -> ReaderT r m ()
forall r (m :: Type -> Type) a. (r -> m a) -> ReaderT r m a
ReaderT ((r -> m ()) -> ReaderT r m ()) -> (r -> m ()) -> ReaderT r m ()
forall a b. (a -> b) -> a -> b
$ \r
_ -> s -> m ()
forall s (m :: Type -> Type). WarnMonad s m => s -> m ()
warn s
s
  runInContext :: forall r. (s -> s) -> ReaderT r m r -> ReaderT r m r
runInContext s -> s
f ReaderT r m r
m = (r -> m r) -> ReaderT r m r
forall r (m :: Type -> Type) a. (r -> m a) -> ReaderT r m a
ReaderT ((r -> m r) -> ReaderT r m r) -> (r -> m r) -> ReaderT r m r
forall a b. (a -> b) -> a -> b
$ \r
r ->
    (s -> s) -> m r -> m r
forall r. (s -> s) -> m r -> m r
forall s (m :: Type -> Type) r.
WarnMonad s m =>
(s -> s) -> m r -> m r
runInContext s -> s
f (ReaderT r m r -> r -> m r
forall r (m :: Type -> Type) a. ReaderT r m a -> r -> m a
runReaderT ReaderT r m r
m r
r)

------------------------------------------------------------------------
-- WarnT

-- | A monad transformer that adds the ability to collect a list of messages
-- (called "warnings") and throw a exception.
newtype WarnT e m r = WarnT {forall e (m :: Type -> Type) r.
WarnT e m r -> ExceptT e (StateT [e] m) r
unWarnT :: ExceptT e (StateT [e] m) r}
  deriving ((forall a b. (a -> b) -> WarnT e m a -> WarnT e m b)
-> (forall a b. a -> WarnT e m b -> WarnT e m a)
-> Functor (WarnT e m)
forall a b. a -> WarnT e m b -> WarnT e m a
forall a b. (a -> b) -> WarnT e m a -> WarnT e m b
forall e (m :: Type -> Type) a b.
Functor m =>
a -> WarnT e m b -> WarnT e m a
forall e (m :: Type -> Type) a b.
Functor m =>
(a -> b) -> WarnT e m a -> WarnT e m b
forall (f :: Type -> Type).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall e (m :: Type -> Type) a b.
Functor m =>
(a -> b) -> WarnT e m a -> WarnT e m b
fmap :: forall a b. (a -> b) -> WarnT e m a -> WarnT e m b
$c<$ :: forall e (m :: Type -> Type) a b.
Functor m =>
a -> WarnT e m b -> WarnT e m a
<$ :: forall a b. a -> WarnT e m b -> WarnT e m a
Functor, Functor (WarnT e m)
Functor (WarnT e m) =>
(forall a. a -> WarnT e m a)
-> (forall a b. WarnT e m (a -> b) -> WarnT e m a -> WarnT e m b)
-> (forall a b c.
    (a -> b -> c) -> WarnT e m a -> WarnT e m b -> WarnT e m c)
-> (forall a b. WarnT e m a -> WarnT e m b -> WarnT e m b)
-> (forall a b. WarnT e m a -> WarnT e m b -> WarnT e m a)
-> Applicative (WarnT e m)
forall a. a -> WarnT e m a
forall a b. WarnT e m a -> WarnT e m b -> WarnT e m a
forall a b. WarnT e m a -> WarnT e m b -> WarnT e m b
forall a b. WarnT e m (a -> b) -> WarnT e m a -> WarnT e m b
forall a b c.
(a -> b -> c) -> WarnT e m a -> WarnT e m b -> WarnT e m c
forall e (m :: Type -> Type). Monad m => Functor (WarnT e m)
forall e (m :: Type -> Type) a. Monad m => a -> WarnT e m a
forall e (m :: Type -> Type) a b.
Monad m =>
WarnT e m a -> WarnT e m b -> WarnT e m a
forall e (m :: Type -> Type) a b.
Monad m =>
WarnT e m a -> WarnT e m b -> WarnT e m b
forall e (m :: Type -> Type) a b.
Monad m =>
WarnT e m (a -> b) -> WarnT e m a -> WarnT e m b
forall e (m :: Type -> Type) a b c.
Monad m =>
(a -> b -> c) -> WarnT e m a -> WarnT e m b -> WarnT e m c
forall (f :: Type -> Type).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall e (m :: Type -> Type) a. Monad m => a -> WarnT e m a
pure :: forall a. a -> WarnT e m a
$c<*> :: forall e (m :: Type -> Type) a b.
Monad m =>
WarnT e m (a -> b) -> WarnT e m a -> WarnT e m b
<*> :: forall a b. WarnT e m (a -> b) -> WarnT e m a -> WarnT e m b
$cliftA2 :: forall e (m :: Type -> Type) a b c.
Monad m =>
(a -> b -> c) -> WarnT e m a -> WarnT e m b -> WarnT e m c
liftA2 :: forall a b c.
(a -> b -> c) -> WarnT e m a -> WarnT e m b -> WarnT e m c
$c*> :: forall e (m :: Type -> Type) a b.
Monad m =>
WarnT e m a -> WarnT e m b -> WarnT e m b
*> :: forall a b. WarnT e m a -> WarnT e m b -> WarnT e m b
$c<* :: forall e (m :: Type -> Type) a b.
Monad m =>
WarnT e m a -> WarnT e m b -> WarnT e m a
<* :: forall a b. WarnT e m a -> WarnT e m b -> WarnT e m a
Applicative, Applicative (WarnT e m)
Applicative (WarnT e m) =>
(forall a b. WarnT e m a -> (a -> WarnT e m b) -> WarnT e m b)
-> (forall a b. WarnT e m a -> WarnT e m b -> WarnT e m b)
-> (forall a. a -> WarnT e m a)
-> Monad (WarnT e m)
forall a. a -> WarnT e m a
forall a b. WarnT e m a -> WarnT e m b -> WarnT e m b
forall a b. WarnT e m a -> (a -> WarnT e m b) -> WarnT e m b
forall e (m :: Type -> Type). Monad m => Applicative (WarnT e m)
forall e (m :: Type -> Type) a. Monad m => a -> WarnT e m a
forall e (m :: Type -> Type) a b.
Monad m =>
WarnT e m a -> WarnT e m b -> WarnT e m b
forall e (m :: Type -> Type) a b.
Monad m =>
WarnT e m a -> (a -> WarnT e m b) -> WarnT e m b
forall (m :: Type -> Type).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall e (m :: Type -> Type) a b.
Monad m =>
WarnT e m a -> (a -> WarnT e m b) -> WarnT e m b
>>= :: forall a b. WarnT e m a -> (a -> WarnT e m b) -> WarnT e m b
$c>> :: forall e (m :: Type -> Type) a b.
Monad m =>
WarnT e m a -> WarnT e m b -> WarnT e m b
>> :: forall a b. WarnT e m a -> WarnT e m b -> WarnT e m b
$creturn :: forall e (m :: Type -> Type) a. Monad m => a -> WarnT e m a
return :: forall a. a -> WarnT e m a
Monad, MonadError e)

runWarnT :: WarnT e m r -> m (Either e r, [e])
runWarnT :: forall e (m :: Type -> Type) r. WarnT e m r -> m (Either e r, [e])
runWarnT WarnT e m r
m = StateT [e] m (Either e r) -> [e] -> m (Either e r, [e])
forall s (m :: Type -> Type) a. StateT s m a -> s -> m (a, s)
runStateT (ExceptT e (StateT [e] m) r -> StateT [e] m (Either e r)
forall e (m :: Type -> Type) a. ExceptT e m a -> m (Either e a)
runExceptT (WarnT e m r -> ExceptT e (StateT [e] m) r
forall e (m :: Type -> Type) r.
WarnT e m r -> ExceptT e (StateT [e] m) r
unWarnT WarnT e m r
m)) []

instance Monad m => WarnMonad e (WarnT e m) where
  warn :: e -> WarnT e m ()
warn e
msg = ExceptT e (StateT [e] m) () -> WarnT e m ()
forall e (m :: Type -> Type) r.
ExceptT e (StateT [e] m) r -> WarnT e m r
WarnT (ExceptT e (StateT [e] m) () -> WarnT e m ())
-> ExceptT e (StateT [e] m) () -> WarnT e m ()
forall a b. (a -> b) -> a -> b
$ StateT [e] m (Either e ()) -> ExceptT e (StateT [e] m) ()
forall e (m :: Type -> Type) a. m (Either e a) -> ExceptT e m a
ExceptT (StateT [e] m (Either e ()) -> ExceptT e (StateT [e] m) ())
-> StateT [e] m (Either e ()) -> ExceptT e (StateT [e] m) ()
forall a b. (a -> b) -> a -> b
$ ([e] -> m (Either e (), [e])) -> StateT [e] m (Either e ())
forall s (m :: Type -> Type) a. (s -> m (a, s)) -> StateT s m a
StateT (([e] -> m (Either e (), [e])) -> StateT [e] m (Either e ()))
-> ([e] -> m (Either e (), [e])) -> StateT [e] m (Either e ())
forall a b. (a -> b) -> a -> b
$ \[e]
s -> (Either e (), [e]) -> m (Either e (), [e])
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (() -> Either e ()
forall a b. b -> Either a b
Right (), e
msg e -> [e] -> [e]
forall a. a -> [a] -> [a]
: [e]
s)

  runInContext :: forall r. (e -> e) -> WarnT e m r -> WarnT e m r
runInContext e -> e
f WarnT e m r
m = ExceptT e (StateT [e] m) r -> WarnT e m r
forall e (m :: Type -> Type) r.
ExceptT e (StateT [e] m) r -> WarnT e m r
WarnT (ExceptT e (StateT [e] m) r -> WarnT e m r)
-> ExceptT e (StateT [e] m) r -> WarnT e m r
forall a b. (a -> b) -> a -> b
$
    StateT [e] m (Either e r) -> ExceptT e (StateT [e] m) r
forall e (m :: Type -> Type) a. m (Either e a) -> ExceptT e m a
ExceptT (StateT [e] m (Either e r) -> ExceptT e (StateT [e] m) r)
-> StateT [e] m (Either e r) -> ExceptT e (StateT [e] m) r
forall a b. (a -> b) -> a -> b
$
      ([e] -> m (Either e r, [e])) -> StateT [e] m (Either e r)
forall s (m :: Type -> Type) a. (s -> m (a, s)) -> StateT s m a
StateT (([e] -> m (Either e r, [e])) -> StateT [e] m (Either e r))
-> ([e] -> m (Either e r, [e])) -> StateT [e] m (Either e r)
forall a b. (a -> b) -> a -> b
$ \[e]
s -> do
        let g :: (Either e r, [e]) -> (Either e r, [e])
g (Either e r
mr, [e]
warnings) = ((e -> Either e r) -> (r -> Either e r) -> Either e r -> Either e r
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (e -> Either e r
forall a b. a -> Either a b
Left (e -> Either e r) -> (e -> e) -> e -> Either e r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> e
f) r -> Either e r
forall a b. b -> Either a b
Right Either e r
mr, (e -> e) -> [e] -> [e]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap e -> e
f [e]
warnings [e] -> [e] -> [e]
forall a. [a] -> [a] -> [a]
++ [e]
s)
         in (Either e r, [e]) -> (Either e r, [e])
g ((Either e r, [e]) -> (Either e r, [e]))
-> m (Either e r, [e]) -> m (Either e r, [e])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> WarnT e m r -> m (Either e r, [e])
forall e (m :: Type -> Type) r. WarnT e m r -> m (Either e r, [e])
runWarnT WarnT e m r
m

------------------------------------------------------------------------
-- Parser

-- | The context needed to read dwarf entries.
newtype ParserState = ParserState
  { ParserState -> Reader
readerInfo :: Dwarf.Reader
  }

newtype Parser r = Parser {forall r. Parser r -> ReaderT ParserState (WarnT String Identity) r
unParser :: ReaderT ParserState (WarnT String Identity) r}
  deriving
    ( (forall a b. (a -> b) -> Parser a -> Parser b)
-> (forall a b. a -> Parser b -> Parser a) -> Functor Parser
forall a b. a -> Parser b -> Parser a
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: Type -> Type).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Parser a -> Parser b
fmap :: forall a b. (a -> b) -> Parser a -> Parser b
$c<$ :: forall a b. a -> Parser b -> Parser a
<$ :: forall a b. a -> Parser b -> Parser a
Functor,
      Functor Parser
Functor Parser =>
(forall a. a -> Parser a)
-> (forall a b. Parser (a -> b) -> Parser a -> Parser b)
-> (forall a b c.
    (a -> b -> c) -> Parser a -> Parser b -> Parser c)
-> (forall a b. Parser a -> Parser b -> Parser b)
-> (forall a b. Parser a -> Parser b -> Parser a)
-> Applicative Parser
forall a. a -> Parser a
forall a b. Parser a -> Parser b -> Parser a
forall a b. Parser a -> Parser b -> Parser b
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall a b c. (a -> b -> c) -> Parser a -> Parser b -> Parser c
forall (f :: Type -> Type).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> Parser a
pure :: forall a. a -> Parser a
$c<*> :: forall a b. Parser (a -> b) -> Parser a -> Parser b
<*> :: forall a b. Parser (a -> b) -> Parser a -> Parser b
$cliftA2 :: forall a b c. (a -> b -> c) -> Parser a -> Parser b -> Parser c
liftA2 :: forall a b c. (a -> b -> c) -> Parser a -> Parser b -> Parser c
$c*> :: forall a b. Parser a -> Parser b -> Parser b
*> :: forall a b. Parser a -> Parser b -> Parser b
$c<* :: forall a b. Parser a -> Parser b -> Parser a
<* :: forall a b. Parser a -> Parser b -> Parser a
Applicative,
      Applicative Parser
Applicative Parser =>
(forall a b. Parser a -> (a -> Parser b) -> Parser b)
-> (forall a b. Parser a -> Parser b -> Parser b)
-> (forall a. a -> Parser a)
-> Monad Parser
forall a. a -> Parser a
forall a b. Parser a -> Parser b -> Parser b
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: Type -> Type).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. Parser a -> (a -> Parser b) -> Parser b
>>= :: forall a b. Parser a -> (a -> Parser b) -> Parser b
$c>> :: forall a b. Parser a -> Parser b -> Parser b
>> :: forall a b. Parser a -> Parser b -> Parser b
$creturn :: forall a. a -> Parser a
return :: forall a. a -> Parser a
Monad,
      MonadError String,
      WarnMonad String
    )

instance MonadFail Parser where
  fail :: forall a. String -> Parser a
fail = String -> Parser a
forall a. String -> Parser a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError


runParser :: Dwarf.Reader -> Parser r -> (Either String r, [String])
runParser :: forall r. Reader -> Parser r -> (Either String r, [String])
runParser Reader
dr Parser r
p = Identity (Either String r, [String]) -> (Either String r, [String])
forall a. Identity a -> a
runIdentity (WarnT String Identity r -> Identity (Either String r, [String])
forall e (m :: Type -> Type) r. WarnT e m r -> m (Either e r, [e])
runWarnT (ReaderT ParserState (WarnT String Identity) r
-> ParserState -> WarnT String Identity r
forall r (m :: Type -> Type) a. ReaderT r m a -> r -> m a
runReaderT (Parser r -> ReaderT ParserState (WarnT String Identity) r
forall r. Parser r -> ReaderT ParserState (WarnT String Identity) r
unParser Parser r
p) ParserState
s))
  where
    s :: ParserState
s =
      ParserState
        { readerInfo :: Reader
readerInfo = Reader
dr
        }

------------------------------------------------------------------------
-- Parser functions

-- | Error from parsing an attribute.
data AttrError
  = IncorrectTypeFor !BSC.ByteString
  | InvalidFileIndex !Word64

ppAttrError :: AttrError -> String
ppAttrError :: AttrError -> String
ppAttrError AttrError
e =
  case AttrError
e of
    IncorrectTypeFor ByteString
tp -> String
"Incorrect type for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
BSC.unpack ByteString
tp
    InvalidFileIndex Word64
idx -> String
"Invalid file index " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show Word64
idx

-- | A parser for attribute values.
type AttrParser r = Dwarf.Reader -> DW_ATVAL -> Except AttrError r

convertAttribute ::
  DW_AT ->
  AttrParser r ->
  DW_ATVAL ->
  Parser r
convertAttribute :: forall r. DW_AT -> AttrParser r -> DW_ATVAL -> Parser r
convertAttribute DW_AT
dat AttrParser r
f DW_ATVAL
v = do
  dr <- ReaderT ParserState (WarnT String Identity) Reader -> Parser Reader
forall r. ReaderT ParserState (WarnT String Identity) r -> Parser r
Parser (ReaderT ParserState (WarnT String Identity) Reader
 -> Parser Reader)
-> ReaderT ParserState (WarnT String Identity) Reader
-> Parser Reader
forall a b. (a -> b) -> a -> b
$ (ParserState -> Reader)
-> ReaderT ParserState (WarnT String Identity) Reader
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks ParserState -> Reader
readerInfo
  case runExcept (f dr v) of
    Left AttrError
e ->
      String -> Parser r
forall a. String -> Parser a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (String -> Parser r) -> String -> Parser r
forall a b. (a -> b) -> a -> b
$
        String
"Could not interpret attribute "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ DW_AT -> String
forall a. Show a => a -> String
show DW_AT
dat
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" value "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ DW_ATVAL -> String
forall a. Show a => a -> String
show DW_ATVAL
v
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ AttrError -> String
ppAttrError AttrError
e
    Right r
r -> r -> Parser r
forall a. a -> Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure r
r

attributeValue :: AttrParser DW_ATVAL
attributeValue :: AttrParser DW_ATVAL
attributeValue = \Reader
_ -> DW_ATVAL -> ExceptT AttrError Identity DW_ATVAL
forall a. a -> ExceptT AttrError Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure

attributeAsBlob :: AttrParser BS.ByteString
attributeAsBlob :: AttrParser ByteString
attributeAsBlob Reader
_ (DW_ATVAL_BLOB ByteString
b) = ByteString -> ExceptT AttrError Identity ByteString
forall a. a -> ExceptT AttrError Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ByteString
b
attributeAsBlob Reader
_ DW_ATVAL
_ = AttrError -> ExceptT AttrError Identity ByteString
forall a. AttrError -> ExceptT AttrError Identity a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (AttrError -> ExceptT AttrError Identity ByteString)
-> AttrError -> ExceptT AttrError Identity ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> AttrError
IncorrectTypeFor ByteString
"BLOB"

attributeAsBool :: AttrParser Bool
attributeAsBool :: AttrParser Bool
attributeAsBool Reader
_ (DW_ATVAL_BOOL Bool
b) = Bool -> ExceptT AttrError Identity Bool
forall a. a -> ExceptT AttrError Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Bool
b
attributeAsBool Reader
_ DW_ATVAL
_ = AttrError -> ExceptT AttrError Identity Bool
forall a. AttrError -> ExceptT AttrError Identity a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (AttrError -> ExceptT AttrError Identity Bool)
-> AttrError -> ExceptT AttrError Identity Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> AttrError
IncorrectTypeFor ByteString
"Bool"

attributeAsUInt :: AttrParser Word64
attributeAsUInt :: AttrParser Word64
attributeAsUInt Reader
_ (DW_ATVAL_UINT Word64
u) = Word64 -> ExceptT AttrError Identity Word64
forall a. a -> ExceptT AttrError Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Word64
u
attributeAsUInt Reader
_ DW_ATVAL
_ = AttrError -> ExceptT AttrError Identity Word64
forall a. AttrError -> ExceptT AttrError Identity a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (AttrError -> ExceptT AttrError Identity Word64)
-> AttrError -> ExceptT AttrError Identity Word64
forall a b. (a -> b) -> a -> b
$ ByteString -> AttrError
IncorrectTypeFor ByteString
"UInt"

-- | Parse an attribute as a DIE identifier.
attributeAsDieID :: AttrParser DieID
attributeAsDieID :: AttrParser DieID
attributeAsDieID Reader
_ (DW_ATVAL_REF DieID
r) = DieID -> ExceptT AttrError Identity DieID
forall a. a -> ExceptT AttrError Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure DieID
r
attributeAsDieID Reader
_ DW_ATVAL
_ = AttrError -> ExceptT AttrError Identity DieID
forall a. AttrError -> ExceptT AttrError Identity a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (AttrError -> ExceptT AttrError Identity DieID)
-> AttrError -> ExceptT AttrError Identity DieID
forall a b. (a -> b) -> a -> b
$ ByteString -> AttrError
IncorrectTypeFor ByteString
"DieID"

-- | Parse an attribute intended to be interpreted as a displayable
-- string.
--
-- The character set is not defined, but typically 7-bit ASCII.
attributeAsString :: AttrParser BS.ByteString
attributeAsString :: AttrParser ByteString
attributeAsString Reader
_ (DW_ATVAL_STRING ByteString
s) = ByteString -> ExceptT AttrError Identity ByteString
forall a. a -> ExceptT AttrError Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ByteString
s
attributeAsString Reader
_ DW_ATVAL
_ = AttrError -> ExceptT AttrError Identity ByteString
forall a. AttrError -> ExceptT AttrError Identity a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (AttrError -> ExceptT AttrError Identity ByteString)
-> AttrError -> ExceptT AttrError Identity ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> AttrError
IncorrectTypeFor ByteString
"String"

attributeAsBaseTypeEncoding :: AttrParser DW_ATE
attributeAsBaseTypeEncoding :: AttrParser DW_ATE
attributeAsBaseTypeEncoding Reader
_ (DW_ATVAL_UINT Word64
u) = DW_ATE -> ExceptT AttrError Identity DW_ATE
forall a. a -> ExceptT AttrError Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Word64 -> DW_ATE
DW_ATE Word64
u)
attributeAsBaseTypeEncoding Reader
_ DW_ATVAL
_ = AttrError -> ExceptT AttrError Identity DW_ATE
forall a. AttrError -> ExceptT AttrError Identity a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (AttrError -> ExceptT AttrError Identity DW_ATE)
-> AttrError -> ExceptT AttrError Identity DW_ATE
forall a b. (a -> b) -> a -> b
$ ByteString -> AttrError
IncorrectTypeFor ByteString
"BaseTypeEncoding"

attributeAsLang :: AttrParser DW_LANG
attributeAsLang :: AttrParser DW_LANG
attributeAsLang Reader
dr DW_ATVAL
v = Word64 -> DW_LANG
DW_LANG (Word64 -> DW_LANG)
-> ExceptT AttrError Identity Word64
-> ExceptT AttrError Identity DW_LANG
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> AttrParser Word64
attributeAsUInt Reader
dr DW_ATVAL
v

mapAttr :: (a -> b) -> AttrParser a -> AttrParser b
mapAttr :: forall a b. (a -> b) -> AttrParser a -> AttrParser b
mapAttr a -> b
f AttrParser a
p Reader
dr DW_ATVAL
v = a -> b
f (a -> b)
-> ExceptT AttrError Identity a -> ExceptT AttrError Identity b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> AttrParser a
p Reader
dr DW_ATVAL
v

parseGet :: BS.ByteString -> Get a -> Parser a
parseGet :: forall a. ByteString -> Get a -> Parser a
parseGet ByteString
bs Get a
m =
  case Decoder a -> Decoder a
forall a. Decoder a -> Decoder a
pushEndOfInput (Get a -> Decoder a
forall a. Get a -> Decoder a
runGetIncremental Get a
m Decoder a -> ByteString -> Decoder a
forall a. Decoder a -> ByteString -> Decoder a
`pushChunk` ByteString
bs) of
    Fail ByteString
_ ByteOffset
_ String
msg -> String -> Parser a
forall a. String -> Parser a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError String
msg
    Partial Maybe ByteString -> Decoder a
_ -> String -> Parser a
forall a. String -> Parser a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError String
"Unexpected partial"
    Done ByteString
_ ByteOffset
_ a
r -> a -> Parser a
forall a. a -> Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure a
r

------------------------------------------------------------------------
-- Range

ppRange :: Range -> Doc ann
ppRange :: forall ann. Range -> Doc ann
ppRange (Range Word64
x Word64
y) =
  Doc ann
"low:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Word64 -> String -> String
forall a. Integral a => a -> String -> String
showHex Word64
x String
"") Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"high:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Word64 -> String -> String
forall a. Integral a => a -> String -> String
showHex Word64
y String
"")

------------------------------------------------------------------------
-- DIEParser

data DIEParserState = DPS
  { DIEParserState -> DIE
dpsDIE :: DIE,
    -- | Maps attributes to the set of values with that attribute.
    DIEParserState -> Map DW_AT [DW_ATVAL]
dpsAttributeMap :: Map DW_AT [DW_ATVAL],
    -- | Set of attributes that a parser has searched for.
    --
    -- Used so that we can flag when a DIE contains an attribute
    -- we have not considered.
    DIEParserState -> Set DW_AT
_dpsSeenAttributes :: Set DW_AT,
    -- | Maps tags to the set of child die nodes with that tag.
    DIEParserState -> Map DW_TAG [DIE]
dpsChildrenMap :: Map DW_TAG [DIE],
    -- | Set of tags for children that we have attempted to
    -- parse.
    --
    -- Used so that we can flag when a DIE contains a child tag
    -- we have not considered.
    DIEParserState -> Set DW_TAG
_dpsSeenChildren :: Set DW_TAG
  }

dpsSeenAttributes :: Lens' DIEParserState (Set DW_AT)
dpsSeenAttributes :: Lens' DIEParserState (Set DW_AT)
dpsSeenAttributes = (DIEParserState -> Set DW_AT)
-> (DIEParserState -> Set DW_AT -> DIEParserState)
-> Lens' DIEParserState (Set DW_AT)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens DIEParserState -> Set DW_AT
_dpsSeenAttributes (\DIEParserState
s Set DW_AT
v -> DIEParserState
s {_dpsSeenAttributes = v})

dpsSeenChildren :: Lens' DIEParserState (Set DW_TAG)
dpsSeenChildren :: Lens' DIEParserState (Set DW_TAG)
dpsSeenChildren = (DIEParserState -> Set DW_TAG)
-> (DIEParserState -> Set DW_TAG -> DIEParserState)
-> Lens' DIEParserState (Set DW_TAG)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens DIEParserState -> Set DW_TAG
_dpsSeenChildren (\DIEParserState
s Set DW_TAG
v -> DIEParserState
s {_dpsSeenChildren = v})

type DIEParser = StateT DIEParserState Parser

taggedError :: String -> String -> String
taggedError :: String -> String -> String
taggedError String
nm String
msg =
  String
"Error parsing " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines ((String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> [String] -> [String]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String]
lines String
msg)

runDIEParser ::
  String ->
  DIE ->
  DIEParser r ->
  Parser r
runDIEParser :: forall r. String -> DIE -> DIEParser r -> Parser r
runDIEParser String
ctx DIE
d DIEParser r
act =
  (String -> String) -> Parser r -> Parser r
forall r. (String -> String) -> Parser r -> Parser r
forall s (m :: Type -> Type) r.
WarnMonad s m =>
(s -> s) -> m r -> m r
runInContext (String -> String -> String
taggedError (String
ctx String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DieID -> String
forall a. Show a => a -> String
show (DIE -> DieID
dieId DIE
d) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DW_TAG -> String
forall a. Show a => a -> String
show (DIE -> DW_TAG
dieTag DIE
d))) (Parser r -> Parser r) -> Parser r -> Parser r
forall a b. (a -> b) -> a -> b
$ do
    let childMap :: Map DW_TAG [DIE]
        childMap :: Map DW_TAG [DIE]
childMap = (DIE -> Map DW_TAG [DIE] -> Map DW_TAG [DIE])
-> Map DW_TAG [DIE] -> [DIE] -> Map DW_TAG [DIE]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' (\DIE
d' -> ([DIE] -> [DIE] -> [DIE])
-> DW_TAG -> [DIE] -> Map DW_TAG [DIE] -> Map DW_TAG [DIE]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (\[DIE]
_ [DIE]
o -> DIE
d' DIE -> [DIE] -> [DIE]
forall a. a -> [a] -> [a]
: [DIE]
o) (DIE -> DW_TAG
dieTag DIE
d') [DIE
d']) Map DW_TAG [DIE]
forall k a. Map k a
Map.empty (DIE -> [DIE]
dieChildren DIE
d)
        attrMap :: Map DW_AT [DW_ATVAL]
attrMap = ((DW_AT, DW_ATVAL) -> Map DW_AT [DW_ATVAL] -> Map DW_AT [DW_ATVAL])
-> Map DW_AT [DW_ATVAL]
-> [(DW_AT, DW_ATVAL)]
-> Map DW_AT [DW_ATVAL]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' (\(DW_AT
k, DW_ATVAL
v) -> ([DW_ATVAL] -> [DW_ATVAL] -> [DW_ATVAL])
-> DW_AT
-> [DW_ATVAL]
-> Map DW_AT [DW_ATVAL]
-> Map DW_AT [DW_ATVAL]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [DW_ATVAL] -> [DW_ATVAL] -> [DW_ATVAL]
forall a. [a] -> [a] -> [a]
(++) DW_AT
k [DW_ATVAL
v]) Map DW_AT [DW_ATVAL]
forall k a. Map k a
Map.empty (DIE -> [(DW_AT, DW_ATVAL)]
dieAttributes DIE
d)
        s0 :: DIEParserState
s0 =
          DPS
            { dpsDIE :: DIE
dpsDIE = DIE
d,
              dpsAttributeMap :: Map DW_AT [DW_ATVAL]
dpsAttributeMap = Map DW_AT [DW_ATVAL]
attrMap,
              _dpsSeenAttributes :: Set DW_AT
_dpsSeenAttributes = DW_AT -> Set DW_AT
forall a. a -> Set a
Set.singleton DW_AT
DW_AT_sibling,
              dpsChildrenMap :: Map DW_TAG [DIE]
dpsChildrenMap = Map DW_TAG [DIE]
childMap,
              _dpsSeenChildren :: Set DW_TAG
_dpsSeenChildren = Set DW_TAG
forall a. Set a
Set.empty
            }
    (r, s1) <- DIEParser r -> DIEParserState -> Parser (r, DIEParserState)
forall s (m :: Type -> Type) a. StateT s m a -> s -> m (a, s)
runStateT DIEParser r
act DIEParserState
s0
    do
      let missingTags = Map DW_TAG [DIE] -> Set DW_TAG
forall k a. Map k a -> Set k
Map.keysSet Map DW_TAG [DIE]
childMap Set DW_TAG -> Set DW_TAG -> Set DW_TAG
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` (DIEParserState
s1 DIEParserState
-> Getting (Set DW_TAG) DIEParserState (Set DW_TAG) -> Set DW_TAG
forall s a. s -> Getting a s a -> a
^. Getting (Set DW_TAG) DIEParserState (Set DW_TAG)
Lens' DIEParserState (Set DW_TAG)
dpsSeenChildren)
      when (not (Set.null missingTags)) $ do
        forM_ (dieChildren d) $ \DIE
child -> do
          Bool -> Parser () -> Parser ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (DW_TAG -> Set DW_TAG -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (DIE -> DW_TAG
dieTag DIE
child) (DIEParserState
s1 DIEParserState
-> Getting (Set DW_TAG) DIEParserState (Set DW_TAG) -> Set DW_TAG
forall s a. s -> Getting a s a -> a
^. Getting (Set DW_TAG) DIEParserState (Set DW_TAG)
Lens' DIEParserState (Set DW_TAG)
dpsSeenChildren))) (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ do
            String -> Parser ()
forall s (m :: Type -> Type). WarnMonad s m => s -> m ()
warn (String -> Parser ()) -> String -> Parser ()
forall a b. (a -> b) -> a -> b
$ String
"Unexpected child for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ctx String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DIE -> String
forall a. Show a => a -> String
show DIE
child
    do
      let missingAttrs = Map DW_AT [DW_ATVAL] -> Set DW_AT
forall k a. Map k a -> Set k
Map.keysSet Map DW_AT [DW_ATVAL]
attrMap Set DW_AT -> Set DW_AT -> Set DW_AT
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` (DIEParserState
s1 DIEParserState
-> Getting (Set DW_AT) DIEParserState (Set DW_AT) -> Set DW_AT
forall s a. s -> Getting a s a -> a
^. Getting (Set DW_AT) DIEParserState (Set DW_AT)
Lens' DIEParserState (Set DW_AT)
dpsSeenAttributes)
      when (not (Set.null missingAttrs)) $ do
        warn $ "Unexpected attributes: " ++ show (Set.toList missingAttrs) ++ "\n" ++ show d
    pure r

checkTag :: DW_TAG -> DIEParser ()
checkTag :: DW_TAG -> DIEParser ()
checkTag DW_TAG
tag = do
  d <- (DIEParserState -> DIE) -> StateT DIEParserState Parser DIE
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets DIEParserState -> DIE
dpsDIE
  lift $ when (dieTag d /= tag) $ warn ("Expected " ++ show tag)

ignoreAttribute :: DW_AT -> DIEParser ()
ignoreAttribute :: DW_AT -> DIEParser ()
ignoreAttribute DW_AT
dat = do
  (Set DW_AT -> Identity (Set DW_AT))
-> DIEParserState -> Identity DIEParserState
Lens' DIEParserState (Set DW_AT)
dpsSeenAttributes ((Set DW_AT -> Identity (Set DW_AT))
 -> DIEParserState -> Identity DIEParserState)
-> (Set DW_AT -> Set DW_AT) -> DIEParser ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= DW_AT -> Set DW_AT -> Set DW_AT
forall a. Ord a => a -> Set a -> Set a
Set.insert DW_AT
dat

ignoreChild :: DW_TAG -> DIEParser ()
ignoreChild :: DW_TAG -> DIEParser ()
ignoreChild DW_TAG
dat = do
  (Set DW_TAG -> Identity (Set DW_TAG))
-> DIEParserState -> Identity DIEParserState
Lens' DIEParserState (Set DW_TAG)
dpsSeenChildren ((Set DW_TAG -> Identity (Set DW_TAG))
 -> DIEParserState -> Identity DIEParserState)
-> (Set DW_TAG -> Set DW_TAG) -> DIEParser ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= DW_TAG -> Set DW_TAG -> Set DW_TAG
forall a. Ord a => a -> Set a -> Set a
Set.insert DW_TAG
dat

getSingleAttribute :: DW_AT -> AttrParser v -> DIEParser v
getSingleAttribute :: forall v. DW_AT -> AttrParser v -> DIEParser v
getSingleAttribute DW_AT
dat AttrParser v
p = do
  d <- (DIEParserState -> DIE) -> StateT DIEParserState Parser DIE
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets DIEParserState -> DIE
dpsDIE
  m <- gets dpsAttributeMap
  case Map.findWithDefault [] dat m of
    [] -> String -> StateT DIEParserState Parser v
forall a. String -> StateT DIEParserState Parser a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (String -> StateT DIEParserState Parser v)
-> String -> StateT DIEParserState Parser v
forall a b. (a -> b) -> a -> b
$ String
"Expected attribute " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DW_AT -> String
forall a. Show a => a -> String
show DW_AT
dat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DIE -> String
forall a. Show a => a -> String
show DIE
d String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
    [DW_ATVAL
v] -> do
      DW_AT -> DIEParser ()
ignoreAttribute DW_AT
dat
      Parser v -> StateT DIEParserState Parser v
forall (m :: Type -> Type) a.
Monad m =>
m a -> StateT DIEParserState m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Parser v -> StateT DIEParserState Parser v)
-> Parser v -> StateT DIEParserState Parser v
forall a b. (a -> b) -> a -> b
$ DW_AT -> AttrParser v -> DW_ATVAL -> Parser v
forall r. DW_AT -> AttrParser r -> DW_ATVAL -> Parser r
convertAttribute DW_AT
dat AttrParser v
p DW_ATVAL
v
    [DW_ATVAL]
_ -> String -> StateT DIEParserState Parser v
forall a. String -> StateT DIEParserState Parser a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (String -> StateT DIEParserState Parser v)
-> String -> StateT DIEParserState Parser v
forall a b. (a -> b) -> a -> b
$ String
"Found multiple attributes for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DW_AT -> String
forall a. Show a => a -> String
show DW_AT
dat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DIE -> String
forall a. Show a => a -> String
show DIE
d String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."

getAttributeWithDefault :: DW_AT -> v -> AttrParser v -> DIEParser v
getAttributeWithDefault :: forall v. DW_AT -> v -> AttrParser v -> DIEParser v
getAttributeWithDefault DW_AT
dat v
def AttrParser v
f = do
  d <- (DIEParserState -> DIE) -> StateT DIEParserState Parser DIE
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets DIEParserState -> DIE
dpsDIE
  m <- gets dpsAttributeMap
  case Map.findWithDefault [] dat m of
    [] -> do
      DW_AT -> DIEParser ()
ignoreAttribute DW_AT
dat
      v -> StateT DIEParserState Parser v
forall a. a -> StateT DIEParserState Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure v
def
    [DW_ATVAL
v] -> do
      DW_AT -> DIEParser ()
ignoreAttribute DW_AT
dat
      Parser v -> StateT DIEParserState Parser v
forall (m :: Type -> Type) a.
Monad m =>
m a -> StateT DIEParserState m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Parser v -> StateT DIEParserState Parser v)
-> Parser v -> StateT DIEParserState Parser v
forall a b. (a -> b) -> a -> b
$ DW_AT -> AttrParser v -> DW_ATVAL -> Parser v
forall r. DW_AT -> AttrParser r -> DW_ATVAL -> Parser r
convertAttribute DW_AT
dat AttrParser v
f DW_ATVAL
v
    [DW_ATVAL]
_ -> String -> StateT DIEParserState Parser v
forall a. String -> StateT DIEParserState Parser a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (String -> StateT DIEParserState Parser v)
-> String -> StateT DIEParserState Parser v
forall a b. (a -> b) -> a -> b
$ String
"Found multiple attributes for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DW_AT -> String
forall a. Show a => a -> String
show DW_AT
dat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DIE -> String
forall a. Show a => a -> String
show DIE
d String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."

getMaybeAttribute :: DW_AT -> AttrParser v -> DIEParser (Maybe v)
getMaybeAttribute :: forall v. DW_AT -> AttrParser v -> DIEParser (Maybe v)
getMaybeAttribute DW_AT
dat AttrParser v
f = do
  d <- (DIEParserState -> DIE) -> StateT DIEParserState Parser DIE
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets DIEParserState -> DIE
dpsDIE
  m <- gets dpsAttributeMap
  case Map.findWithDefault [] dat m of
    [] -> do
      DW_AT -> DIEParser ()
ignoreAttribute DW_AT
dat
      Maybe v -> StateT DIEParserState Parser (Maybe v)
forall a. a -> StateT DIEParserState Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe v
forall a. Maybe a
Nothing
    [DW_ATVAL
v] -> do
      DW_AT -> DIEParser ()
ignoreAttribute DW_AT
dat
      Parser (Maybe v) -> StateT DIEParserState Parser (Maybe v)
forall (m :: Type -> Type) a.
Monad m =>
m a -> StateT DIEParserState m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Parser (Maybe v) -> StateT DIEParserState Parser (Maybe v))
-> Parser (Maybe v) -> StateT DIEParserState Parser (Maybe v)
forall a b. (a -> b) -> a -> b
$ v -> Maybe v
forall a. a -> Maybe a
Just (v -> Maybe v) -> Parser v -> Parser (Maybe v)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DW_AT -> AttrParser v -> DW_ATVAL -> Parser v
forall r. DW_AT -> AttrParser r -> DW_ATVAL -> Parser r
convertAttribute DW_AT
dat AttrParser v
f DW_ATVAL
v
    [DW_ATVAL]
_ -> String -> StateT DIEParserState Parser (Maybe v)
forall a. String -> StateT DIEParserState Parser a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (String -> StateT DIEParserState Parser (Maybe v))
-> String -> StateT DIEParserState Parser (Maybe v)
forall a b. (a -> b) -> a -> b
$ String
"Found multiple attributes for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DW_AT -> String
forall a. Show a => a -> String
show DW_AT
dat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DIE -> String
forall a. Show a => a -> String
show DIE
d String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."

parseChildrenList :: DW_TAG -> (DIE -> Parser v) -> DIEParser [v]
parseChildrenList :: forall v. DW_TAG -> (DIE -> Parser v) -> DIEParser [v]
parseChildrenList DW_TAG
tag DIE -> Parser v
f = do
  DW_TAG -> DIEParser ()
ignoreChild DW_TAG
tag
  m <- (DIEParserState -> Map DW_TAG [DIE])
-> StateT DIEParserState Parser (Map DW_TAG [DIE])
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets DIEParserState -> Map DW_TAG [DIE]
dpsChildrenMap
  lift $ traverse f $ Map.findWithDefault [] tag m

hasChildren :: DW_TAG -> DIEParser Bool
hasChildren :: DW_TAG -> DIEParser Bool
hasChildren DW_TAG
tag = do
  DW_TAG -> DIEParser ()
ignoreChild DW_TAG
tag
  (DIEParserState -> Bool) -> DIEParser Bool
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets ((DIEParserState -> Bool) -> DIEParser Bool)
-> (DIEParserState -> Bool) -> DIEParser Bool
forall a b. (a -> b) -> a -> b
$ DW_TAG -> Map DW_TAG [DIE] -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member DW_TAG
tag (Map DW_TAG [DIE] -> Bool)
-> (DIEParserState -> Map DW_TAG [DIE]) -> DIEParserState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DIEParserState -> Map DW_TAG [DIE]
dpsChildrenMap

------------------------------------------------------------------------
-- DeclLoc

-- | Type synonym for file paths in Dwarf
--
-- The empty string denotes no file.
newtype DwarfFilePath = DwarfFilePath {DwarfFilePath -> ByteString
filePathVal :: BS.ByteString}
  deriving (DwarfFilePath -> DwarfFilePath -> Bool
(DwarfFilePath -> DwarfFilePath -> Bool)
-> (DwarfFilePath -> DwarfFilePath -> Bool) -> Eq DwarfFilePath
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DwarfFilePath -> DwarfFilePath -> Bool
== :: DwarfFilePath -> DwarfFilePath -> Bool
$c/= :: DwarfFilePath -> DwarfFilePath -> Bool
/= :: DwarfFilePath -> DwarfFilePath -> Bool
Eq, String -> DwarfFilePath
(String -> DwarfFilePath) -> IsString DwarfFilePath
forall a. (String -> a) -> IsString a
$cfromString :: String -> DwarfFilePath
fromString :: String -> DwarfFilePath
IsString)

instance Show DwarfFilePath where
  show :: DwarfFilePath -> String
show = ByteString -> String
BSC.unpack (ByteString -> String)
-> (DwarfFilePath -> ByteString) -> DwarfFilePath -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DwarfFilePath -> ByteString
filePathVal

instance Pretty DwarfFilePath where
  pretty :: forall ann. DwarfFilePath -> Doc ann
pretty = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann)
-> (DwarfFilePath -> String) -> DwarfFilePath -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BSC.unpack (ByteString -> String)
-> (DwarfFilePath -> ByteString) -> DwarfFilePath -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DwarfFilePath -> ByteString
filePathVal

-- | File vector read from line-number information.
type FileVec = V.Vector DwarfFilePath

-- | A file and line number for a declaration.
data DeclLoc = DeclLoc
  { DeclLoc -> DwarfFilePath
locFile :: !DwarfFilePath,
    DeclLoc -> Word64
locLine :: !Word64,
    DeclLoc -> Word64
locColumn :: !Word64
  }

instance Pretty DeclLoc where
  pretty :: forall ann. DeclLoc -> Doc ann
pretty DeclLoc
loc =
    let file :: Doc ann
file
          | DeclLoc -> DwarfFilePath
locFile DeclLoc
loc DwarfFilePath -> DwarfFilePath -> Bool
forall a. Eq a => a -> a -> Bool
== DwarfFilePath
"" = Doc ann
forall ann. Doc ann
emptyDoc
          | Bool
otherwise = Doc ann
"decl_file:   " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> DwarfFilePath -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. DwarfFilePath -> Doc ann
pretty (DeclLoc -> DwarfFilePath
locFile DeclLoc
loc) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line
        lne :: Doc ann
lne
          | DeclLoc -> Word64
locLine DeclLoc
loc Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0 = Doc ann
forall ann. Doc ann
emptyDoc
          | Bool
otherwise = Doc ann
"decl_line:   " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Word64 -> Doc ann
forall ann. Word64 -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (DeclLoc -> Word64
locLine DeclLoc
loc) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line
        col :: Doc ann
col
          | DeclLoc -> Word64
locColumn DeclLoc
loc Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0 = Doc ann
forall ann. Doc ann
emptyDoc
          | Bool
otherwise = Doc ann
"decl_column: " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Word64 -> Doc ann
forall ann. Word64 -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (DeclLoc -> Word64
locColumn DeclLoc
loc) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line
     in Doc ann
file Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
lne Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
col

instance Show DeclLoc where
  show :: DeclLoc -> String
show = Doc (ZonkAny 3) -> String
forall a. Show a => a -> String
show (Doc (ZonkAny 3) -> String)
-> (DeclLoc -> Doc (ZonkAny 3)) -> DeclLoc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeclLoc -> Doc (ZonkAny 3)
forall a ann. Pretty a => a -> Doc ann
forall ann. DeclLoc -> Doc ann
pretty

attributeAsFile :: FileVec -> AttrParser DwarfFilePath
attributeAsFile :: FileVec -> AttrParser DwarfFilePath
attributeAsFile FileVec
fileVec Reader
_ (DW_ATVAL_UINT Word64
i) =
  if Word64
i Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0
    then DwarfFilePath -> ExceptT AttrError Identity DwarfFilePath
forall a. a -> ExceptT AttrError Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure DwarfFilePath
""
    else
      if Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Int -> Integer
forall a. Integral a => a -> Integer
toInteger (FileVec -> Int
forall a. Vector a -> Int
V.length FileVec
fileVec)
        then DwarfFilePath -> ExceptT AttrError Identity DwarfFilePath
forall a. a -> ExceptT AttrError Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (DwarfFilePath -> ExceptT AttrError Identity DwarfFilePath)
-> DwarfFilePath -> ExceptT AttrError Identity DwarfFilePath
forall a b. (a -> b) -> a -> b
$! FileVec
fileVec FileVec -> Int -> DwarfFilePath
forall a. Vector a -> Int -> a
V.! Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
i Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
-Word64
1)
        else AttrError -> ExceptT AttrError Identity DwarfFilePath
forall a. AttrError -> ExceptT AttrError Identity a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (AttrError -> ExceptT AttrError Identity DwarfFilePath)
-> AttrError -> ExceptT AttrError Identity DwarfFilePath
forall a b. (a -> b) -> a -> b
$ Word64 -> AttrError
InvalidFileIndex Word64
i
attributeAsFile FileVec
_ Reader
_ DW_ATVAL
_ = AttrError -> ExceptT AttrError Identity DwarfFilePath
forall a. AttrError -> ExceptT AttrError Identity a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (AttrError -> ExceptT AttrError Identity DwarfFilePath)
-> AttrError -> ExceptT AttrError Identity DwarfFilePath
forall a b. (a -> b) -> a -> b
$ ByteString -> AttrError
IncorrectTypeFor ByteString
"file path"

-- | Read the decl_file and decl_line attributes from the DIE
parseDeclLoc :: FileVec -> DIEParser DeclLoc
parseDeclLoc :: FileVec -> DIEParser DeclLoc
parseDeclLoc FileVec
fileVec = do
  declFile <- DW_AT
-> DwarfFilePath
-> AttrParser DwarfFilePath
-> DIEParser DwarfFilePath
forall v. DW_AT -> v -> AttrParser v -> DIEParser v
getAttributeWithDefault DW_AT
DW_AT_decl_file DwarfFilePath
"" (FileVec -> AttrParser DwarfFilePath
attributeAsFile FileVec
fileVec)
  declLine <- getAttributeWithDefault DW_AT_decl_line 0 attributeAsUInt
  declCol <- getAttributeWithDefault DW_AT_decl_column 0 attributeAsUInt
  pure
    $! DeclLoc
      { locFile = declFile,
        locLine = declLine,
        locColumn = declCol
      }

------------------------------------------------------------------------
-- DW_OP operations

ppOp :: DW_OP -> Doc ann
ppOp :: forall ann. DW_OP -> Doc ann
ppOp (DW_OP_addr Word64
w) | Word64
w Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
0 = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Word64 -> String -> String
forall a. Integral a => a -> String -> String
showHex Word64
w String
"")
ppOp DW_OP
o = DW_OP -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow DW_OP
o

ppOps :: [DW_OP] -> Doc ann
ppOps :: forall ann. [DW_OP] -> Doc ann
ppOps [DW_OP]
l = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep (DW_OP -> Doc ann
forall ann. DW_OP -> Doc ann
ppOp (DW_OP -> Doc ann) -> [DW_OP] -> [Doc ann]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [DW_OP]
l)

------------------------------------------------------------------------
-- Name and Descripion

newtype Name = Name {Name -> ByteString
nameVal :: BS.ByteString}
  deriving (Name -> Name -> Bool
(Name -> Name -> Bool) -> (Name -> Name -> Bool) -> Eq Name
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Name -> Name -> Bool
== :: Name -> Name -> Bool
$c/= :: Name -> Name -> Bool
/= :: Name -> Name -> Bool
Eq, Eq Name
Eq Name =>
(Name -> Name -> Ordering)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Name)
-> (Name -> Name -> Name)
-> Ord Name
Name -> Name -> Bool
Name -> Name -> Ordering
Name -> Name -> Name
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Name -> Name -> Ordering
compare :: Name -> Name -> Ordering
$c< :: Name -> Name -> Bool
< :: Name -> Name -> Bool
$c<= :: Name -> Name -> Bool
<= :: Name -> Name -> Bool
$c> :: Name -> Name -> Bool
> :: Name -> Name -> Bool
$c>= :: Name -> Name -> Bool
>= :: Name -> Name -> Bool
$cmax :: Name -> Name -> Name
max :: Name -> Name -> Name
$cmin :: Name -> Name -> Name
min :: Name -> Name -> Name
Ord)

instance IsString Name where
  fromString :: String -> Name
fromString = ByteString -> Name
Name (ByteString -> Name) -> (String -> ByteString) -> String -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BSC.pack

instance Pretty Name where
  pretty :: forall ann. Name -> Doc ann
pretty = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> (Name -> String) -> Name -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BSC.unpack (ByteString -> String) -> (Name -> ByteString) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> ByteString
nameVal

instance Show Name where
  show :: Name -> String
show = ByteString -> String
BSC.unpack (ByteString -> String) -> (Name -> ByteString) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> ByteString
nameVal

-- | The value of a `DW_AT_description` field.
--
-- Note. This is the empty string if th
newtype Description = Description {Description -> ByteString
descriptionVal :: BS.ByteString}

instance Show Description where
  show :: Description -> String
show = ByteString -> String
BSC.unpack (ByteString -> String)
-> (Description -> ByteString) -> Description -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Description -> ByteString
descriptionVal

-- | Get name and description.
--
-- If name of description is missing, the empty string is returned.
getNameAndDescription :: DIEParser (Name, Description)
getNameAndDescription :: DIEParser (Name, Description)
getNameAndDescription = do
  (,) (Name -> Description -> (Name, Description))
-> StateT DIEParserState Parser Name
-> StateT
     DIEParserState Parser (Description -> (Name, Description))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ByteString -> Name
Name (ByteString -> Name)
-> StateT DIEParserState Parser ByteString
-> StateT DIEParserState Parser Name
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DW_AT
-> ByteString
-> AttrParser ByteString
-> StateT DIEParserState Parser ByteString
forall v. DW_AT -> v -> AttrParser v -> DIEParser v
getAttributeWithDefault DW_AT
DW_AT_name ByteString
BS.empty AttrParser ByteString
attributeAsString)
    StateT DIEParserState Parser (Description -> (Name, Description))
-> StateT DIEParserState Parser Description
-> DIEParser (Name, Description)
forall a b.
StateT DIEParserState Parser (a -> b)
-> StateT DIEParserState Parser a -> StateT DIEParserState Parser b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> (ByteString -> Description
Description (ByteString -> Description)
-> StateT DIEParserState Parser ByteString
-> StateT DIEParserState Parser Description
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DW_AT
-> ByteString
-> AttrParser ByteString
-> StateT DIEParserState Parser ByteString
forall v. DW_AT -> v -> AttrParser v -> DIEParser v
getAttributeWithDefault DW_AT
DW_AT_description ByteString
BS.empty AttrParser ByteString
attributeAsString)

------------------------------------------------------------------------
-- ConstValue

data ConstValue
  = ConstBlob BS.ByteString
  | ConstInt Int64
  | ConstUInt Word64
  | -- | A string of bytes that was originally null-terminated.
    --
    -- Note. The null terminator was removed and does not appear
    -- in the Haskell `ByteString`.
    ConstString BS.ByteString
  deriving (Int -> ConstValue -> String -> String
[ConstValue] -> String -> String
ConstValue -> String
(Int -> ConstValue -> String -> String)
-> (ConstValue -> String)
-> ([ConstValue] -> String -> String)
-> Show ConstValue
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ConstValue -> String -> String
showsPrec :: Int -> ConstValue -> String -> String
$cshow :: ConstValue -> String
show :: ConstValue -> String
$cshowList :: [ConstValue] -> String -> String
showList :: [ConstValue] -> String -> String
Show)

attributeConstValue :: AttrParser ConstValue
attributeConstValue :: AttrParser ConstValue
attributeConstValue Reader
_ DW_ATVAL
v =
  case DW_ATVAL
v of
    DW_ATVAL_BLOB ByteString
x -> ConstValue -> Except AttrError ConstValue
forall a. a -> ExceptT AttrError Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ConstValue -> Except AttrError ConstValue)
-> ConstValue -> Except AttrError ConstValue
forall a b. (a -> b) -> a -> b
$! ByteString -> ConstValue
ConstBlob ByteString
x
    DW_ATVAL_INT ByteOffset
x -> ConstValue -> Except AttrError ConstValue
forall a. a -> ExceptT AttrError Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ConstValue -> Except AttrError ConstValue)
-> ConstValue -> Except AttrError ConstValue
forall a b. (a -> b) -> a -> b
$! ByteOffset -> ConstValue
ConstInt ByteOffset
x
    DW_ATVAL_UINT Word64
x -> ConstValue -> Except AttrError ConstValue
forall a. a -> ExceptT AttrError Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ConstValue -> Except AttrError ConstValue)
-> ConstValue -> Except AttrError ConstValue
forall a b. (a -> b) -> a -> b
$! Word64 -> ConstValue
ConstUInt Word64
x
    DW_ATVAL_STRING ByteString
x -> ConstValue -> Except AttrError ConstValue
forall a. a -> ExceptT AttrError Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ConstValue -> Except AttrError ConstValue)
-> ConstValue -> Except AttrError ConstValue
forall a b. (a -> b) -> a -> b
$! ByteString -> ConstValue
ConstString ByteString
x
    DW_ATVAL
_ -> AttrError -> Except AttrError ConstValue
forall a. AttrError -> ExceptT AttrError Identity a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (AttrError -> Except AttrError ConstValue)
-> AttrError -> Except AttrError ConstValue
forall a b. (a -> b) -> a -> b
$ ByteString -> AttrError
IncorrectTypeFor ByteString
"const value"

getConstValue :: DIEParser (Maybe ConstValue)
getConstValue :: DIEParser (Maybe ConstValue)
getConstValue = DW_AT -> AttrParser ConstValue -> DIEParser (Maybe ConstValue)
forall v. DW_AT -> AttrParser v -> DIEParser (Maybe v)
getMaybeAttribute DW_AT
DW_AT_const_value AttrParser ConstValue
attributeConstValue

------------------------------------------------------------------------
-- TypeRef

-- | A reference to a type DIE
newtype TypeRef = TypeRef DieID
  deriving (TypeRef -> TypeRef -> Bool
(TypeRef -> TypeRef -> Bool)
-> (TypeRef -> TypeRef -> Bool) -> Eq TypeRef
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TypeRef -> TypeRef -> Bool
== :: TypeRef -> TypeRef -> Bool
$c/= :: TypeRef -> TypeRef -> Bool
/= :: TypeRef -> TypeRef -> Bool
Eq, Eq TypeRef
Eq TypeRef =>
(TypeRef -> TypeRef -> Ordering)
-> (TypeRef -> TypeRef -> Bool)
-> (TypeRef -> TypeRef -> Bool)
-> (TypeRef -> TypeRef -> Bool)
-> (TypeRef -> TypeRef -> Bool)
-> (TypeRef -> TypeRef -> TypeRef)
-> (TypeRef -> TypeRef -> TypeRef)
-> Ord TypeRef
TypeRef -> TypeRef -> Bool
TypeRef -> TypeRef -> Ordering
TypeRef -> TypeRef -> TypeRef
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TypeRef -> TypeRef -> Ordering
compare :: TypeRef -> TypeRef -> Ordering
$c< :: TypeRef -> TypeRef -> Bool
< :: TypeRef -> TypeRef -> Bool
$c<= :: TypeRef -> TypeRef -> Bool
<= :: TypeRef -> TypeRef -> Bool
$c> :: TypeRef -> TypeRef -> Bool
> :: TypeRef -> TypeRef -> Bool
$c>= :: TypeRef -> TypeRef -> Bool
>= :: TypeRef -> TypeRef -> Bool
$cmax :: TypeRef -> TypeRef -> TypeRef
max :: TypeRef -> TypeRef -> TypeRef
$cmin :: TypeRef -> TypeRef -> TypeRef
min :: TypeRef -> TypeRef -> TypeRef
Ord, Int -> TypeRef -> String -> String
[TypeRef] -> String -> String
TypeRef -> String
(Int -> TypeRef -> String -> String)
-> (TypeRef -> String)
-> ([TypeRef] -> String -> String)
-> Show TypeRef
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> TypeRef -> String -> String
showsPrec :: Int -> TypeRef -> String -> String
$cshow :: TypeRef -> String
show :: TypeRef -> String
$cshowList :: [TypeRef] -> String -> String
showList :: [TypeRef] -> String -> String
Show)

-- | Return the offset asssociated with the type.
typeRefFileOffset :: TypeRef -> Word64
typeRefFileOffset :: TypeRef -> Word64
typeRefFileOffset (TypeRef DieID
o) = DieID -> Word64
dieID DieID
o

instance Pretty TypeRef where
  pretty :: forall ann. TypeRef -> Doc ann
pretty TypeRef
r = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Word64 -> String -> String
forall a. Integral a => a -> String -> String
showHex (TypeRef -> Word64
typeRefFileOffset TypeRef
r) String
"")

------------------------------------------------------------------------
-- Enumerator

data Enumerator = Enumerator
  { Enumerator -> Name
enumName :: !Name,
    Enumerator -> Description
enumDescription :: !Description,
    Enumerator -> ConstValue
enumValue :: !ConstValue
  }
  deriving (Int -> Enumerator -> String -> String
[Enumerator] -> String -> String
Enumerator -> String
(Int -> Enumerator -> String -> String)
-> (Enumerator -> String)
-> ([Enumerator] -> String -> String)
-> Show Enumerator
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Enumerator -> String -> String
showsPrec :: Int -> Enumerator -> String -> String
$cshow :: Enumerator -> String
show :: Enumerator -> String
$cshowList :: [Enumerator] -> String -> String
showList :: [Enumerator] -> String -> String
Show)

parseEnumerator :: DIE -> Parser Enumerator
parseEnumerator :: DIE -> Parser Enumerator
parseEnumerator DIE
d = String -> DIE -> DIEParser Enumerator -> Parser Enumerator
forall r. String -> DIE -> DIEParser r -> Parser r
runDIEParser String
"parseEnumerator" DIE
d (DIEParser Enumerator -> Parser Enumerator)
-> DIEParser Enumerator -> Parser Enumerator
forall a b. (a -> b) -> a -> b
$ do
  DW_TAG -> DIEParser ()
checkTag DW_TAG
DW_TAG_enumerator
  (name, desc) <- DIEParser (Name, Description)
getNameAndDescription
  val <- getSingleAttribute DW_AT_const_value attributeConstValue
  pure
    Enumerator
      { enumName = name,
        enumDescription = desc,
        enumValue = val
      }

------------------------------------------------------------------------
-- Subrange

data Subrange tp = Subrange
  { forall tp. Subrange tp -> tp
subrangeType :: tp,
    forall tp. Subrange tp -> [DW_OP]
subrangeUpperBound :: [DW_OP]
  }
  deriving (Int -> Subrange tp -> String -> String
[Subrange tp] -> String -> String
Subrange tp -> String
(Int -> Subrange tp -> String -> String)
-> (Subrange tp -> String)
-> ([Subrange tp] -> String -> String)
-> Show (Subrange tp)
forall tp. Show tp => Int -> Subrange tp -> String -> String
forall tp. Show tp => [Subrange tp] -> String -> String
forall tp. Show tp => Subrange tp -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: forall tp. Show tp => Int -> Subrange tp -> String -> String
showsPrec :: Int -> Subrange tp -> String -> String
$cshow :: forall tp. Show tp => Subrange tp -> String
show :: Subrange tp -> String
$cshowList :: forall tp. Show tp => [Subrange tp] -> String -> String
showList :: [Subrange tp] -> String -> String
Show)

--subrangeTypeLens :: Lens (Subrange a) (Subrange b) a b
--subrangeTypeLens = lens subrangeType (\s v -> s { subrangeType = v })

parseSubrange :: DIE -> Parser (Subrange TypeRef)
parseSubrange :: DIE -> Parser (Subrange TypeRef)
parseSubrange DIE
d = String
-> DIE -> DIEParser (Subrange TypeRef) -> Parser (Subrange TypeRef)
forall r. String -> DIE -> DIEParser r -> Parser r
runDIEParser String
"parseSubrange" DIE
d (DIEParser (Subrange TypeRef) -> Parser (Subrange TypeRef))
-> DIEParser (Subrange TypeRef) -> Parser (Subrange TypeRef)
forall a b. (a -> b) -> a -> b
$ do
  dr <- Parser Reader -> StateT DIEParserState Parser Reader
forall (m :: Type -> Type) a.
Monad m =>
m a -> StateT DIEParserState m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Parser Reader -> StateT DIEParserState Parser Reader)
-> Parser Reader -> StateT DIEParserState Parser Reader
forall a b. (a -> b) -> a -> b
$ ReaderT ParserState (WarnT String Identity) Reader -> Parser Reader
forall r. ReaderT ParserState (WarnT String Identity) r -> Parser r
Parser (ReaderT ParserState (WarnT String Identity) Reader
 -> Parser Reader)
-> ReaderT ParserState (WarnT String Identity) Reader
-> Parser Reader
forall a b. (a -> b) -> a -> b
$ (ParserState -> Reader)
-> ReaderT ParserState (WarnT String Identity) Reader
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks ParserState -> Reader
readerInfo
  tp <- getSingleAttribute DW_AT_type attributeAsTypeRef
  upperVal <- getSingleAttribute DW_AT_upper_bound attributeValue

  upper <-
    case upperVal of
      DW_ATVAL_UINT Word64
w -> [DW_OP] -> StateT DIEParserState Parser [DW_OP]
forall a. a -> StateT DIEParserState Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [Word64 -> DW_OP
DW_OP_const8u Word64
w]
      DW_ATVAL_BLOB ByteString
bs ->
        case Reader
-> ByteString -> Either ([DW_OP], ByteOffset, String) [DW_OP]
parseDW_OPs Reader
dr ByteString
bs of
          Left ([DW_OP]
_, ByteOffset
_, String
msg) -> String -> StateT DIEParserState Parser [DW_OP]
forall a. String -> StateT DIEParserState Parser a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError String
msg
          Right [DW_OP]
ops -> [DW_OP] -> StateT DIEParserState Parser [DW_OP]
forall a. a -> StateT DIEParserState Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [DW_OP]
ops
      DW_ATVAL
_ -> String -> StateT DIEParserState Parser [DW_OP]
forall a. String -> StateT DIEParserState Parser a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError String
"Invalid upper bound"

  pure
    $! Subrange
      { subrangeType = tp,
        subrangeUpperBound = upper
      }

------------------------------------------------------------------------
-- Type

data Member = Member
  { Member -> Name
memberName :: !Name,
    Member -> Description
memberDescription :: !Description,
    Member -> DeclLoc
memberDeclLoc :: !DeclLoc,
    Member -> Maybe Word64
memberLoc :: !(Maybe Word64),
    Member -> TypeRef
memberType :: !TypeRef,
    Member -> Bool
memberArtificial :: !Bool,
    Member -> Maybe Word64
memberByteSize :: !(Maybe Word64),
    Member -> Maybe Word64
memberBitOffset :: !(Maybe Word64),
    Member -> Maybe Word64
memberBitSize :: !(Maybe Word64)
  }
  deriving (Int -> Member -> String -> String
[Member] -> String -> String
Member -> String
(Int -> Member -> String -> String)
-> (Member -> String)
-> ([Member] -> String -> String)
-> Show Member
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Member -> String -> String
showsPrec :: Int -> Member -> String -> String
$cshow :: Member -> String
show :: Member -> String
$cshowList :: [Member] -> String -> String
showList :: [Member] -> String -> String
Show)

data StructDecl = StructDecl
  { StructDecl -> Name
structName :: !Name,
    StructDecl -> Description
structDescription :: !Description,
    StructDecl -> Word64
structByteSize :: !Word64,
    StructDecl -> DeclLoc
structLoc :: !DeclLoc,
    StructDecl -> [Member]
structMembers :: ![Member]
  }
  deriving (Int -> StructDecl -> String -> String
[StructDecl] -> String -> String
StructDecl -> String
(Int -> StructDecl -> String -> String)
-> (StructDecl -> String)
-> ([StructDecl] -> String -> String)
-> Show StructDecl
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> StructDecl -> String -> String
showsPrec :: Int -> StructDecl -> String -> String
$cshow :: StructDecl -> String
show :: StructDecl -> String
$cshowList :: [StructDecl] -> String -> String
showList :: [StructDecl] -> String -> String
Show)

data UnionDecl = UnionDecl
  { UnionDecl -> Name
unionName :: !Name,
    UnionDecl -> Description
unionDescription :: !Description,
    UnionDecl -> Word64
unionByteSize :: !Word64,
    UnionDecl -> DeclLoc
unionLoc :: !DeclLoc,
    UnionDecl -> [Member]
unionMembers :: ![Member]
  }
  deriving (Int -> UnionDecl -> String -> String
[UnionDecl] -> String -> String
UnionDecl -> String
(Int -> UnionDecl -> String -> String)
-> (UnionDecl -> String)
-> ([UnionDecl] -> String -> String)
-> Show UnionDecl
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> UnionDecl -> String -> String
showsPrec :: Int -> UnionDecl -> String -> String
$cshow :: UnionDecl -> String
show :: UnionDecl -> String
$cshowList :: [UnionDecl] -> String -> String
showList :: [UnionDecl] -> String -> String
Show)

data EnumDecl = EnumDecl
  { EnumDecl -> Name
enumDeclName :: !Name,
    EnumDecl -> Description
enumDeclDescription :: !Description,
    EnumDecl -> Word64
enumDeclByteSize :: !Word64,
    EnumDecl -> DeclLoc
enumDeclLoc :: !DeclLoc,
    -- | The underlying type of an enum.
    EnumDecl -> Maybe TypeRef
enumDeclType :: !(Maybe TypeRef),
    EnumDecl -> [Enumerator]
enumDeclCases :: ![Enumerator]
  }
  deriving (Int -> EnumDecl -> String -> String
[EnumDecl] -> String -> String
EnumDecl -> String
(Int -> EnumDecl -> String -> String)
-> (EnumDecl -> String)
-> ([EnumDecl] -> String -> String)
-> Show EnumDecl
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> EnumDecl -> String -> String
showsPrec :: Int -> EnumDecl -> String -> String
$cshow :: EnumDecl -> String
show :: EnumDecl -> String
$cshowList :: [EnumDecl] -> String -> String
showList :: [EnumDecl] -> String -> String
Show)

data SubroutineTypeDecl = SubroutineTypeDecl
  { SubroutineTypeDecl -> Maybe Bool
fntypePrototyped :: !(Maybe Bool),
    SubroutineTypeDecl -> [Variable]
fntypeFormals :: ![Variable],
    SubroutineTypeDecl -> Maybe TypeRef
fntypeType :: !(Maybe TypeRef)
  }
  deriving (Int -> SubroutineTypeDecl -> String -> String
[SubroutineTypeDecl] -> String -> String
SubroutineTypeDecl -> String
(Int -> SubroutineTypeDecl -> String -> String)
-> (SubroutineTypeDecl -> String)
-> ([SubroutineTypeDecl] -> String -> String)
-> Show SubroutineTypeDecl
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> SubroutineTypeDecl -> String -> String
showsPrec :: Int -> SubroutineTypeDecl -> String -> String
$cshow :: SubroutineTypeDecl -> String
show :: SubroutineTypeDecl -> String
$cshowList :: [SubroutineTypeDecl] -> String -> String
showList :: [SubroutineTypeDecl] -> String -> String
Show)

data Typedef = Typedef
  { Typedef -> Name
typedefName :: !Name,
    Typedef -> Description
typedefDescription :: !Description,
    Typedef -> DeclLoc
typedefLoc :: !DeclLoc,
    Typedef -> TypeRef
typedefType :: !TypeRef
  }
  deriving (Int -> Typedef -> String -> String
[Typedef] -> String -> String
Typedef -> String
(Int -> Typedef -> String -> String)
-> (Typedef -> String)
-> ([Typedef] -> String -> String)
-> Show Typedef
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Typedef -> String -> String
showsPrec :: Int -> Typedef -> String -> String
$cshow :: Typedef -> String
show :: Typedef -> String
$cshowList :: [Typedef] -> String -> String
showList :: [Typedef] -> String -> String
Show)

parseMember :: FileVec -> DIE -> Parser Member
parseMember :: FileVec -> DIE -> Parser Member
parseMember FileVec
fileVec DIE
d = String -> DIE -> DIEParser Member -> Parser Member
forall r. String -> DIE -> DIEParser r -> Parser r
runDIEParser String
"parseMember" DIE
d (DIEParser Member -> Parser Member)
-> DIEParser Member -> Parser Member
forall a b. (a -> b) -> a -> b
$ do
  DW_TAG -> DIEParser ()
checkTag DW_TAG
DW_TAG_member
  (name, desc) <- DIEParser (Name, Description)
getNameAndDescription
  tp <- getSingleAttribute DW_AT_type attributeAsTypeRef
  memLoc <- getMaybeAttribute DW_AT_data_member_location attributeAsUInt
  artificial <- getAttributeWithDefault DW_AT_artificial False attributeAsBool
  dloc <- parseDeclLoc fileVec

  byteSize <- getMaybeAttribute DW_AT_byte_size attributeAsUInt
  bitOff <- getMaybeAttribute DW_AT_bit_offset attributeAsUInt
  bitSize <- getMaybeAttribute DW_AT_bit_size attributeAsUInt

  pure
    $! Member
      { memberName = name,
        memberDescription = desc,
        memberDeclLoc = dloc,
        memberLoc = memLoc,
        memberType = tp,
        memberArtificial = artificial,
        memberByteSize = byteSize,
        memberBitOffset = bitOff,
        memberBitSize = bitSize
      }

attributeAsTypeRef :: AttrParser TypeRef
attributeAsTypeRef :: AttrParser TypeRef
attributeAsTypeRef Reader
_ (DW_ATVAL_REF DieID
r) = TypeRef -> ExceptT AttrError Identity TypeRef
forall a. a -> ExceptT AttrError Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (DieID -> TypeRef
TypeRef DieID
r)
attributeAsTypeRef Reader
_ DW_ATVAL
_ = AttrError -> ExceptT AttrError Identity TypeRef
forall a. AttrError -> ExceptT AttrError Identity a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (AttrError -> ExceptT AttrError Identity TypeRef)
-> AttrError -> ExceptT AttrError Identity TypeRef
forall a b. (a -> b) -> a -> b
$ ByteString -> AttrError
IncorrectTypeFor ByteString
"type reference"

-- | A qualifier on a type.
data TypeQual
  = ConstQual
  | VolatileQual
  | RestrictQual
  deriving (Int -> TypeQual -> String -> String
[TypeQual] -> String -> String
TypeQual -> String
(Int -> TypeQual -> String -> String)
-> (TypeQual -> String)
-> ([TypeQual] -> String -> String)
-> Show TypeQual
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> TypeQual -> String -> String
showsPrec :: Int -> TypeQual -> String -> String
$cshow :: TypeQual -> String
show :: TypeQual -> String
$cshowList :: [TypeQual] -> String -> String
showList :: [TypeQual] -> String -> String
Show)

-- | A type qualifier annotation.
data TypeQualAnn = TypeQualAnn
  { TypeQualAnn -> TypeQual
tqaTypeQual :: !TypeQual,
    TypeQualAnn -> Name
tqaName :: !Name,
    TypeQualAnn -> Description
tqaDescription :: !Description,
    TypeQualAnn -> DeclLoc
tqaDeclLoc :: !DeclLoc,
    TypeQualAnn -> Word64
tqaAlign :: !Word64,
    TypeQualAnn -> Maybe TypeRef
tqaType :: !(Maybe TypeRef)
  }
  deriving (Int -> TypeQualAnn -> String -> String
[TypeQualAnn] -> String -> String
TypeQualAnn -> String
(Int -> TypeQualAnn -> String -> String)
-> (TypeQualAnn -> String)
-> ([TypeQualAnn] -> String -> String)
-> Show TypeQualAnn
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> TypeQualAnn -> String -> String
showsPrec :: Int -> TypeQualAnn -> String -> String
$cshow :: TypeQualAnn -> String
show :: TypeQualAnn -> String
$cshowList :: [TypeQualAnn] -> String -> String
showList :: [TypeQualAnn] -> String -> String
Show)

-- | A type form
data TypeApp
  = -- | A 1-byte boolean value (0 is false, nonzero is true)
    BoolType
  | -- | An unsigned integer with the given number of bytes (should be positive)
    -- The byte order is platform defined.
    UnsignedIntType !Int
  | -- | An signed integer with the given number of bytes (should be positive)
    -- The byte order is platform defined.
    SignedIntType !Int
  | -- | An IEEE single precision floating point value.
    FloatType
  | -- | An IEEE double precision floating point value.
    DoubleType
  | -- | A long double type.
    LongDoubleType
  | -- | A 1-byte unsigned character.
    UnsignedCharType
  | -- | A 1-byte signed character.
    SignedCharType
  | ArrayType !TypeRef ![Subrange TypeRef]
  | -- | @PointerType mw mtp@ describes a pointer where @mtp@ is
    -- the type that the pointer points to (or 'Nothing') to indicate
    -- this is a void pointer.  @mw@ is the number of bytes the pointer
    -- occupies or @Nothing@ to indicate that is omitted.
    PointerType !(Maybe Word64) !(Maybe TypeRef)
  | -- | Denotes a C struct
    StructType !StructDecl
  | -- | Denotes a C union
    UnionType !UnionDecl
  | EnumType !EnumDecl
  | SubroutinePtrType !SubroutineTypeDecl
  | TypedefType !Typedef
  | -- | Restrict modifier on type.
    TypeQualType !TypeQualAnn
  | -- | Subroutine type
    SubroutineTypeF !SubroutineTypeDecl
  deriving (Int -> TypeApp -> String -> String
[TypeApp] -> String -> String
TypeApp -> String
(Int -> TypeApp -> String -> String)
-> (TypeApp -> String)
-> ([TypeApp] -> String -> String)
-> Show TypeApp
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> TypeApp -> String -> String
showsPrec :: Int -> TypeApp -> String -> String
$cshow :: TypeApp -> String
show :: TypeApp -> String
$cshowList :: [TypeApp] -> String -> String
showList :: [TypeApp] -> String -> String
Show)

-- | A type parser takes the file vector and returns either a `TypeF` or `Nothing`.
--
-- The nothing value is returned, because `DW_TAG_const_type` with no `DW_AT_type`
-- attribute.
type TypeParser = FileVec -> DIEParser TypeApp

parseBaseType :: TypeParser
parseBaseType :: TypeParser
parseBaseType FileVec
_ = do
  (name, _) <- DIEParser (Name, Description)
getNameAndDescription
  enc <- getSingleAttribute DW_AT_encoding attributeAsBaseTypeEncoding
  size <- getSingleAttribute DW_AT_byte_size attributeAsUInt
  case (name, enc, size) of
    (Name
_, DW_ATE
DW_ATE_boolean, Word64
1) -> TypeApp -> StateT DIEParserState Parser TypeApp
forall a. a -> StateT DIEParserState Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TypeApp -> StateT DIEParserState Parser TypeApp)
-> TypeApp -> StateT DIEParserState Parser TypeApp
forall a b. (a -> b) -> a -> b
$ TypeApp
BoolType
    (Name
_, DW_ATE
DW_ATE_signed, Word64
_) | Word64
size Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
1 -> TypeApp -> StateT DIEParserState Parser TypeApp
forall a. a -> StateT DIEParserState Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TypeApp -> StateT DIEParserState Parser TypeApp)
-> TypeApp -> StateT DIEParserState Parser TypeApp
forall a b. (a -> b) -> a -> b
$ Int -> TypeApp
SignedIntType (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
size)
    (Name
_, DW_ATE
DW_ATE_unsigned, Word64
_) | Word64
size Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
1 -> TypeApp -> StateT DIEParserState Parser TypeApp
forall a. a -> StateT DIEParserState Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TypeApp -> StateT DIEParserState Parser TypeApp)
-> TypeApp -> StateT DIEParserState Parser TypeApp
forall a b. (a -> b) -> a -> b
$ Int -> TypeApp
UnsignedIntType (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
size)
    (Name
_, DW_ATE
DW_ATE_float, Word64
4) -> TypeApp -> StateT DIEParserState Parser TypeApp
forall a. a -> StateT DIEParserState Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TypeApp -> StateT DIEParserState Parser TypeApp)
-> TypeApp -> StateT DIEParserState Parser TypeApp
forall a b. (a -> b) -> a -> b
$! TypeApp
FloatType
    (Name
_, DW_ATE
DW_ATE_float, Word64
8) -> TypeApp -> StateT DIEParserState Parser TypeApp
forall a. a -> StateT DIEParserState Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TypeApp -> StateT DIEParserState Parser TypeApp)
-> TypeApp -> StateT DIEParserState Parser TypeApp
forall a b. (a -> b) -> a -> b
$! TypeApp
DoubleType
    (Name
"long double", DW_ATE
DW_ATE_float, Word64
16) -> TypeApp -> StateT DIEParserState Parser TypeApp
forall a. a -> StateT DIEParserState Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TypeApp -> StateT DIEParserState Parser TypeApp)
-> TypeApp -> StateT DIEParserState Parser TypeApp
forall a b. (a -> b) -> a -> b
$! TypeApp
LongDoubleType
    (Name
_, DW_ATE
DW_ATE_signed_char, Word64
1) -> TypeApp -> StateT DIEParserState Parser TypeApp
forall a. a -> StateT DIEParserState Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TypeApp -> StateT DIEParserState Parser TypeApp)
-> TypeApp -> StateT DIEParserState Parser TypeApp
forall a b. (a -> b) -> a -> b
$! TypeApp
SignedCharType
    (Name
_, DW_ATE
DW_ATE_unsigned_char, Word64
1) -> TypeApp -> StateT DIEParserState Parser TypeApp
forall a. a -> StateT DIEParserState Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TypeApp -> StateT DIEParserState Parser TypeApp)
-> TypeApp -> StateT DIEParserState Parser TypeApp
forall a b. (a -> b) -> a -> b
$! TypeApp
UnsignedCharType
    (Name, DW_ATE, Word64)
_ -> String -> StateT DIEParserState Parser TypeApp
forall a. String -> StateT DIEParserState Parser a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (String -> StateT DIEParserState Parser TypeApp)
-> String -> StateT DIEParserState Parser TypeApp
forall a b. (a -> b) -> a -> b
$ String
"Unsupported base type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DW_ATE -> String
forall a. Show a => a -> String
show DW_ATE
enc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show Word64
size

parsePointerType :: TypeParser
parsePointerType :: TypeParser
parsePointerType FileVec
_ = do
  mtp <- DW_AT -> AttrParser TypeRef -> DIEParser (Maybe TypeRef)
forall v. DW_AT -> AttrParser v -> DIEParser (Maybe v)
getMaybeAttribute DW_AT
DW_AT_type AttrParser TypeRef
attributeAsTypeRef
  w <- getMaybeAttribute DW_AT_byte_size attributeAsUInt
  pure $! PointerType w mtp

parseStructureType :: TypeParser
parseStructureType :: TypeParser
parseStructureType FileVec
fileVec = do
  (name, desc) <- DIEParser (Name, Description)
getNameAndDescription
  byteSize <- getSingleAttribute DW_AT_byte_size attributeAsUInt
  dloc <- parseDeclLoc fileVec

  members <- parseChildrenList DW_TAG_member $ parseMember fileVec

  let struct =
        StructDecl
          { structName :: Name
structName = Name
name,
            structDescription :: Description
structDescription = Description
desc,
            structByteSize :: Word64
structByteSize = Word64
byteSize,
            structLoc :: DeclLoc
structLoc = DeclLoc
dloc,
            structMembers :: [Member]
structMembers = [Member]
members
          }
  pure $! StructType struct

parseUnionType :: TypeParser
parseUnionType :: TypeParser
parseUnionType FileVec
fileVec = do
  (name, desc) <- DIEParser (Name, Description)
getNameAndDescription
  byteSize <- getSingleAttribute DW_AT_byte_size attributeAsUInt
  dloc <- parseDeclLoc fileVec

  members <- parseChildrenList DW_TAG_member $ parseMember fileVec

  let u =
        UnionDecl
          { unionName :: Name
unionName = Name
name,
            unionDescription :: Description
unionDescription = Description
desc,
            unionByteSize :: Word64
unionByteSize = Word64
byteSize,
            unionLoc :: DeclLoc
unionLoc = DeclLoc
dloc,
            unionMembers :: [Member]
unionMembers = [Member]
members
          }
  pure $! UnionType u

parseTypedefType :: TypeParser
parseTypedefType :: TypeParser
parseTypedefType FileVec
fileVec = do
  (name, desc) <- DIEParser (Name, Description)
getNameAndDescription
  dloc <- parseDeclLoc fileVec
  tp <- getSingleAttribute DW_AT_type attributeAsTypeRef

  let td =
        Typedef
          { typedefName :: Name
typedefName = Name
name,
            typedefDescription :: Description
typedefDescription = Description
desc,
            typedefLoc :: DeclLoc
typedefLoc = DeclLoc
dloc,
            typedefType :: TypeRef
typedefType = TypeRef
tp
          }
  pure $! TypedefType td

parseArrayType :: TypeParser
parseArrayType :: TypeParser
parseArrayType FileVec
_ = do
  eltType <- DW_AT -> AttrParser TypeRef -> DIEParser TypeRef
forall v. DW_AT -> AttrParser v -> DIEParser v
getSingleAttribute DW_AT
DW_AT_type AttrParser TypeRef
attributeAsTypeRef

  sr <- parseChildrenList DW_TAG_subrange_type parseSubrange
  pure $! ArrayType eltType sr

parseEnumerationType :: TypeParser
parseEnumerationType :: TypeParser
parseEnumerationType FileVec
fileVec = do
  (name, desc) <- DIEParser (Name, Description)
getNameAndDescription
  byteSize <- getSingleAttribute DW_AT_byte_size attributeAsUInt
  dloc <- parseDeclLoc fileVec
  _enc <- getMaybeAttribute DW_AT_encoding attributeAsBaseTypeEncoding
  underlyingType <- getMaybeAttribute DW_AT_type attributeAsTypeRef
  cases <- parseChildrenList DW_TAG_enumerator parseEnumerator
  let e =
        EnumDecl
          { enumDeclName :: Name
enumDeclName = Name
name,
            enumDeclDescription :: Description
enumDeclDescription = Description
desc,
            enumDeclByteSize :: Word64
enumDeclByteSize = Word64
byteSize,
            enumDeclType :: Maybe TypeRef
enumDeclType = Maybe TypeRef
underlyingType,
            enumDeclLoc :: DeclLoc
enumDeclLoc = DeclLoc
dloc,
            enumDeclCases :: [Enumerator]
enumDeclCases = [Enumerator]
cases
          }
  pure $! EnumType e

-- | Parse a subroutine type.
parseSubroutineType :: TypeParser
parseSubroutineType :: TypeParser
parseSubroutineType FileVec
fileVec = do
  proto <- DW_AT -> AttrParser Bool -> DIEParser (Maybe Bool)
forall v. DW_AT -> AttrParser v -> DIEParser (Maybe v)
getMaybeAttribute DW_AT
DW_AT_prototyped AttrParser Bool
attributeAsBool
  formals <- parseParameters fileVec

  tp <- getMaybeAttribute DW_AT_type attributeAsTypeRef

  let sub =
        SubroutineTypeDecl
          { fntypePrototyped :: Maybe Bool
fntypePrototyped = Maybe Bool
proto,
            fntypeFormals :: [Variable]
fntypeFormals = [Variable]
formals,
            fntypeType :: Maybe TypeRef
fntypeType = Maybe TypeRef
tp
          }
  pure $! SubroutineTypeF sub

parseTypeQualifier :: TypeQual -> TypeParser
parseTypeQualifier :: TypeQual -> TypeParser
parseTypeQualifier TypeQual
tq FileVec
fileVec = do
  (name, desc) <- DIEParser (Name, Description)
getNameAndDescription
  loc <- parseDeclLoc fileVec
  alignment <- getAttributeWithDefault DW_AT_alignment 0 attributeAsUInt
  mtp <- getMaybeAttribute DW_AT_type attributeAsTypeRef
  let ann =
        TypeQualAnn
          { tqaTypeQual :: TypeQual
tqaTypeQual = TypeQual
tq,
            tqaName :: Name
tqaName = Name
name,
            tqaDescription :: Description
tqaDescription = Description
desc,
            tqaDeclLoc :: DeclLoc
tqaDeclLoc = DeclLoc
loc,
            tqaAlign :: Word64
tqaAlign = Word64
alignment,
            tqaType :: Maybe TypeRef
tqaType = Maybe TypeRef
mtp
          }
  pure $! TypeQualType ann

typeParsers :: Map DW_TAG TypeParser
typeParsers :: Map DW_TAG TypeParser
typeParsers =
  [(DW_TAG, TypeParser)] -> Map DW_TAG TypeParser
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (,) DW_TAG
DW_TAG_base_type TypeParser
parseBaseType,
      (,) DW_TAG
DW_TAG_const_type (TypeQual -> TypeParser
parseTypeQualifier TypeQual
ConstQual),
      (,) DW_TAG
DW_TAG_volatile_type (TypeQual -> TypeParser
parseTypeQualifier TypeQual
VolatileQual),
      (,) DW_TAG
DW_TAG_restrict_type (TypeQual -> TypeParser
parseTypeQualifier TypeQual
RestrictQual),
      (,) DW_TAG
DW_TAG_pointer_type TypeParser
parsePointerType,
      (,) DW_TAG
DW_TAG_structure_type TypeParser
parseStructureType,
      (,) DW_TAG
DW_TAG_union_type TypeParser
parseUnionType,
      (,) DW_TAG
DW_TAG_typedef TypeParser
parseTypedefType,
      (,) DW_TAG
DW_TAG_array_type TypeParser
parseArrayType,
      (,) DW_TAG
DW_TAG_enumeration_type TypeParser
parseEnumerationType,
      (,) DW_TAG
DW_TAG_subroutine_type TypeParser
parseSubroutineType
    ]

type AbsType = (Either String TypeApp, [String])

-- | Parse a type given a vector identifying file vectors.
parseTypeMap ::
  Map TypeRef AbsType ->
  FileVec ->
  DIEParser (Map TypeRef AbsType)
parseTypeMap :: Map TypeRef AbsType -> FileVec -> DIEParser (Map TypeRef AbsType)
parseTypeMap Map TypeRef AbsType
preMap FileVec
fileVec = do
  (DW_TAG -> DIEParser ()) -> [DW_TAG] -> DIEParser ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ DW_TAG -> DIEParser ()
ignoreChild (Map DW_TAG TypeParser -> [DW_TAG]
forall k a. Map k a -> [k]
Map.keys Map DW_TAG TypeParser
typeParsers)
  dr <- Parser Reader -> StateT DIEParserState Parser Reader
forall (m :: Type -> Type) a.
Monad m =>
m a -> StateT DIEParserState m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Parser Reader -> StateT DIEParserState Parser Reader)
-> Parser Reader -> StateT DIEParserState Parser Reader
forall a b. (a -> b) -> a -> b
$ ReaderT ParserState (WarnT String Identity) Reader -> Parser Reader
forall r. ReaderT ParserState (WarnT String Identity) r -> Parser r
Parser (ReaderT ParserState (WarnT String Identity) Reader
 -> Parser Reader)
-> ReaderT ParserState (WarnT String Identity) Reader
-> Parser Reader
forall a b. (a -> b) -> a -> b
$ (ParserState -> Reader)
-> ReaderT ParserState (WarnT String Identity) Reader
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks ParserState -> Reader
readerInfo
  childMap <- gets dpsChildrenMap
  let insDIE ::
        TypeParser ->
        Map TypeRef AbsType ->
        DIE ->
        Map TypeRef AbsType
      insDIE TypeParser
act Map TypeRef AbsType
m DIE
d =
        TypeRef -> AbsType -> Map TypeRef AbsType -> Map TypeRef AbsType
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert
          (DieID -> TypeRef
TypeRef (DIE -> DieID
dieId DIE
d))
          (Reader -> Parser TypeApp -> AbsType
forall r. Reader -> Parser r -> (Either String r, [String])
runParser Reader
dr (String
-> DIE -> StateT DIEParserState Parser TypeApp -> Parser TypeApp
forall r. String -> DIE -> DIEParser r -> Parser r
runDIEParser String
"parseTypeF" DIE
d (TypeParser
act FileVec
fileVec)))
          Map TypeRef AbsType
m

  let insTagChildren ::
        Map TypeRef AbsType ->
        DW_TAG ->
        TypeParser ->
        Map TypeRef AbsType
      insTagChildren Map TypeRef AbsType
m DW_TAG
tag TypeParser
act =
        (Map TypeRef AbsType -> DIE -> Map TypeRef AbsType)
-> Map TypeRef AbsType -> [DIE] -> Map TypeRef AbsType
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (TypeParser -> Map TypeRef AbsType -> DIE -> Map TypeRef AbsType
insDIE TypeParser
act) Map TypeRef AbsType
m ([DIE] -> DW_TAG -> Map DW_TAG [DIE] -> [DIE]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] DW_TAG
tag Map DW_TAG [DIE]
childMap)

  pure $! Map.foldlWithKey' insTagChildren preMap typeParsers

------------------------------------------------------------------------
-- Location

data DwarfExpr = DwarfExpr !Dwarf.Reader !BS.ByteString

instance Eq DwarfExpr where
  DwarfExpr Reader
_ ByteString
x == :: DwarfExpr -> DwarfExpr -> Bool
== DwarfExpr Reader
_ ByteString
y = ByteString
x ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
y

instance Ord DwarfExpr where
  compare :: DwarfExpr -> DwarfExpr -> Ordering
compare (DwarfExpr Reader
_ ByteString
x) (DwarfExpr Reader
_ ByteString
y) = ByteString -> ByteString -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ByteString
x ByteString
y

instance Show DwarfExpr where
  show :: DwarfExpr -> String
show (DwarfExpr Reader
dr ByteString
bs) =
    case Reader
-> ByteString -> Either ([DW_OP], ByteOffset, String) [DW_OP]
Dwarf.parseDW_OPs Reader
dr ByteString
bs of
      Left ([DW_OP]
_, ByteOffset
_, String
msg) -> String
msg
      Right [DW_OP]
r -> [DW_OP] -> String
forall a. Show a => a -> String
show [DW_OP]
r

-- | Provides a way of computing the location of a variable.
data Location
  = ComputedLoc !DwarfExpr
  | OffsetLoc !Word64
  deriving (Location -> Location -> Bool
(Location -> Location -> Bool)
-> (Location -> Location -> Bool) -> Eq Location
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Location -> Location -> Bool
== :: Location -> Location -> Bool
$c/= :: Location -> Location -> Bool
/= :: Location -> Location -> Bool
Eq, Eq Location
Eq Location =>
(Location -> Location -> Ordering)
-> (Location -> Location -> Bool)
-> (Location -> Location -> Bool)
-> (Location -> Location -> Bool)
-> (Location -> Location -> Bool)
-> (Location -> Location -> Location)
-> (Location -> Location -> Location)
-> Ord Location
Location -> Location -> Bool
Location -> Location -> Ordering
Location -> Location -> Location
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Location -> Location -> Ordering
compare :: Location -> Location -> Ordering
$c< :: Location -> Location -> Bool
< :: Location -> Location -> Bool
$c<= :: Location -> Location -> Bool
<= :: Location -> Location -> Bool
$c> :: Location -> Location -> Bool
> :: Location -> Location -> Bool
$c>= :: Location -> Location -> Bool
>= :: Location -> Location -> Bool
$cmax :: Location -> Location -> Location
max :: Location -> Location -> Location
$cmin :: Location -> Location -> Location
min :: Location -> Location -> Location
Ord)

attributeAsLocation :: AttrParser Location
attributeAsLocation :: AttrParser Location
attributeAsLocation Reader
dr = \case
  DW_ATVAL_BLOB ByteString
b -> Location -> Except AttrError Location
forall a. a -> ExceptT AttrError Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (DwarfExpr -> Location
ComputedLoc (Reader -> ByteString -> DwarfExpr
DwarfExpr Reader
dr ByteString
b))
  DW_ATVAL_UINT Word64
w -> Location -> Except AttrError Location
forall a. a -> ExceptT AttrError Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Word64 -> Location
OffsetLoc Word64
w)
  DW_ATVAL
_ -> AttrError -> Except AttrError Location
forall a. AttrError -> ExceptT AttrError Identity a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (AttrError -> Except AttrError Location)
-> AttrError -> Except AttrError Location
forall a b. (a -> b) -> a -> b
$ ByteString -> AttrError
IncorrectTypeFor ByteString
"Location"

instance Pretty Location where
  pretty :: forall ann. Location -> Doc ann
pretty (ComputedLoc (DwarfExpr Reader
dr ByteString
bs)) =
    case Reader
-> ByteString -> Either ([DW_OP], ByteOffset, String) [DW_OP]
Dwarf.parseDW_OPs Reader
dr ByteString
bs of
      Left ([DW_OP]
_, ByteOffset
_, String
msg) -> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
msg
      Right [DW_OP]
ops -> [DW_OP] -> Doc ann
forall ann. [DW_OP] -> Doc ann
ppOps [DW_OP]
ops
  pretty (OffsetLoc Word64
w) = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String
"offset 0x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String -> String
forall a. Integral a => a -> String -> String
showHex Word64
w String
"")

------------------------------------------------------------------------
-- Variable

-- | A reference to a variable
newtype VariableRef = VariableRef DieID
  deriving (VariableRef -> VariableRef -> Bool
(VariableRef -> VariableRef -> Bool)
-> (VariableRef -> VariableRef -> Bool) -> Eq VariableRef
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: VariableRef -> VariableRef -> Bool
== :: VariableRef -> VariableRef -> Bool
$c/= :: VariableRef -> VariableRef -> Bool
/= :: VariableRef -> VariableRef -> Bool
Eq, Eq VariableRef
Eq VariableRef =>
(VariableRef -> VariableRef -> Ordering)
-> (VariableRef -> VariableRef -> Bool)
-> (VariableRef -> VariableRef -> Bool)
-> (VariableRef -> VariableRef -> Bool)
-> (VariableRef -> VariableRef -> Bool)
-> (VariableRef -> VariableRef -> VariableRef)
-> (VariableRef -> VariableRef -> VariableRef)
-> Ord VariableRef
VariableRef -> VariableRef -> Bool
VariableRef -> VariableRef -> Ordering
VariableRef -> VariableRef -> VariableRef
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: VariableRef -> VariableRef -> Ordering
compare :: VariableRef -> VariableRef -> Ordering
$c< :: VariableRef -> VariableRef -> Bool
< :: VariableRef -> VariableRef -> Bool
$c<= :: VariableRef -> VariableRef -> Bool
<= :: VariableRef -> VariableRef -> Bool
$c> :: VariableRef -> VariableRef -> Bool
> :: VariableRef -> VariableRef -> Bool
$c>= :: VariableRef -> VariableRef -> Bool
>= :: VariableRef -> VariableRef -> Bool
$cmax :: VariableRef -> VariableRef -> VariableRef
max :: VariableRef -> VariableRef -> VariableRef
$cmin :: VariableRef -> VariableRef -> VariableRef
min :: VariableRef -> VariableRef -> VariableRef
Ord)

instance Pretty VariableRef where
  pretty :: forall ann. VariableRef -> Doc ann
pretty (VariableRef (DieID Word64
w)) = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String
"0x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String -> String
forall a. Integral a => a -> String -> String
showHex Word64
w String
"")

data Variable = Variable
  { Variable -> DieID
varDieID :: !DieID,
    Variable -> Name
varName :: !Name,
    Variable -> Description
varDescription :: !Description,
    -- | Indicates if this variable is just a declaration
    Variable -> Bool
varDecl :: !Bool,
    Variable -> DeclLoc
varDeclLoc :: !DeclLoc,
    Variable -> Maybe TypeRef
varType :: !(Maybe TypeRef),
    Variable -> Maybe Location
varLocation :: !(Maybe Location),
    Variable -> Maybe ConstValue
varConstValue :: !(Maybe ConstValue),
    -- | A variable reference if this variable comes from an inlined function.
    Variable -> Maybe VariableRef
varOrigin :: !(Maybe VariableRef)
  }

instance Pretty Variable where
  pretty :: forall ann. Variable -> Doc ann
pretty Variable
v =
    [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat
      [ Doc ann
"name:    " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Name -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Name -> Doc ann
pretty (Variable -> Name
varName Variable
v),
        DeclLoc -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. DeclLoc -> Doc ann
pretty (Variable -> DeclLoc
varDeclLoc Variable
v),
        Doc ann
"type:    " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Maybe TypeRef -> Doc ann
forall ann. Maybe TypeRef -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Variable -> Maybe TypeRef
varType Variable
v),
        Doc ann -> (Location -> Doc ann) -> Maybe Location -> Doc ann
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Doc ann
"") (\Location
l -> Doc ann
"location:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Location -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Location -> Doc ann
pretty Location
l) (Variable -> Maybe Location
varLocation Variable
v)
      ]

instance Show Variable where
  show :: Variable -> String
show = Doc (ZonkAny 2) -> String
forall a. Show a => a -> String
show (Doc (ZonkAny 2) -> String)
-> (Variable -> Doc (ZonkAny 2)) -> Variable -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Variable -> Doc (ZonkAny 2)
forall a ann. Pretty a => a -> Doc ann
forall ann. Variable -> Doc ann
pretty

------------------------------------------------------------------------
-- Variable

parseVariableOrParameter :: String -> FileVec -> DIE -> Parser Variable
parseVariableOrParameter :: String -> FileVec -> DIE -> Parser Variable
parseVariableOrParameter String
nm FileVec
fileVec DIE
d =
  String -> DIE -> DIEParser Variable -> Parser Variable
forall r. String -> DIE -> DIEParser r -> Parser r
runDIEParser String
nm DIE
d (DIEParser Variable -> Parser Variable)
-> DIEParser Variable -> Parser Variable
forall a b. (a -> b) -> a -> b
$ do
    mloc <- DW_AT -> AttrParser Location -> DIEParser (Maybe Location)
forall v. DW_AT -> AttrParser v -> DIEParser (Maybe v)
getMaybeAttribute DW_AT
DW_AT_location AttrParser Location
attributeAsLocation
    (name, desc) <- getNameAndDescription
    dloc <- parseDeclLoc fileVec
    mvarType <- getMaybeAttribute DW_AT_type attributeAsTypeRef

    constVal <- getConstValue

    decl <- getAttributeWithDefault DW_AT_declaration False attributeAsBool
    _exte <- getMaybeAttribute DW_AT_external attributeAsBool

    ignoreAttribute DW_AT_artificial
    ignoreAttribute DW_AT_specification
    originDieID <- getMaybeAttribute DW_AT_abstract_origin attributeAsDieID

    pure
      $! Variable
        { varDieID = dieId d,
          varName = name,
          varDescription = desc,
          varDecl = decl,
          varDeclLoc = dloc,
          varType = mvarType,
          varLocation = mloc,
          varConstValue = constVal,
          varOrigin = VariableRef <$> originDieID
        }

parseVariables :: FileVec -> DIEParser [Variable]
parseVariables :: FileVec -> DIEParser [Variable]
parseVariables FileVec
fileVec = do
  DW_TAG -> (DIE -> Parser Variable) -> DIEParser [Variable]
forall v. DW_TAG -> (DIE -> Parser v) -> DIEParser [v]
parseChildrenList DW_TAG
DW_TAG_variable ((DIE -> Parser Variable) -> DIEParser [Variable])
-> (DIE -> Parser Variable) -> DIEParser [Variable]
forall a b. (a -> b) -> a -> b
$
    String -> FileVec -> DIE -> Parser Variable
parseVariableOrParameter String
"parseVariable" FileVec
fileVec

parseParameters :: FileVec -> DIEParser [Variable]
parseParameters :: FileVec -> DIEParser [Variable]
parseParameters FileVec
fileVec = do
  DW_TAG -> (DIE -> Parser Variable) -> DIEParser [Variable]
forall v. DW_TAG -> (DIE -> Parser v) -> DIEParser [v]
parseChildrenList DW_TAG
DW_TAG_formal_parameter ((DIE -> Parser Variable) -> DIEParser [Variable])
-> (DIE -> Parser Variable) -> DIEParser [Variable]
forall a b. (a -> b) -> a -> b
$
    String -> FileVec -> DIE -> Parser Variable
parseVariableOrParameter String
"parseParameter" FileVec
fileVec

------------------------------------------------------------------------
-- Subprogram

-- | A reference to a subprogram.
newtype SubprogramRef = SubprogramRef DieID
  deriving (SubprogramRef -> SubprogramRef -> Bool
(SubprogramRef -> SubprogramRef -> Bool)
-> (SubprogramRef -> SubprogramRef -> Bool) -> Eq SubprogramRef
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SubprogramRef -> SubprogramRef -> Bool
== :: SubprogramRef -> SubprogramRef -> Bool
$c/= :: SubprogramRef -> SubprogramRef -> Bool
/= :: SubprogramRef -> SubprogramRef -> Bool
Eq, Eq SubprogramRef
Eq SubprogramRef =>
(SubprogramRef -> SubprogramRef -> Ordering)
-> (SubprogramRef -> SubprogramRef -> Bool)
-> (SubprogramRef -> SubprogramRef -> Bool)
-> (SubprogramRef -> SubprogramRef -> Bool)
-> (SubprogramRef -> SubprogramRef -> Bool)
-> (SubprogramRef -> SubprogramRef -> SubprogramRef)
-> (SubprogramRef -> SubprogramRef -> SubprogramRef)
-> Ord SubprogramRef
SubprogramRef -> SubprogramRef -> Bool
SubprogramRef -> SubprogramRef -> Ordering
SubprogramRef -> SubprogramRef -> SubprogramRef
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SubprogramRef -> SubprogramRef -> Ordering
compare :: SubprogramRef -> SubprogramRef -> Ordering
$c< :: SubprogramRef -> SubprogramRef -> Bool
< :: SubprogramRef -> SubprogramRef -> Bool
$c<= :: SubprogramRef -> SubprogramRef -> Bool
<= :: SubprogramRef -> SubprogramRef -> Bool
$c> :: SubprogramRef -> SubprogramRef -> Bool
> :: SubprogramRef -> SubprogramRef -> Bool
$c>= :: SubprogramRef -> SubprogramRef -> Bool
>= :: SubprogramRef -> SubprogramRef -> Bool
$cmax :: SubprogramRef -> SubprogramRef -> SubprogramRef
max :: SubprogramRef -> SubprogramRef -> SubprogramRef
$cmin :: SubprogramRef -> SubprogramRef -> SubprogramRef
min :: SubprogramRef -> SubprogramRef -> SubprogramRef
Ord)

instance Pretty SubprogramRef where
  pretty :: forall ann. SubprogramRef -> Doc ann
pretty (SubprogramRef (DieID Word64
d)) = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String
"0x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String -> String
forall a. Integral a => a -> String -> String
showHex Word64
d String
"")

data SubprogramDef = SubprogramDef
  { SubprogramDef -> Maybe Word64
subLowPC :: !(Maybe Word64),
    SubprogramDef -> Maybe Word64
subHighPC :: !(Maybe Word64),
    SubprogramDef -> Maybe DwarfExpr
subFrameBase :: !(Maybe DwarfExpr),
    SubprogramDef -> Maybe Bool
subGNUAllCallSites :: !(Maybe Bool)
  }

instance Pretty SubprogramDef where
  pretty :: forall ann. SubprogramDef -> Doc ann
pretty SubprogramDef
d =
    [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat
      [ Doc ann
"low_pc:     " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> (Word64 -> String) -> Maybe Word64 -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"UNDEF" (Word64 -> String -> String
forall a. Integral a => a -> String -> String
`showHex` String
"") (SubprogramDef -> Maybe Word64
subLowPC SubprogramDef
d)),
        Doc ann
"high_pc:    " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> (Word64 -> String) -> Maybe Word64 -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"UNDEF" (Word64 -> String -> String
forall a. Integral a => a -> String -> String
`showHex` String
"") (SubprogramDef -> Maybe Word64
subHighPC SubprogramDef
d)),
        Doc ann
"frame_base: " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Maybe DwarfExpr -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow (SubprogramDef -> Maybe DwarfExpr
subFrameBase SubprogramDef
d),
        Doc ann
"GNU_all_call_sites: " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Maybe Bool -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow (SubprogramDef -> Maybe Bool
subGNUAllCallSites SubprogramDef
d)
      ]

-- | Get `DW_AT_GNU_all_tail_call_sites`
getAllTailCallSites :: DIEParser Bool
getAllTailCallSites :: DIEParser Bool
getAllTailCallSites = DW_AT -> Bool -> AttrParser Bool -> DIEParser Bool
forall v. DW_AT -> v -> AttrParser v -> DIEParser v
getAttributeWithDefault DW_AT
DW_AT_GNU_all_tail_call_sites Bool
False AttrParser Bool
attributeAsBool

parseSubprogramDef :: DIEParser SubprogramDef
parseSubprogramDef :: DIEParser SubprogramDef
parseSubprogramDef = do
  dr <- Parser Reader -> StateT DIEParserState Parser Reader
forall (m :: Type -> Type) a.
Monad m =>
m a -> StateT DIEParserState m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Parser Reader -> StateT DIEParserState Parser Reader)
-> Parser Reader -> StateT DIEParserState Parser Reader
forall a b. (a -> b) -> a -> b
$ ReaderT ParserState (WarnT String Identity) Reader -> Parser Reader
forall r. ReaderT ParserState (WarnT String Identity) r -> Parser r
Parser (ReaderT ParserState (WarnT String Identity) Reader
 -> Parser Reader)
-> ReaderT ParserState (WarnT String Identity) Reader
-> Parser Reader
forall a b. (a -> b) -> a -> b
$ (ParserState -> Reader)
-> ReaderT ParserState (WarnT String Identity) Reader
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks ParserState -> Reader
readerInfo
  lowPC <- getMaybeAttribute DW_AT_low_pc attributeAsUInt
  highPC <- getMaybeAttribute DW_AT_high_pc attributeAsUInt
  frameBase <- getMaybeAttribute DW_AT_frame_base attributeAsBlob
  callSites <- getMaybeAttribute DW_AT_GNU_all_call_sites attributeAsBool
  ignoreChild DW_TAG_lexical_block
  ignoreChild DW_TAG_GNU_call_site
  ignoreChild DW_TAG_inlined_subroutine
  pure $
    SubprogramDef
      { subLowPC = lowPC,
        subHighPC = highPC,
        subFrameBase = DwarfExpr dr <$> frameBase,
        subGNUAllCallSites = callSites
      }

data Subprogram = Subprogram
  { Subprogram -> Name
subName :: !Name,
    Subprogram -> Description
subDescription :: !Description,
    Subprogram -> ByteString
subLinkageName :: !BS.ByteString,
    Subprogram -> Bool
subExternal :: !Bool,
    -- | Origin for inlined functions.
    Subprogram -> Maybe SubprogramRef
subOrigin :: !(Maybe SubprogramRef),
    -- | Indicates this is a declaration and not a defining declaration.
    Subprogram -> Bool
subIsDeclaration :: !Bool,
    Subprogram -> Maybe Word64
subEntryPC :: !(Maybe Word64),
    Subprogram -> Bool
subArtificial :: !Bool,
    Subprogram -> Bool
subGNUAllTailCallSites :: !Bool,
    Subprogram -> DeclLoc
subDeclLoc :: !DeclLoc,
    Subprogram -> Bool
subPrototyped :: !Bool,
    Subprogram -> Maybe SubprogramDef
subDef :: !(Maybe SubprogramDef),
    Subprogram -> Map VariableRef Variable
subVars :: !(Map VariableRef Variable),
    -- | Maps variable ref to subprogram variable.
    --
    -- Note. Parameters offsets are ordered so in-order
    -- traversal of map is order of parameters.
    Subprogram -> Map VariableRef Variable
subParamMap :: !(Map VariableRef Variable),
    Subprogram -> Bool
subUnspecifiedParams :: !Bool,
    Subprogram -> Maybe TypeRef
subRetType :: !(Maybe TypeRef),
    -- | Flag indicating function declared with
    -- "noreturn" attribute
    Subprogram -> Bool
subNoreturn :: !Bool,
    -- | Type map for resolving types in subprogram.
    Subprogram -> Map TypeRef AbsType
subTypeMap :: !(Map TypeRef AbsType)
  }

instance Pretty Subprogram where
  pretty :: forall ann. Subprogram -> Doc ann
pretty Subprogram
sub =
    [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat
      [ Doc ann
"name:       " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Name -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Name -> Doc ann
pretty (Subprogram -> Name
subName Subprogram
sub),
        Doc ann
"external:   " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Bool -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow (Subprogram -> Bool
subExternal Subprogram
sub),
        DeclLoc -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. DeclLoc -> Doc ann
pretty (Subprogram -> DeclLoc
subDeclLoc Subprogram
sub),
        Doc ann
"prototyped: " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Bool -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow (Subprogram -> Bool
subPrototyped Subprogram
sub),
        Doc ann
-> (SubprogramDef -> Doc ann) -> Maybe SubprogramDef -> Doc ann
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Doc ann
"") SubprogramDef -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. SubprogramDef -> Doc ann
pretty (Subprogram -> Maybe SubprogramDef
subDef Subprogram
sub),
        String -> [Doc ann] -> Doc ann
forall ann. String -> [Doc ann] -> Doc ann
ppList String
"variables" (Variable -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Variable -> Doc ann
pretty (Variable -> Doc ann) -> [Variable] -> [Doc ann]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Map VariableRef Variable -> [Variable]
forall k a. Map k a -> [a]
Map.elems (Subprogram -> Map VariableRef Variable
subVars Subprogram
sub)),
        String -> [Doc ann] -> Doc ann
forall ann. String -> [Doc ann] -> Doc ann
ppList String
"parameters" (Variable -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Variable -> Doc ann
pretty (Variable -> Doc ann) -> [Variable] -> [Doc ann]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Map VariableRef Variable -> [Variable]
forall k a. Map k a -> [a]
Map.elems (Subprogram -> Map VariableRef Variable
subParamMap Subprogram
sub)),
        Doc ann
"return type: " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Maybe TypeRef -> Doc ann
forall ann. Maybe TypeRef -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Subprogram -> Maybe TypeRef
subRetType Subprogram
sub)
      ]

instance Show Subprogram where
  show :: Subprogram -> String
show = Doc (ZonkAny 1) -> String
forall a. Show a => a -> String
show (Doc (ZonkAny 1) -> String)
-> (Subprogram -> Doc (ZonkAny 1)) -> Subprogram -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Subprogram -> Doc (ZonkAny 1)
forall a ann. Pretty a => a -> Doc ann
forall ann. Subprogram -> Doc ann
pretty

isInlined :: DW_INL -> Parser Bool
isInlined :: DW_INL -> Parser Bool
isInlined DW_INL
inl =
  case DW_INL
inl of
    DW_INL
DW_INL_not_inlined -> Bool -> Parser Bool
forall a. a -> Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Bool
False
    DW_INL
DW_INL_inlined -> Bool -> Parser Bool
forall a. a -> Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Bool
True
    DW_INL
DW_INL_declared_not_inlined -> Bool -> Parser Bool
forall a. a -> Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Bool
False
    DW_INL
DW_INL_declared_inlined -> Bool -> Parser Bool
forall a. a -> Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Bool
True
    DW_INL
_ -> do
      String -> Parser ()
forall s (m :: Type -> Type). WarnMonad s m => s -> m ()
warn String
"Unexpected inline attribute."
      Bool -> Parser Bool
forall a. a -> Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Bool
False

-- | For some reason, DW_AT_linkage_name is duplicated in some elf files,
-- so we handle this specially.
getLinkageName :: DIEParser BS.ByteString
getLinkageName :: StateT DIEParserState Parser ByteString
getLinkageName = do
  let attrName :: DW_AT
attrName = DW_AT
DW_AT_linkage_name
  DW_AT -> DIEParser ()
ignoreAttribute DW_AT
attrName
  m <- (DIEParserState -> Map DW_AT [DW_ATVAL])
-> StateT DIEParserState Parser (Map DW_AT [DW_ATVAL])
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets DIEParserState -> Map DW_AT [DW_ATVAL]
dpsAttributeMap
  case Map.findWithDefault [] attrName m of
    [] -> do
      ByteString -> StateT DIEParserState Parser ByteString
forall a. a -> StateT DIEParserState Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ByteString
BS.empty
    DW_ATVAL
v : [DW_ATVAL]
r -> do
      d <- (DIEParserState -> DIE) -> StateT DIEParserState Parser DIE
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets DIEParserState -> DIE
dpsDIE
      linkageName <- lift $ convertAttribute attrName attributeAsString v
      forM_ r $ \DW_ATVAL
rv -> do
        case DW_ATVAL
rv of
          DW_ATVAL_STRING ByteString
rvs | ByteString
rvs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
linkageName -> () -> DIEParser ()
forall a. a -> StateT DIEParserState Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
          DW_ATVAL
_ -> String -> DIEParser ()
forall a. String -> StateT DIEParserState Parser a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (String -> DIEParser ()) -> String -> DIEParser ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Found distinct attributes for %s in %d." (DW_AT -> String
forall a. Show a => a -> String
show DW_AT
attrName) (DIE -> String
forall a. Show a => a -> String
show DIE
d)
      pure linkageName

getInlineAttribute :: DIEParser DW_INL
getInlineAttribute :: DIEParser DW_INL
getInlineAttribute =
  DW_AT -> DW_INL -> AttrParser DW_INL -> DIEParser DW_INL
forall v. DW_AT -> v -> AttrParser v -> DIEParser v
getAttributeWithDefault DW_AT
DW_AT_inline DW_INL
DW_INL_not_inlined ((Word64 -> DW_INL) -> AttrParser Word64 -> AttrParser DW_INL
forall a b. (a -> b) -> AttrParser a -> AttrParser b
mapAttr Word64 -> DW_INL
DW_INL AttrParser Word64
attributeAsUInt)

-- | Parse a subprogram
--
-- Tag has type `DW_TAG_subprogram`
parseSubprogram ::
  FileVec ->
  Map TypeRef AbsType ->
  DIE ->
  Parser Subprogram
parseSubprogram :: FileVec -> Map TypeRef AbsType -> DIE -> Parser Subprogram
parseSubprogram FileVec
fileVec Map TypeRef AbsType
typeMap DIE
d = String -> DIE -> DIEParser Subprogram -> Parser Subprogram
forall r. String -> DIE -> DIEParser r -> Parser r
runDIEParser String
"parseSubprogram" DIE
d (DIEParser Subprogram -> Parser Subprogram)
-> DIEParser Subprogram -> Parser Subprogram
forall a b. (a -> b) -> a -> b
$ do
  DW_TAG -> DIEParser ()
checkTag DW_TAG
DW_TAG_subprogram
  ext <- DW_AT -> Bool -> AttrParser Bool -> DIEParser Bool
forall v. DW_AT -> v -> AttrParser v -> DIEParser v
getAttributeWithDefault DW_AT
DW_AT_external Bool
False AttrParser Bool
attributeAsBool
  decl <- getAttributeWithDefault DW_AT_declaration False attributeAsBool

  inl <- getInlineAttribute
  inlined <- lift $ isInlined inl

  originDieID <- getMaybeAttribute DW_AT_abstract_origin attributeAsDieID

  def <-
    if decl || inlined
      then pure Nothing
      else do
        Just <$> parseSubprogramDef

  (name, desc) <- getNameAndDescription
  linkageName <- getLinkageName
  prototyped <- getAttributeWithDefault DW_AT_prototyped False attributeAsBool
  artificial <- getAttributeWithDefault DW_AT_artificial False attributeAsBool
  dloc <- parseDeclLoc fileVec

  typeMap' <- parseTypeMap typeMap fileVec
  vars <- parseVariables fileVec
  -- DW_TAG_formal_paramters children
  params <- parseParameters fileVec
  hasUnspecifiedParams <- hasChildren DW_TAG_unspecified_parameters

  entryPC <- getMaybeAttribute DW_AT_entry_pc attributeAsUInt

  retType <- getMaybeAttribute DW_AT_type attributeAsTypeRef
  noreturn <- getAttributeWithDefault DW_AT_noreturn False attributeAsBool

  allTailCallSites <- getAllTailCallSites

  ignoreAttribute DW_AT_type
  ignoreChild DW_TAG_label
  ignoreChild DW_TAG_lexical_block
  pure
    $! Subprogram
      { subName = name,
        subDescription = desc,
        subLinkageName = linkageName,
        subExternal = ext,
        subOrigin = SubprogramRef <$> originDieID,
        subIsDeclaration = decl,
        subEntryPC = entryPC,
        subArtificial = artificial,
        subGNUAllTailCallSites = allTailCallSites,
        subDeclLoc = dloc,
        subPrototyped = prototyped,
        subDef = def,
        subVars = Map.fromList [(VariableRef (varDieID v), v) | v <- vars],
        subParamMap = Map.fromList [(VariableRef (varDieID v), v) | v <- params],
        subUnspecifiedParams = hasUnspecifiedParams,
        subRetType = retType,
        subNoreturn = noreturn,
        subTypeMap = typeMap'
      }

-- CompileUnit

-- | The output of one compilation.
data CompileUnit = CompileUnit
  { CompileUnit -> CUContext
cuCtx :: !CUContext,
    CompileUnit -> ByteString
cuProducer :: !BS.ByteString,
    CompileUnit -> Maybe DW_LANG
cuLanguage :: Maybe DW_LANG,
    CompileUnit -> Name
cuName :: !Name,
    CompileUnit -> Description
cuDescription :: !Description,
    CompileUnit -> ByteString
cuCompDir :: !BS.ByteString,
    CompileUnit -> Maybe Word64
cuGNUMacros :: !(Maybe Word64),
    -- | Map from subprogram reference to a subprogram.
    CompileUnit -> Map SubprogramRef Subprogram
cuSubprogramMap :: !(Map SubprogramRef Subprogram),
    CompileUnit -> [Subprogram]
cuSubprograms :: ![Subprogram],
    -- | Global variables in this unit
    CompileUnit -> [Variable]
cuVariables :: ![Variable],
    CompileUnit -> Map TypeRef AbsType
cuTypeMap :: !(Map TypeRef AbsType),
    CompileUnit -> [Range]
cuRanges :: ![Dwarf.Range],
    CompileUnit -> [DW_LNE]
cuLNE :: ![DW_LNE],
    -- | File vector for file references.
    CompileUnit -> FileVec
cuFileVec :: !FileVec
  }

instance Show CompileUnit where
  show :: CompileUnit -> String
show = Doc (ZonkAny 0) -> String
forall a. Show a => a -> String
show (Doc (ZonkAny 0) -> String)
-> (CompileUnit -> Doc (ZonkAny 0)) -> CompileUnit -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompileUnit -> Doc (ZonkAny 0)
forall a ann. Pretty a => a -> Doc ann
forall ann. CompileUnit -> Doc ann
pretty

instance Pretty CompileUnit where
  pretty :: forall ann. CompileUnit -> Doc ann
pretty CompileUnit
cu =
    [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat
      [ Doc ann
"producer:    " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (ByteString -> String
BSC.unpack (CompileUnit -> ByteString
cuProducer CompileUnit
cu)),
        Doc ann
"language:    " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Maybe DW_LANG -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow (CompileUnit -> Maybe DW_LANG
cuLanguage CompileUnit
cu),
        Doc ann
"name:        " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Name -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Name -> Doc ann
pretty (CompileUnit -> Name
cuName CompileUnit
cu),
        Doc ann
"comp_dir:    " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (ByteString -> String
BSC.unpack (CompileUnit -> ByteString
cuCompDir CompileUnit
cu)),
        Doc ann
"GNU_macros:  " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Maybe Word64 -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow (CompileUnit -> Maybe Word64
cuGNUMacros CompileUnit
cu),
        String -> [Doc ann] -> Doc ann
forall ann. String -> [Doc ann] -> Doc ann
ppList String
"variables" (Variable -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Variable -> Doc ann
pretty (Variable -> Doc ann) -> [Variable] -> [Doc ann]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> CompileUnit -> [Variable]
cuVariables CompileUnit
cu),
        String -> [Doc ann] -> Doc ann
forall ann. String -> [Doc ann] -> Doc ann
ppList String
"subprograms" (Subprogram -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Subprogram -> Doc ann
pretty (Subprogram -> Doc ann) -> [Subprogram] -> [Doc ann]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> CompileUnit -> [Subprogram]
cuSubprograms CompileUnit
cu),
        String -> [Doc ann] -> Doc ann
forall ann. String -> [Doc ann] -> Doc ann
ppList String
"ranges" (Range -> Doc ann
forall ann. Range -> Doc ann
ppRange (Range -> Doc ann) -> [Range] -> [Doc ann]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> CompileUnit -> [Range]
cuRanges CompileUnit
cu)
      ]

ppList :: String -> [Doc ann] -> Doc ann
ppList :: forall ann. String -> [Doc ann] -> Doc ann
ppList String
nm [] = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
nm Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
": []"
ppList String
nm [Doc ann]
l = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat [String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
nm Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
colon, Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat [Doc ann]
l)]

-- | Return subprogram in compile unit
lookupSubprogram :: SubprogramRef -> CompileUnit -> Maybe Subprogram
lookupSubprogram :: SubprogramRef -> CompileUnit -> Maybe Subprogram
lookupSubprogram SubprogramRef
r CompileUnit
cu = SubprogramRef -> Map SubprogramRef Subprogram -> Maybe Subprogram
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SubprogramRef
r (CompileUnit -> Map SubprogramRef Subprogram
cuSubprogramMap CompileUnit
cu)

-- Section 7.20 - Address Range Table
-- Returns the ranges that belong to a CU
getAddressRangeTable ::
  Dwarf.Endianess ->
  Encoding ->
  BS.ByteString ->
  Parser [Dwarf.Range]
getAddressRangeTable :: Endianess -> Encoding -> ByteString -> Parser [Range]
getAddressRangeTable Endianess
end Encoding
enc ByteString
bs = ByteString -> Get [Range] -> Parser [Range]
forall a. ByteString -> Get a -> Parser a
parseGet ByteString
bs ([Range] -> Get [Range]
go [])
  where
    readAddress :: Get Word64
readAddress = Endianess -> Encoding -> Get Word64
desrGetOffset Endianess
end Encoding
enc
    go :: [Range] -> Get [Range]
go [Range]
prev = do
      r <- Word64 -> Word64 -> Range
Range (Word64 -> Word64 -> Range) -> Get Word64 -> Get (Word64 -> Range)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word64
readAddress Get (Word64 -> Range) -> Get Word64 -> Get Range
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Get Word64
readAddress
      if r /= Range 0 0
        then go (r : prev)
        else pure $! reverse prev

parseCompileUnit ::
  Dwarf.Sections ->
  (CUContext, DIE) ->
  (Either String CompileUnit, [String])
parseCompileUnit :: Sections
-> (CUContext, DIE) -> (Either String CompileUnit, [String])
parseCompileUnit Sections
secs (CUContext
ctx, DIE
d) =
  Reader
-> Parser CompileUnit -> (Either String CompileUnit, [String])
forall r. Reader -> Parser r -> (Either String r, [String])
runParser (CUContext -> Reader
cuReader CUContext
ctx) (Parser CompileUnit -> (Either String CompileUnit, [String]))
-> Parser CompileUnit -> (Either String CompileUnit, [String])
forall a b. (a -> b) -> a -> b
$
    String -> DIE -> DIEParser CompileUnit -> Parser CompileUnit
forall r. String -> DIE -> DIEParser r -> Parser r
runDIEParser String
"parseCompileUnit" DIE
d (DIEParser CompileUnit -> Parser CompileUnit)
-> DIEParser CompileUnit -> Parser CompileUnit
forall a b. (a -> b) -> a -> b
$ do
      let contents :: Sections
contents = CUContext -> Sections
cuSections CUContext
ctx
      DW_TAG -> DIEParser ()
checkTag DW_TAG
DW_TAG_compile_unit
      let dr :: Reader
dr = CUContext -> Reader
cuReader CUContext
ctx
      let end :: Endianess
end = Reader -> Endianess
drEndianess Reader
dr
      let tgt :: TargetSize
tgt = Reader -> TargetSize
drTarget64 Reader
dr
      prod <- DW_AT
-> AttrParser ByteString -> StateT DIEParserState Parser ByteString
forall v. DW_AT -> AttrParser v -> DIEParser v
getSingleAttribute DW_AT
DW_AT_producer AttrParser ByteString
attributeAsString
      lang <- getMaybeAttribute DW_AT_language attributeAsLang
      (name, desc) <- getNameAndDescription
      compDir <- getSingleAttribute DW_AT_comp_dir attributeAsString
      -- Get offset into .debug_line for this compile units line number information
      mStmtOffset <- getMaybeAttribute DW_AT_stmt_list attributeAsUInt
      (fileVec, lne) <-
        case mStmtOffset of
          Maybe Word64
Nothing -> (FileVec, [DW_LNE])
-> StateT DIEParserState Parser (FileVec, [DW_LNE])
forall a. a -> StateT DIEParserState Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (FileVec
forall a. Vector a
V.empty, [])
          Just Word64
offset -> do
            lines_bs <- Sections -> StateT DIEParserState Parser ByteString
forall (m :: Type -> Type). MonadFail m => Sections -> m ByteString
dsLineSection Sections
contents
            when (fromIntegral offset > BS.length lines_bs) $ do
              throwError "Illegal compile unit debug_line offset"
            let bs = Int -> ByteString -> ByteString
BS.drop (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
offset) ByteString
lines_bs
            (fileList, lne) <- lift $ parseGet bs (getLNE secs end tgt)
            pure (fmap DwarfFilePath (V.fromList fileList), lne)

      ranges <-
        if hasAttribute DW_AT_low_pc d
          then do
            lowPC <- getSingleAttribute DW_AT_low_pc attributeAsUInt
            if hasAttribute DW_AT_high_pc d
              then do
                highPC <- getSingleAttribute DW_AT_high_pc attributeAsUInt
                when (hasAttribute DW_AT_ranges d) $ do
                  throwError $ "Unexpected ranges"
                pure $! [Range lowPC (lowPC + highPC)]
              else do
                range_offset <- getSingleAttribute DW_AT_ranges attributeAsUInt
                ranges <- dsRangesSection contents
                lift $
                  getAddressRangeTable end (drEncoding dr) $
                    BS.drop (fromIntegral range_offset) ranges
          else do
            when (hasAttribute DW_AT_high_pc d) $ do
              throwError $ "Unexpected high_pc\n" ++ show d
            when (hasAttribute DW_AT_ranges d) $ do
              throwError $ "Unexpected ranges\n" ++ show d
            pure []
      -- The compile unit context already gets updated to use these during a parse
      ignoreAttribute DW_AT_str_offsets_base
      ignoreAttribute DW_AT_addr_base
      gnuMacros <- getMaybeAttribute DW_AT_GNU_macros attributeAsUInt
      -- Type map for children
      typeMap <- parseTypeMap Map.empty fileVec

      subprogramDies <- parseChildrenList DW_TAG_subprogram pure

      subprograms <- lift $ traverse (parseSubprogram fileVec typeMap) subprogramDies
      let subMap = [(SubprogramRef, Subprogram)] -> Map SubprogramRef Subprogram
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(SubprogramRef, Subprogram)] -> Map SubprogramRef Subprogram)
-> [(SubprogramRef, Subprogram)] -> Map SubprogramRef Subprogram
forall a b. (a -> b) -> a -> b
$ (DIE -> Subprogram -> (SubprogramRef, Subprogram))
-> [DIE] -> [Subprogram] -> [(SubprogramRef, Subprogram)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\DIE
d' Subprogram
s -> (DieID -> SubprogramRef
SubprogramRef (DIE -> DieID
dieId DIE
d'), Subprogram
s)) [DIE]
subprogramDies [Subprogram]
subprograms
      variables <- parseVariables fileVec

      ignoreChild DW_TAG_dwarf_procedure

      pure
        $! CompileUnit
          { cuCtx = ctx,
            cuProducer = prod,
            cuLanguage = lang,
            cuName = name,
            cuDescription = desc,
            cuCompDir = compDir,
            cuGNUMacros = gnuMacros,
            cuSubprogramMap = subMap,
            cuSubprograms = subprograms,
            cuVariables = variables,
            cuTypeMap = typeMap,
            cuRanges = ranges,
            cuLNE = lne,
            cuFileVec = fileVec
          }

------------------------------------------------------------------------
-- dwarfCompileUnits

getCompileUnit :: Dwarf.Sections -> CUContext -> (Either String CompileUnit, [String])
getCompileUnit :: Sections -> CUContext -> (Either String CompileUnit, [String])
getCompileUnit Sections
secs CUContext
ctx =
  case CUContext -> Either String DIE
cuFirstDie CUContext
ctx of
    Left String
e -> (String -> Either String CompileUnit
forall a b. a -> Either a b
Left String
e, [])
    Right DIE
d -> Sections
-> (CUContext, DIE) -> (Either String CompileUnit, [String])
parseCompileUnit Sections
secs (CUContext
ctx, DIE
d)

firstCUContext :: Endianness -> Dwarf.Sections -> Maybe (Either String CUContext)
firstCUContext :: Endianness -> Sections -> Maybe (Either String CUContext)
firstCUContext Endianness
end Sections
sections = do
  let dwEnd :: Endianess
dwEnd = case Endianness
end of
        Endianness
LittleEndian -> Endianess
Dwarf.LittleEndian
        Endianness
BigEndian -> Endianess
Dwarf.BigEndian
  Endianess -> Sections -> Maybe (Either String CUContext)
Dwarf.firstCUContext Endianess
dwEnd Sections
sections

{-# DEPRECATED dwarfCompileUnits "Use firstCUContext, nextCUContext and getCompileUnit" #-}

-- | Return dwarf information out of buffers.
dwarfCompileUnits ::
  Endianness ->
  Dwarf.Sections ->
  ([String], [CompileUnit])
dwarfCompileUnits :: Endianness -> Sections -> ([String], [CompileUnit])
dwarfCompileUnits Endianness
end Sections
sections = do
  let go ::
        [String] ->
        [CompileUnit] ->
        Maybe (Either String CUContext) ->
        ([String], [CompileUnit])
      go :: [String]
-> [CompileUnit]
-> Maybe (Either String CUContext)
-> ([String], [CompileUnit])
go [String]
prevWarn [CompileUnit]
cus Maybe (Either String CUContext)
Nothing = ([String] -> [String]
forall a. [a] -> [a]
reverse [String]
prevWarn, [CompileUnit] -> [CompileUnit]
forall a. [a] -> [a]
reverse [CompileUnit]
cus)
      go [String]
prevWarn [CompileUnit]
cus (Just (Left String
e)) = ([String] -> [String]
forall a. [a] -> [a]
reverse (String
e String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
prevWarn), [CompileUnit] -> [CompileUnit]
forall a. [a] -> [a]
reverse [CompileUnit]
cus)
      go [String]
prevWarn [CompileUnit]
cus (Just (Right CUContext
ctx)) =
        case Sections -> CUContext -> (Either String CompileUnit, [String])
getCompileUnit Sections
sections CUContext
ctx of
          (Left String
msg, [String]
warnings) ->
            [String]
-> [CompileUnit]
-> Maybe (Either String CUContext)
-> ([String], [CompileUnit])
go ([String]
warnings [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String
msg String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
prevWarn) [CompileUnit]
cus (CUContext -> Maybe (Either String CUContext)
nextCUContext CUContext
ctx)
          (Right CompileUnit
cu, [String]
warnings) ->
            [String]
-> [CompileUnit]
-> Maybe (Either String CUContext)
-> ([String], [CompileUnit])
go ([String]
warnings [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
prevWarn) (CompileUnit
cu CompileUnit -> [CompileUnit] -> [CompileUnit]
forall a. a -> [a] -> [a]
: [CompileUnit]
cus) (CUContext -> Maybe (Either String CUContext)
nextCUContext CUContext
ctx)
   in [String]
-> [CompileUnit]
-> Maybe (Either String CUContext)
-> ([String], [CompileUnit])
go [] [] (Endianness -> Sections -> Maybe (Either String CUContext)
firstCUContext Endianness
end Sections
sections)

------------------------------------------------------------------------
-- dwarfInfoFromElf

-- | Elf informaton
tryGetElfSection :: Elf.Elf v -> BS.ByteString -> Maybe BS.ByteString
tryGetElfSection :: forall (v :: Nat). Elf v -> ByteString -> Maybe ByteString
tryGetElfSection Elf v
e ByteString
nm =
  case ByteString -> Elf v -> [ElfSection (ElfWordType v)]
forall (w :: Nat).
ByteString -> Elf w -> [ElfSection (ElfWordType w)]
Elf.findSectionByName ByteString
nm Elf v
e of
    [] -> Maybe ByteString
forall a. Maybe a
Nothing
    -- We would like to warn about duplicate sections in this function
    --  but are restricted by the galois-dwarf API: https://github.com/GaloisInc/dwarf/issues/23
    ElfSection (ElfWordType v)
s : [ElfSection (ElfWordType v)]
_ -> do
      ByteString -> Maybe ByteString
forall a. a -> Maybe a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ElfSection (ElfWordType v) -> ByteString
forall w. ElfSection w -> ByteString
Elf.elfSectionData ElfSection (ElfWordType v)
s

-- | Return dwarf information out of an Elf file.
dwarfInfoFromElf :: Elf.Elf v -> ([String], [CompileUnit])
dwarfInfoFromElf :: forall (v :: Nat). Elf v -> ([String], [CompileUnit])
dwarfInfoFromElf Elf v
e = do
  case ByteString -> Elf v -> [ElfSection (ElfWordType v)]
forall (w :: Nat).
ByteString -> Elf w -> [ElfSection (ElfWordType w)]
Elf.findSectionByName ByteString
".debug_info" Elf v
e of
    [] -> ([], [])
    [ElfSection (ElfWordType v)]
_ ->
      let end :: Endianness
end =
            case Elf v -> ElfData
forall (w :: Nat). Elf w -> ElfData
Elf.elfData Elf v
e of
              ElfData
Elf.ELFDATA2LSB -> Endianness
LittleEndian
              ElfData
Elf.ELFDATA2MSB -> Endianness
BigEndian
          sections :: Sections
sections = (ByteString -> Maybe ByteString) -> Sections
mkSections (Elf v -> ByteString -> Maybe ByteString
forall (v :: Nat). Elf v -> ByteString -> Maybe ByteString
tryGetElfSection Elf v
e)
          ([String]
cuWarn, [CompileUnit]
cu) = Endianness -> Sections -> ([String], [CompileUnit])
dwarfCompileUnits Endianness
end Sections
sections
       in ([String] -> [String]
forall a. [a] -> [a]
reverse [String]
cuWarn, [CompileUnit]
cu)

-- | This returns all the variables in the given compile units.
dwarfGlobals :: [CompileUnit] -> [Variable]
dwarfGlobals :: [CompileUnit] -> [Variable]
dwarfGlobals [CompileUnit]
units = ((Location, Variable) -> Variable)
-> [(Location, Variable)] -> [Variable]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Location, Variable) -> Variable
forall a b. (a, b) -> b
snd (((Location, Variable) -> Location)
-> [(Location, Variable)] -> [(Location, Variable)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Location, Variable) -> Location
forall a b. (a, b) -> a
fst [(Location, Variable)]
l)
  where
    l :: [(Location, Variable)]
l =
      [ (Location
w, Variable
var)
        | CompileUnit
cu <- [CompileUnit]
units,
          Variable
var <- CompileUnit -> [Variable]
cuVariables CompileUnit
cu,
          Location
w <- Maybe Location -> [Location]
forall a. Maybe a -> [a]
maybeToList (Variable -> Maybe Location
varLocation Variable
var)
      ]