graph-trace-dot 0.1.0.0 → 0.1.1.0

raw patch · 3 files changed

+238/−89 lines, 3 filesdep +base16-bytestringdep +cryptohash-sha256PVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: base16-bytestring, cryptohash-sha256

API changes (from Hackage documentation)

Files

• app/Main.hs +41/−21
• graph-trace-dot.cabal +5/−3
• src/Graph/Trace/Dot.hs +192/−65

@@ -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"+  ]

@@ -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

@@ -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 =-      [ ('&', "&amp;")-      , ('<', "&lt;")-      , ('>', "&gt;")-      , ('\\', "\\\\") -- 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 =+      [ ('&', "&amp;")+      , ('<', "&lt;")+      , ('>', "&gt;")+      , ('\\', "\\\\") -- 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"] ["&larr;"])-                    mEdgeData+                [ (foldMap . foldMap) (const $ el "FONT" ["POINT-SIZE" .= "7"] ["&larr;"])+                    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