{-# OPTIONS_HADDOCK prune #-}
{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module: Vestigia.Symbol
-- Copyright: (c) 2026 Jared Tobin
-- License: MIT
-- Maintainer: Jared Tobin <jared@ppad.tech>
--
-- Naming an instruction by its source: an addr2line over an
-- object's debug information, inlined frames included, at the
-- instruction's address in the object (where the object's program
-- headers place it, as its disassembly does). LLVM's names each
-- inlined frame by its own function, and an address no symbol covers
-- by none, where binutils' gives the innermost frame the name of the
-- function it was inlined into, and code without debug information
-- (a GHC program's) the name of whatever function precedes it. LLVM
-- leaves a legacy Rust symbol as an Itanium demangler does, its
-- escapes and hash in place, which are undone here.

module Vestigia.Symbol (
    Place(..)
  , symbolize
  , parseAddr2line
  , rustLegacy
  ) where

import Control.Exception (IOException, try)
import Data.Char (chr, isHexDigit)
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import Numeric (readHex, showHex)
import System.Process (readProcess)
import Text.Read (readMaybe)

-- | One frame of a source location: the function and, where the
--   debug information has it, the file and line. The innermost
--   frame comes first.
data Place = Place {
    Place -> Maybe Text
plFunction :: !(Maybe T.Text)
  , Place -> Maybe Text
plFile :: !(Maybe T.Text)
  , Place -> Maybe Int
plLine :: !(Maybe Int)
  } deriving (Place -> Place -> Bool
(Place -> Place -> Bool) -> (Place -> Place -> Bool) -> Eq Place
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Place -> Place -> Bool
== :: Place -> Place -> Bool
$c/= :: Place -> Place -> Bool
/= :: Place -> Place -> Bool
Eq, Int -> Place -> ShowS
[Place] -> ShowS
Place -> String
(Int -> Place -> ShowS)
-> (Place -> String) -> ([Place] -> ShowS) -> Show Place
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Place -> ShowS
showsPrec :: Int -> Place -> ShowS
$cshow :: Place -> String
show :: Place -> String
$cshowList :: [Place] -> ShowS
showList :: [Place] -> ShowS
Show)

-- | The source of each address, per object, by one addr2line call
--   per object. An object addr2line cannot read names nothing.
symbolize
  :: FilePath -> [(T.Text, Integer)]
  -> IO (M.Map (T.Text, Integer) [Place])
symbolize :: String -> [(Text, Integer)] -> IO (Map (Text, Integer) [Place])
symbolize String
addr2line [(Text, Integer)]
keys = do
  let byObject :: Map Text [Integer]
byObject = ([Integer] -> [Integer] -> [Integer])
-> [(Text, [Integer])] -> Map Text [Integer]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith [Integer] -> [Integer] -> [Integer]
forall a. Semigroup a => a -> a -> a
(<>) [ (Text
o, [ Integer
off ]) | (Text
o, Integer
off) <- [(Text, Integer)]
keys ]
  parts <- ((Text, [Integer]) -> IO (Map (Text, Integer) [Place]))
-> [(Text, [Integer])] -> IO [Map (Text, Integer) [Place]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Text, [Integer]) -> IO (Map (Text, Integer) [Place])
forall {a}.
Integral a =>
(Text, [a]) -> IO (Map (Text, Integer) [Place])
one (Map Text [Integer] -> [(Text, [Integer])]
forall k a. Map k a -> [(k, a)]
M.toList Map Text [Integer]
byObject)
  pure (M.unions parts)
  where
    one :: (Text, [a]) -> IO (Map (Text, Integer) [Place])
one (Text
obj, [a]
offs) = do
      r <- IO String -> IO (Either IOException String)
forall e a. Exception e => IO a -> IO (Either e a)
try (String -> [String] -> String -> IO String
readProcess String
addr2line
             [ String
"-a", String
"-f", String
"-i", String
"-C", String
"-e", Text -> String
T.unpack Text
obj ]
             ([String] -> String
unlines [ String
"0x" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> ShowS
forall a. Integral a => a -> ShowS
showHex a
o String
"" | a
o <- [a]
offs ]))
             :: IO (Either IOException String)
      pure $ case r of
        Left IOException
_ -> Map (Text, Integer) [Place]
forall k a. Map k a
M.empty
        Right String
out -> [((Text, Integer), [Place])] -> Map (Text, Integer) [Place]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
          [ ((Text
obj, Integer
a), [Place]
ps) | (Integer
a, [Place]
ps) <- Text -> [(Integer, [Place])]
parseAddr2line (String -> Text
T.pack String
out) ]

-- | addr2line's output under @-a -f -i@: an address line, then a
--   function line and a location line per frame.
--
-- >>> parseAddr2line "0x20\n??\n??:0\n"
-- [(32,[Place Nothing Nothing Nothing])]
parseAddr2line :: T.Text -> [(Integer, [Place])]
parseAddr2line :: Text -> [(Integer, [Place])]
parseAddr2line = [Text] -> [(Integer, [Place])]
go ([Text] -> [(Integer, [Place])])
-> (Text -> [Text]) -> Text -> [(Integer, [Place])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines
  where
    go :: [Text] -> [(Integer, [Place])]
go [Text]
ls = case [Text]
ls of
      (Text
a : [Text]
rest) | Just Integer
addr <- Text -> Maybe Integer
address Text
a ->
        let ([Text]
body, [Text]
more) = (Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (\Text
l -> Text -> Maybe Integer
address Text
l Maybe Integer -> Maybe Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Integer
forall a. Maybe a
Nothing) [Text]
rest
        in (Integer
addr, [Text] -> [Place]
frames [Text]
body) (Integer, [Place]) -> [(Integer, [Place])] -> [(Integer, [Place])]
forall a. a -> [a] -> [a]
: [Text] -> [(Integer, [Place])]
go [Text]
more
      (Text
_ : [Text]
rest) -> [Text] -> [(Integer, [Place])]
go [Text]
rest
      [] -> []

    address :: T.Text -> Maybe Integer
    address :: Text -> Maybe Integer
address Text
l = case Text -> Text -> Maybe Text
T.stripPrefix Text
"0x" Text
l of
      Just Text
h | Bool -> Bool
not (Text -> Bool
T.null Text
h), [ (Integer
v, String
"") ] <- ReadS Integer
forall a. (Eq a, Num a) => ReadS a
readHex (Text -> String
T.unpack Text
h) ->
        Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
v
      Maybe Text
_ -> Maybe Integer
forall a. Maybe a
Nothing

    frames :: [Text] -> [Place]
frames [Text]
ls = case [Text]
ls of
      (Text
f : Text
loc : [Text]
rest) -> Text -> Text -> Place
place Text
f Text
loc Place -> [Place] -> [Place]
forall a. a -> [a] -> [a]
: [Text] -> [Place]
frames [Text]
rest
      [Text]
_ -> []

    place :: Text -> Text -> Place
place Text
f Text
loc =
      let (Maybe Text
file, Maybe Int
line) = Text -> (Maybe Text, Maybe Int)
forall {a}. (Read a, Eq a, Num a) => Text -> (Maybe Text, Maybe a)
location Text
loc
      in Place {
             plFunction :: Maybe Text
plFunction = if Text
f Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"??" then Maybe Text
forall a. Maybe a
Nothing else Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Text
rustLegacy Text
f)
           , plFile :: Maybe Text
plFile = Maybe Text
file
           , plLine :: Maybe Int
plLine = Maybe Int
line
           }

    -- "path:line", "path:line (discriminator n)", or "??:0"
    location :: Text -> (Maybe Text, Maybe a)
location Text
loc =
      let l :: Text
l = (Char -> Bool) -> Text -> Text
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ') Text
loc
          (Text
p, Text
n) = HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOnEnd Text
":" Text
l
          path :: Text
path = Int -> Text -> Text
T.dropEnd Int
1 Text
p
      in ( if Text -> Bool
T.null Text
path Bool -> Bool -> Bool
|| Text
path Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"??" then Maybe Text
forall a. Maybe a
Nothing else Text -> Maybe Text
forall a. a -> Maybe a
Just Text
path
         , case String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
T.unpack Text
n) of
             Just a
0 -> Maybe a
forall a. Maybe a
Nothing
             Maybe a
other -> Maybe a
other )

-- | A legacy Rust symbol, as an Itanium demangler leaves it, as
--   rustc-demangle gives it: its hash dropped, each path segment's
--   escapes undone. Any other name is left as it is.
--
-- >>> rustLegacy "a::_$LT$impl$u20$b..C$GT$::f::h346fee1681a4f34f"
-- "a::<impl b::C>::f"
rustLegacy :: T.Text -> T.Text
rustLegacy :: Text -> Text
rustLegacy Text
t = case HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOnEnd Text
"::" Text
t of
  (Text
pre, Text
h) | Bool -> Bool
not (Text -> Bool
T.null Text
pre), Text -> Bool
hash Text
h ->
    Text -> [Text] -> Text
T.intercalate Text
"::"
      ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
segment (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"::" (Int -> Text -> Text
T.dropEnd Int
2 Text
pre)))
  (Text, Text)
_ -> Text
t
  where
    hash :: Text -> Bool
hash Text
h = case Text -> Maybe (Char, Text)
T.uncons Text
h of
      Just (Char
'h', Text
ds) -> Text -> Int
T.length Text
ds Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
16 Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isHexDigit Text
ds
      Maybe (Char, Text)
_ -> Bool
False
    segment :: Text -> Text
segment Text
g = String -> Text
T.pack (ShowS
unescape (Text -> String
T.unpack
      (Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
g (Text
"$" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text -> Maybe Text
T.stripPrefix Text
"_$" Text
g))))
    unescape :: ShowS
unescape String
cs = case String
cs of
      Char
'$' : String
rest
        | (String
code, Char
'$' : String
more) <- (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'$') String
rest
        , Just String
r <- String -> Maybe String
escape String
code -> String
r String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
unescape String
more
      Char
'.' : Char
'.' : String
more -> String
"::" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
unescape String
more
      Char
c : String
more -> Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
unescape String
more
      [] -> []
    escape :: String -> Maybe String
escape String
code = case String
code of
      String
"SP" -> String -> Maybe String
forall a. a -> Maybe a
Just String
"@"
      String
"BP" -> String -> Maybe String
forall a. a -> Maybe a
Just String
"*"
      String
"RF" -> String -> Maybe String
forall a. a -> Maybe a
Just String
"&"
      String
"LT" -> String -> Maybe String
forall a. a -> Maybe a
Just String
"<"
      String
"GT" -> String -> Maybe String
forall a. a -> Maybe a
Just String
">"
      String
"LP" -> String -> Maybe String
forall a. a -> Maybe a
Just String
"("
      String
"RP" -> String -> Maybe String
forall a. a -> Maybe a
Just String
")"
      String
"C" -> String -> Maybe String
forall a. a -> Maybe a
Just String
","
      Char
'u' : String
h | [ (Int
n, String
"") ] <- ReadS Int
forall a. (Eq a, Num a) => ReadS a
readHex String
h -> String -> Maybe String
forall a. a -> Maybe a
Just [ Int -> Char
chr Int
n ]
      String
_ -> Maybe String
forall a. Maybe a
Nothing