packages feed

graph-trace-dot (empty) → 0.1.0.0

raw patch · 4 files changed

+379/−0 lines, 4 filesdep +attoparsecdep +basedep +bytestring

Dependencies added: attoparsec, base, bytestring, containers, directory, graph-trace-dot

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for graph-trace-viz++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ app/Main.hs view
@@ -0,0 +1,37 @@+import qualified Data.ByteString.Builder as BSB+import qualified Data.ByteString.Lazy as BSL+import           Data.Foldable (for_)+import qualified Data.List as List+import qualified System.Directory as Dir+import           System.Environment+import           System.IO++import           Graph.Trace.Dot (buildGraph, 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++  for_ traceFiles $ \traceFile -> do+    logContents+      <- either (\err -> fail $ "Failed parsing trace file: " <> err) id+       . parseLogEntries+     <$> BSL.readFile traceFile++    let dotFileContent = graphToDot $ buildGraph logContents+        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
+ graph-trace-dot.cabal view
@@ -0,0 +1,53 @@+cabal-version:      2.4+name:               graph-trace-dot+version:            0.1.0.0++-- A short (one-line) description of the package.+synopsis:+  Converts a graph-trace log into a DOT file for use with Graphviz++-- A longer description of the package.+description:+  Creates a DOT file from a @graph-trace@ log which is useable with [Graphviz](https://graphviz.org).+  .+  See the [README](https://github.com/aaronallen8455/graph-trace#graph-trace) for details.++-- A URL where users can report bugs.+bug-reports: https://github.com/aaronallen8455/graph-trace/issues++-- The license under which the package is released.+license: MIT++-- The package author(s).+-- author:+maintainer:         aaronallen8455@gmail.com++-- A copyright notice.+copyright:     Copyright (C) 2022 Aaron Allen+category: tooling, debug, development, graph, plugin+extra-source-files: CHANGELOG.md+tested-with: GHC==9.2.1, GHC==9.0.1, GHC==8.10.7++library+  default-language: Haskell2010+  exposed-modules: Graph.Trace.Dot+  build-depends: base+               , bytestring+               , containers+               , directory+               , attoparsec+  hs-source-dirs: src+  ghc-options: -Wall+++executable graph-trace-dot+  default-language: Haskell2010+  main-is: Main.hs+  build-depends: base >= 4.9 && < 5+               , bytestring+               , containers+               , directory+               , attoparsec+               , graph-trace-dot+  hs-source-dirs: app+  ghc-options: -Wall
+ src/Graph/Trace/Dot.hs view
@@ -0,0 +1,284 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+module Graph.Trace.Dot+  ( parseLogEntries+  , parseLogEntry+  , buildGraph+  , graphToDot+  , Key(..)+  , LogEntry(..)+  ) where++import           Control.Applicative ((<|>))+import           Control.Monad+import qualified Data.Attoparsec.ByteString.Char8 as Atto+import qualified Data.Attoparsec.ByteString.Lazy as AttoL+import qualified Data.ByteString as BS+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           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)++data Key = Key { keyId :: !Word+               , keyName :: !BS.ByteString+               }+  deriving (Eq, Ord, Show)++data LogEntry+  = Entry+      Key+      (Maybe Key) -- called by+      (Maybe SrcCodeLoc) -- definition site+      (Maybe SrcCodeLoc) -- call site+  | Trace Key BS.ByteString (Maybe SrcCodeLoc)+  deriving Show++data SrcCodeLoc =+  SrcCodeLoc+    { srcMod :: BS.ByteString+    , srcLine :: Int+    , 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++    replacements =+      [ ('&', "&amp;")+      , ('<', "&lt;")+      , ('>', "&gt;")+      , ('\\', "\\\\") -- not really an HTML escape, but still needed+      ]++parseKey :: Atto.Parser Key+parseKey = do+  kName <- Atto.takeTill (== '§') <* Atto.char '§'+  kId <- Atto.decimal <* Atto.char '§'+  pure $ Key { keyId = kId, keyName = kName }++parseLogEntry :: Atto.Parser LogEntry+parseLogEntry = (parseEntryEvent <|> parseTraceEvent) <* Atto.many' Atto.space++parseEntryEvent :: Atto.Parser LogEntry+parseEntryEvent = do+  _ <- Atto.string "entry§"+  curKey <- parseKey+  mPrevKey <- Just <$> parseKey+          <|> Nothing <$ Atto.string "§§"+  defSite <- parseSrcCodeLoc+  callSite <- parseSrcCodeLoc+  _ <- Atto.many' Atto.space+  pure $ Entry curKey mPrevKey defSite callSite++parseTraceEvent :: Atto.Parser LogEntry+parseTraceEvent = do+  _ <- Atto.string "trace§"+  key <- parseKey+  message <- Atto.takeTill (== '§') <* Atto.char '§'+  callSite <- parseSrcCodeLoc+  _ <- Atto.many' Atto.space+  let removeNewlines = BS8.unwords . BS8.lines+  pure $ Trace key (htmlEscape . removeNewlines $ message) callSite++parseSrcCodeLoc :: Atto.Parser (Maybe SrcCodeLoc)+parseSrcCodeLoc = do+  let parseLoc = do+        srcMod <- Atto.takeTill (== '§') <* Atto.char '§'+        srcLine <- Atto.decimal <* Atto.char '§'+        srcCol <- Atto.decimal <* Atto.char '§'+        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++-- Remembers the order in which the elements were inserted+type Graph =+  M.Map Key ( Min Int -- order+            , [NodeEntry] -- contents+            , Alt Maybe SrcCodeLoc -- definition site+            )++buildGraph :: [LogEntry] -> Graph+buildGraph = foldl' build mempty where+  build graph entry =+    case entry of+      Trace tag msg callSite ->+        M.insertWith (<>)+          tag+          (graphSize, [Message msg callSite], Alt Nothing)+          graph+      Entry curTag (Just prevTag) defSite callSite ->+          M.insertWith (<>)+            curTag+            (graphSize + 1, [], Alt defSite)+        $ M.insertWith (<>)+            prevTag+            (graphSize, [Edge curTag callSite], Alt Nothing)+            graph+      Entry curTag Nothing defSite _ ->+        M.insertWith (<>) curTag (graphSize, [], Alt defSite) graph+    where+      graphSize = Min $ M.size graph++graphToDot :: Graph -> BSB.Builder+graphToDot graph = header <> graphContent <> "}"+  where+    orderedEntries = map (\(key, (_, content, srcLoc)) -> (key, (content, getAlt srcLoc)))+                   . List.sortOn (Down . (\(x,_,_) -> x) . 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)+              (mempty, cycle edgeColors, mempty)+              orderedEntries+       in output++    header :: BSB.Builder+    header = "digraph {\nnode [tooltip=\" \" shape=plaintext colorscheme=set28]\n"++    doNode finalColorMap (acc, colors, colorMapAcc) (key, (entries, mSrcLoc)) =+      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+               then acc+               else tableStart+                 <> tableEl cells+                 <> tableEnd+                 <> mconcat edges+                 <> 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+        nodeToolTip = foldMap (("defined at " <>) . pprSrcCodeLoc) mSrcLoc+        backHref = foldMap (\(k, _) -> "#" <> keyStr k) mEdgeData+        labelCell =+          el "TR" []+            [ el "TD" [ "HREF" .= backHref+                      , "TOOLTIP" .= nodeToolTip+                      , "BGCOLOR" .=? nodeColor+                      ]+                [ foldMap (const $ el "FONT" ["POINT-SIZE" .= "7"] ["&larr;"])+                    mEdgeData+                , " "+                , el "B" [] [ BSB.byteString . htmlEscape $ keyName key ]+                ]+            ]+        tableEl cells =+          el "TABLE" [ "BORDER" .= "0"+                     , "CELLBORDER" .= "1"+                     , "CELLSPACING" .= "0"+                     , "CELLPADDING" .= "4"+                     ]+            [ labelCell+            , mconcat cells+            ]+        tableStart, tableEnd :: BSB.Builder+        tableStart = quoted (keyStr key) <> " [label=<\n"+        tableEnd = ">];"++        -- Building an entry in a node+        doEntry (cs, es, colors'@(color:nextColors), colorMap) ev = case ev of+          (Message str mCallSite, idx) ->+            let msgToolTip =+                  foldMap (("printed at " <>) . pprSrcCodeLoc) mCallSite+                msgEl =+                  el "TR" []+                    [ el "TD" [ "HREF" .= ""+                              , "TOOLTIP" .= msgToolTip+                              , "ALIGN" .= "LEFT"+                              , "PORT" .= BSB.wordDec idx+                              ]+                        [ BSB.byteString str ]+                    ]+             in (msgEl : cs, es, colors', colorMap)+          (Edge edgeKey mCallSite, idx) ->+            let href = foldMap (const $ "#" <> keyStrEsc edgeKey) mEdge+                elToolTip =+                  foldMap (("called at " <>) . pprSrcCodeLoc) mCallSite+                edgeEl =+                  el "TR" []+                    [ el "TD" [ "TOOLTIP" .= elToolTip+                              , "ALIGN" .= "LEFT"+                              , "CELLPADDING" .= "1"+                              , "BGCOLOR" .= color+                              , "PORT" .= BSB.wordDec idx+                              , "HREF" .= href+                              ]+                        [ el "FONT" [ "POINT-SIZE" .= "8" ]+                            [ BSB.byteString . htmlEscape $ keyName edgeKey ]+                        ]+                    ]++                mEdge = do+                  (_, targetContent, _) <- M.lookup edgeKey graph+                  guard . not $ null targetContent+                  Just $+                    quoted (keyStr key) <> ":" <> BSB.wordDec idx+                    <> " -> " <> quoted (keyStr edgeKey)+                    <> " [tooltip=\" \" colorscheme=set28 color=" <> color <> "];"++             in ( edgeEl : cs+                , maybe id (:) mEdge es+                , nextColors+                , M.insert edgeKey (key, color) colorMap+                )+        doEntry ac _ = ac++type Element = BSB.Builder+type Attr = (BSB.Builder, Maybe BSB.Builder)++(.=) :: BSB.Builder -> BSB.Builder -> Attr+name .= val = name .=? Just val++(.=?) :: BSB.Builder -> Maybe BSB.Builder -> Attr+name .=? val = (name, val)++el :: BSB.Builder -> [Attr] -> [BSB.Builder] -> Element+el name attrs children =+  "<" <> name <> foldMap renderAttr attrs <> ">"+  <> mconcat children <> "</" <> name <> ">"+  where+    renderAttr (aName, Just aVal) = " " <> aName <> "=\"" <> aVal <> "\""+    renderAttr (_, Nothing) = mempty++edgeColors :: [BSB.Builder]+edgeColors = BSB.intDec <$> [1..8 :: Int]++pprSrcCodeLoc :: SrcCodeLoc -> BSB.Builder+pprSrcCodeLoc loc+  = BSB.byteString (srcMod loc) <> ":"+ <> BSB.intDec (srcLine loc) <> ":"+ <> BSB.intDec (srcCol loc)