diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -6,32 +6,52 @@ import System.Environment import System.IO -import Graph.Trace.Dot (buildGraph, graphToDot, parseLogEntries) +import Graph.Trace.Dot (buildTree, buildNexus, graphToDot, parseLogEntries) main :: IO () main = do args <- getArgs - traceFiles <- case args of - [] -> do - contents <- Dir.listDirectory =<< Dir.getCurrentDirectory - let isTraceFile = (".trace" `List.isSuffixOf`) - pure $ filter isTraceFile contents - xs -> pure xs + let isFlag arg = "--" `List.isPrefixOf` arg + (flags, fileArgs) = span isFlag args + nexusFlag = "--nexus" `List.elem` flags + helpCommand = "--help" `List.elem` flags - for_ traceFiles $ \traceFile -> do - logContents - <- either (\err -> fail $ "Failed parsing trace file: " <> err) id - . parseLogEntries - <$> BSL.readFile traceFile + if helpCommand + then putStrLn helpText + else do + traceFiles <- case fileArgs of + [] -> do + contents <- Dir.listDirectory =<< Dir.getCurrentDirectory + let isTraceFile = (".trace" `List.isSuffixOf`) + pure $ filter isTraceFile contents + xs -> pure xs - let dotFileContent = graphToDot $ buildGraph logContents - fileName = (<> ".dot") - $ if ".trace" `List.isSuffixOf` traceFile - then reverse . drop 6 $ reverse traceFile - else traceFile + for_ traceFiles $ \traceFile -> do + logContents + <- either (\err -> fail $ "Failed parsing trace file: " <> err) id + . parseLogEntries + <$> BSL.readFile traceFile - withFile fileName WriteMode $ \h -> do - hSetBinaryMode h True - hSetBuffering h (BlockBuffering Nothing) - BSB.hPutBuilder h dotFileContent + let tree = buildTree logContents + dotFileContent + | nexusFlag = graphToDot $ buildNexus tree + | otherwise = graphToDot tree + fileName = (<> ".dot") + $ if ".trace" `List.isSuffixOf` traceFile + then reverse . drop 6 $ reverse traceFile + else traceFile + + withFile fileName WriteMode $ \h -> do + hSetBinaryMode h True + hSetBuffering h (BlockBuffering Nothing) + BSB.hPutBuilder h dotFileContent + +helpText :: String +helpText = unlines + [ "Command line utility for converting trace files generated by the \ + \graph-trace plugin into GraphViz compatible dot files." + , "" + , "Flags:" + , " --nexus Causes two or more identical nodes to be merged into one" + ] diff --git a/graph-trace-dot.cabal b/graph-trace-dot.cabal --- a/graph-trace-dot.cabal +++ b/graph-trace-dot.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: graph-trace-dot -version: 0.1.0.0 +version: 0.1.1.0 -- A short (one-line) description of the package. synopsis: @@ -36,8 +36,10 @@ , containers , directory , attoparsec + , cryptohash-sha256 + , base16-bytestring hs-source-dirs: src - ghc-options: -Wall + ghc-options: -Wall -O2 executable graph-trace-dot @@ -50,4 +52,4 @@ , attoparsec , graph-trace-dot hs-source-dirs: app - ghc-options: -Wall + ghc-options: -Wall -O2 diff --git a/src/Graph/Trace/Dot.hs b/src/Graph/Trace/Dot.hs --- a/src/Graph/Trace/Dot.hs +++ b/src/Graph/Trace/Dot.hs @@ -1,9 +1,12 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} module Graph.Trace.Dot ( parseLogEntries , parseLogEntry - , buildGraph + , buildTree + , buildNexus , graphToDot , Key(..) , LogEntry(..) @@ -11,22 +14,27 @@ import Control.Applicative ((<|>)) import Control.Monad +import qualified Crypto.Hash.SHA256 as Sha import qualified Data.Attoparsec.ByteString.Char8 as Atto import qualified Data.Attoparsec.ByteString.Lazy as AttoL +import Data.Bifunctor import qualified Data.ByteString as BS +import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Builder as BSB import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as BSL import Data.Foldable (foldl') import qualified Data.List as List -import qualified Data.Map as M +import qualified Data.Map.Lazy as ML +import qualified Data.Map.Strict as M import Data.Maybe (isJust) import Data.Monoid (Alt(..)) import Data.Ord (Down(..)) import Data.Semigroup (Min(..)) -parseLogEntries :: BSL.ByteString -> Either String [LogEntry] -parseLogEntries = AttoL.parseOnly (Atto.many' parseLogEntry <* Atto.endOfInput) +-------------------------------------------------------------------------------- +-- Types +-------------------------------------------------------------------------------- data Key = Key { keyId :: !Word , keyName :: !BS.ByteString @@ -39,7 +47,10 @@ (Maybe Key) -- called by (Maybe SrcCodeLoc) -- definition site (Maybe SrcCodeLoc) -- call site - | Trace Key BS.ByteString (Maybe SrcCodeLoc) + | Trace + Key + BS.ByteString + (Maybe SrcCodeLoc) deriving Show data SrcCodeLoc = @@ -49,24 +60,56 @@ , srcCol :: Int } deriving (Eq, Ord, Show) --- | Use this to escape special characters that appear in the HTML portion of --- the dot code. Other strings such as node names should not be escaped. -htmlEscape :: BS.ByteString -> BS.ByteString -htmlEscape bs = foldl' doReplacement bs replacements - where - doReplacement acc (c, re) = - case BS8.break (== c) acc of - (before, after) - | BS.null after -> acc - | otherwise -> before <> re <> BS8.tail after +data NodeEntry key + = Message BS.ByteString -- ^ The trace message + (Maybe SrcCodeLoc) -- ^ call site + | Edge key -- ^ Id of the invocation to link to + (Maybe SrcCodeLoc) -- ^ call site + deriving Show - replacements = - [ ('&', "&") - , ('<', "<") - , ('>', ">") - , ('\\', "\\\\") -- not really an HTML escape, but still needed - ] +type Color = BSB.Builder +-- Remembers the order in which the elements were inserted. Is monoidal +type Node key = + ( Min Int -- order + , ( [NodeEntry key] -- contents + , Alt Maybe SrcCodeLoc -- definition site + , Alt Maybe (Maybe key) -- back link. Is Just Nothing if there are multiple incoming edges (nexus) + ) + ) + +type Graph key = M.Map key (Node key) + +type Tree = Graph Key + +data NexusKey = + NexusKey { nexKeyName :: !BS.ByteString, nexKeyHash :: !BS.ByteString } + deriving (Eq, Ord, Show) + +type Nexus = Graph NexusKey + +class Ord key => IsKey key where + getKeyName :: key -> BS.ByteString + keyStr :: key -> BSB.Builder + keyStrEsc :: key -> BSB.Builder + +instance IsKey NexusKey where + getKeyName = nexKeyName + keyStr (NexusKey name hash) = BSB.byteString name <> BSB.byteString hash + keyStrEsc k = keyStr k { nexKeyName = htmlEscape $ nexKeyName k } + +instance IsKey Key where + getKeyName = keyName + keyStr (Key i k) = BSB.byteString k <> BSB.wordDec i + keyStrEsc k = keyStr k { keyName = htmlEscape $ keyName k } + +-------------------------------------------------------------------------------- +-- Parsing +-------------------------------------------------------------------------------- + +parseLogEntries :: BSL.ByteString -> Either String [LogEntry] +parseLogEntries = AttoL.parseOnly (Atto.many' parseLogEntry <* Atto.endOfInput) + parseKey :: Atto.Parser Key parseKey = do kName <- Atto.takeTill (== '§') <* Atto.char '§' @@ -106,52 +149,128 @@ pure SrcCodeLoc{..} Just <$> parseLoc <|> Nothing <$ Atto.string "§§§" -data NodeEntry - = Message BS.ByteString -- ^ The trace message - (Maybe SrcCodeLoc) -- ^ call site - | Edge Key -- ^ Id of the invocation to link to - (Maybe SrcCodeLoc) -- ^ call site - deriving Show +-- | Use this to escape special characters that appear in the HTML portion of +-- the dot code. Other strings such as node names should not be escaped. +htmlEscape :: BS.ByteString -> BS.ByteString +htmlEscape bs = foldl' doReplacement bs replacements + where + doReplacement acc (c, re) = + case BS8.break (== c) acc of + (before, after) + | BS.null after -> acc + | otherwise -> before <> re <> BS8.tail after --- Remembers the order in which the elements were inserted -type Graph = - M.Map Key ( Min Int -- order - , [NodeEntry] -- contents - , Alt Maybe SrcCodeLoc -- definition site - ) + replacements = + [ ('&', "&") + , ('<', "<") + , ('>', ">") + , ('\\', "\\\\") -- not really an HTML escape, but still needed + ] -buildGraph :: [LogEntry] -> Graph -buildGraph = foldl' build mempty where +-------------------------------------------------------------------------------- +-- Graph construction +-------------------------------------------------------------------------------- + +buildTree :: [LogEntry] -> Tree +buildTree = foldl' build mempty where build graph entry = case entry of Trace tag msg callSite -> M.insertWith (<>) tag - (graphSize, [Message msg callSite], Alt Nothing) + (graphSize, ([Message msg callSite], mempty, mempty)) graph + Entry curTag (Just prevTag) defSite callSite -> M.insertWith (<>) curTag - (graphSize + 1, [], Alt defSite) + (graphSize + 1, ([], Alt defSite, Alt . Just $ Just prevTag)) $ M.insertWith (<>) prevTag - (graphSize, [Edge curTag callSite], Alt Nothing) + (graphSize, ([Edge curTag callSite], mempty, mempty)) graph + Entry curTag Nothing defSite _ -> - M.insertWith (<>) curTag (graphSize, [], Alt defSite) graph + M.insertWith (<>) + curTag + (graphSize, ([], Alt defSite, mempty)) + graph where graphSize = Min $ M.size graph -graphToDot :: Graph -> BSB.Builder +-- | Constructs a nexus by merging tree nodes that have identical content based +-- on their hash. +buildNexus :: Tree -> Nexus +buildNexus tree = + let hashes = calcHashes tree + toNexusKey key = + case M.lookup key hashes of + Nothing -> error "missing hash" + Just hash -> + NexusKey { nexKeyName = keyName key, nexKeyHash = hash } + + mapNode ((order, (entries, loc, mKey)), multipleParents) = + (order, ( mapEntry <$> entries + , loc + , if multipleParents + then Alt (Just Nothing) + else fmap toNexusKey <$> mKey + ) + ) + + mapEntry = \case + Message msg loc -> Message msg loc + Edge key loc -> + let nexKey = toNexusKey key + in Edge nexKey + loc + + -- Used to determine if a node has inbound edges from two different parents + multipleInEdges + a@((_, (_, _, Alt ia)), multInA) + ((_, (_, _, Alt ib)), multInB) = + case (==) <$> (toNexusKey <$> join ia) <*> (toNexusKey <$> join ib) of + (Just False) -> (fst a, True) + _ -> (fst a, multInA || multInB) + + in M.map mapNode $ + M.mapKeysWith + multipleInEdges + toNexusKey + ((,False) <$> tree) + +-- | Produce a mapping of tree keys to the hash for that node. +calcHashes :: Tree -> M.Map Key BS.ByteString +calcHashes tree = + -- this relies on knot tying and must therefore use the lazy Map api + let hashes = ML.foldlWithKey buildHash mempty tree + + buildHash acc key (_, (entries, defSite, _)) = + let entryHashes = foldMap hashEntry entries + hash = Base16.encode . Sha.hash + $ keyName key + <> BSL.toStrict (BSB.toLazyByteString entryHashes) + <> BS8.pack (show defSite) + in ML.insert key hash acc + + hashEntry = \case + Message msg loc -> + BSB.byteString . Base16.encode . Sha.hash + $ msg <> BS8.pack (show loc) + Edge key _ -> BSB.byteString $ ML.findWithDefault mempty key hashes + in hashes + +-------------------------------------------------------------------------------- +-- Dot +-------------------------------------------------------------------------------- + +graphToDot :: IsKey key => Graph key -> BSB.Builder graphToDot graph = header <> graphContent <> "}" where - orderedEntries = map (\(key, (_, content, srcLoc)) -> (key, (content, getAlt srcLoc))) - . List.sortOn (Down . (\(x,_,_) -> x) . snd) + orderedEntries = map (second snd) + . List.sortOn (Down . fst . snd) $ M.toList graph graphContent = - -- knot-tying is used to get the color of a node from the edge pointing to that node. - -- TODO consider doing separate traversals for edges and nodes so that the - -- result can be built strictly. let (output, _, colorMap) = foldl' (doNode colorMap) @@ -162,12 +281,13 @@ header :: BSB.Builder header = "digraph {\nnode [tooltip=\" \" shape=plaintext colorscheme=set28]\n" - doNode finalColorMap (acc, colors, colorMapAcc) (key, (entries, mSrcLoc)) = + doNode finalColorMap (acc, colors, colorMapAcc) + (key, (entries, Alt mSrcLoc, Alt mBacklink)) = let (cells, edges, colors', colorMapAcc') = foldl' doEntry ([], [], colors, colorMapAcc) (zip entries [1..]) acc' = - -- don't render nodes that have in inbound edge but no content - if null entries && isJust mEdgeData + -- don't render nodes that have inbound edge(s) but no content + if null entries && isJust mBacklink then acc else tableStart <> tableEl cells @@ -176,24 +296,21 @@ <> acc in (acc', colors', colorMapAcc') where - keyStr (Key i k) = BSB.byteString k <> BSB.wordDec i - keyStrEsc k = keyStr k { keyName = htmlEscape $ keyName k } quoted bs = "\"" <> bs <> "\"" -- Building a node - mEdgeData = M.lookup key finalColorMap - nodeColor = snd <$> mEdgeData + nodeColor = ML.lookup key finalColorMap nodeToolTip = foldMap (("defined at " <>) . pprSrcCodeLoc) mSrcLoc - backHref = foldMap (\(k, _) -> "#" <> keyStr k) mEdgeData + backHref = (foldMap . foldMap) (\k -> "#" <> keyStr k) mBacklink labelCell = el "TR" [] [ el "TD" [ "HREF" .= backHref , "TOOLTIP" .= nodeToolTip , "BGCOLOR" .=? nodeColor ] - [ foldMap (const $ el "FONT" ["POINT-SIZE" .= "7"] ["←"]) - mEdgeData + [ (foldMap . foldMap) (const $ el "FONT" ["POINT-SIZE" .= "7"] ["←"]) + mBacklink , " " - , el "B" [] [ BSB.byteString . htmlEscape $ keyName key ] + , el "B" [] [ BSB.byteString . htmlEscape $ getKeyName key ] ] ] tableEl cells = @@ -210,7 +327,7 @@ tableEnd = ">];" -- Building an entry in a node - doEntry (cs, es, colors'@(color:nextColors), colorMap) ev = case ev of + doEntry (cs, es, colors'@(color:nextColors), colorMap) = \case (Message str mCallSite, idx) -> let msgToolTip = foldMap (("printed at " <>) . pprSrcCodeLoc) mCallSite @@ -225,7 +342,17 @@ ] in (msgEl : cs, es, colors', colorMap) (Edge edgeKey mCallSite, idx) -> - let href = foldMap (const $ "#" <> keyStrEsc edgeKey) mEdge + let mTargetNode = M.lookup edgeKey graph + -- If the target node isn't empty then check if a color is + -- already assigned (for a nexus) otherwise use the next color. + edgeColor = + case mTargetNode of + Just (_, (content, _, _)) + | not (null content) -> + M.findWithDefault color edgeKey colorMap + _ -> color + -- TODO ^ don't need this lookup if not a nexus + href = foldMap (const $ "#" <> keyStrEsc edgeKey) mEdge elToolTip = foldMap (("called at " <>) . pprSrcCodeLoc) mCallSite edgeEl = @@ -233,29 +360,29 @@ [ el "TD" [ "TOOLTIP" .= elToolTip , "ALIGN" .= "LEFT" , "CELLPADDING" .= "1" - , "BGCOLOR" .= color + , "BGCOLOR" .= edgeColor , "PORT" .= BSB.wordDec idx , "HREF" .= href ] [ el "FONT" [ "POINT-SIZE" .= "8" ] - [ BSB.byteString . htmlEscape $ keyName edgeKey ] + [ BSB.byteString . htmlEscape $ getKeyName edgeKey ] ] ] mEdge = do - (_, targetContent, _) <- M.lookup edgeKey graph + (_, (targetContent, _, _)) <- mTargetNode guard . not $ null targetContent Just $ quoted (keyStr key) <> ":" <> BSB.wordDec idx <> " -> " <> quoted (keyStr edgeKey) - <> " [tooltip=\" \" colorscheme=set28 color=" <> color <> "];" + <> " [tooltip=\" \" colorscheme=set28 color=" <> edgeColor <> "];" in ( edgeEl : cs , maybe id (:) mEdge es , nextColors - , M.insert edgeKey (key, color) colorMap + , M.insert edgeKey edgeColor colorMap ) - doEntry ac _ = ac + doEntry _ = mempty type Element = BSB.Builder type Attr = (BSB.Builder, Maybe BSB.Builder) @@ -274,7 +401,7 @@ renderAttr (aName, Just aVal) = " " <> aName <> "=\"" <> aVal <> "\"" renderAttr (_, Nothing) = mempty -edgeColors :: [BSB.Builder] +edgeColors :: [Color] edgeColors = BSB.intDec <$> [1..8 :: Int] pprSrcCodeLoc :: SrcCodeLoc -> BSB.Builder