{-# 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 :: ByteString -> Either String [LogEntry]
parseLogEntries = Parser [LogEntry] -> ByteString -> Either String [LogEntry]
forall a. Parser a -> ByteString -> Either String a
AttoL.parseOnly (Parser ByteString LogEntry -> Parser [LogEntry]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
Atto.many' Parser ByteString LogEntry
parseLogEntry Parser [LogEntry] -> Parser ByteString () -> Parser [LogEntry]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
Atto.endOfInput)

data Key = Key { Key -> Word
keyId :: !Word
               , Key -> ByteString
keyName :: !BS.ByteString
               }
  deriving (Key -> Key -> Bool
(Key -> Key -> Bool) -> (Key -> Key -> Bool) -> Eq Key
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Key -> Key -> Bool
$c/= :: Key -> Key -> Bool
== :: Key -> Key -> Bool
$c== :: Key -> Key -> Bool
Eq, Eq Key
Eq Key
-> (Key -> Key -> Ordering)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Key)
-> (Key -> Key -> Key)
-> Ord Key
Key -> Key -> Bool
Key -> Key -> Ordering
Key -> Key -> Key
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
min :: Key -> Key -> Key
$cmin :: Key -> Key -> Key
max :: Key -> Key -> Key
$cmax :: Key -> Key -> Key
>= :: Key -> Key -> Bool
$c>= :: Key -> Key -> Bool
> :: Key -> Key -> Bool
$c> :: Key -> Key -> Bool
<= :: Key -> Key -> Bool
$c<= :: Key -> Key -> Bool
< :: Key -> Key -> Bool
$c< :: Key -> Key -> Bool
compare :: Key -> Key -> Ordering
$ccompare :: Key -> Key -> Ordering
$cp1Ord :: Eq Key
Ord, Int -> Key -> ShowS
[Key] -> ShowS
Key -> String
(Int -> Key -> ShowS)
-> (Key -> String) -> ([Key] -> ShowS) -> Show Key
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Key] -> ShowS
$cshowList :: [Key] -> ShowS
show :: Key -> String
$cshow :: Key -> String
showsPrec :: Int -> Key -> ShowS
$cshowsPrec :: Int -> Key -> ShowS
Show)

data LogEntry
  = Entry
      Key
      (Maybe Key) -- called by
      (Maybe SrcCodeLoc) -- definition site
      (Maybe SrcCodeLoc) -- call site
  | Trace Key BS.ByteString (Maybe SrcCodeLoc)
  deriving Int -> LogEntry -> ShowS
[LogEntry] -> ShowS
LogEntry -> String
(Int -> LogEntry -> ShowS)
-> (LogEntry -> String) -> ([LogEntry] -> ShowS) -> Show LogEntry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LogEntry] -> ShowS
$cshowList :: [LogEntry] -> ShowS
show :: LogEntry -> String
$cshow :: LogEntry -> String
showsPrec :: Int -> LogEntry -> ShowS
$cshowsPrec :: Int -> LogEntry -> ShowS
Show

data SrcCodeLoc =
  SrcCodeLoc
    { SrcCodeLoc -> ByteString
srcMod :: BS.ByteString
    , SrcCodeLoc -> Int
srcLine :: Int
    , SrcCodeLoc -> Int
srcCol :: Int
    } deriving (SrcCodeLoc -> SrcCodeLoc -> Bool
(SrcCodeLoc -> SrcCodeLoc -> Bool)
-> (SrcCodeLoc -> SrcCodeLoc -> Bool) -> Eq SrcCodeLoc
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SrcCodeLoc -> SrcCodeLoc -> Bool
$c/= :: SrcCodeLoc -> SrcCodeLoc -> Bool
== :: SrcCodeLoc -> SrcCodeLoc -> Bool
$c== :: SrcCodeLoc -> SrcCodeLoc -> Bool
Eq, Eq SrcCodeLoc
Eq SrcCodeLoc
-> (SrcCodeLoc -> SrcCodeLoc -> Ordering)
-> (SrcCodeLoc -> SrcCodeLoc -> Bool)
-> (SrcCodeLoc -> SrcCodeLoc -> Bool)
-> (SrcCodeLoc -> SrcCodeLoc -> Bool)
-> (SrcCodeLoc -> SrcCodeLoc -> Bool)
-> (SrcCodeLoc -> SrcCodeLoc -> SrcCodeLoc)
-> (SrcCodeLoc -> SrcCodeLoc -> SrcCodeLoc)
-> Ord SrcCodeLoc
SrcCodeLoc -> SrcCodeLoc -> Bool
SrcCodeLoc -> SrcCodeLoc -> Ordering
SrcCodeLoc -> SrcCodeLoc -> SrcCodeLoc
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
min :: SrcCodeLoc -> SrcCodeLoc -> SrcCodeLoc
$cmin :: SrcCodeLoc -> SrcCodeLoc -> SrcCodeLoc
max :: SrcCodeLoc -> SrcCodeLoc -> SrcCodeLoc
$cmax :: SrcCodeLoc -> SrcCodeLoc -> SrcCodeLoc
>= :: SrcCodeLoc -> SrcCodeLoc -> Bool
$c>= :: SrcCodeLoc -> SrcCodeLoc -> Bool
> :: SrcCodeLoc -> SrcCodeLoc -> Bool
$c> :: SrcCodeLoc -> SrcCodeLoc -> Bool
<= :: SrcCodeLoc -> SrcCodeLoc -> Bool
$c<= :: SrcCodeLoc -> SrcCodeLoc -> Bool
< :: SrcCodeLoc -> SrcCodeLoc -> Bool
$c< :: SrcCodeLoc -> SrcCodeLoc -> Bool
compare :: SrcCodeLoc -> SrcCodeLoc -> Ordering
$ccompare :: SrcCodeLoc -> SrcCodeLoc -> Ordering
$cp1Ord :: Eq SrcCodeLoc
Ord, Int -> SrcCodeLoc -> ShowS
[SrcCodeLoc] -> ShowS
SrcCodeLoc -> String
(Int -> SrcCodeLoc -> ShowS)
-> (SrcCodeLoc -> String)
-> ([SrcCodeLoc] -> ShowS)
-> Show SrcCodeLoc
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SrcCodeLoc] -> ShowS
$cshowList :: [SrcCodeLoc] -> ShowS
show :: SrcCodeLoc -> String
$cshow :: SrcCodeLoc -> String
showsPrec :: Int -> SrcCodeLoc -> ShowS
$cshowsPrec :: Int -> SrcCodeLoc -> ShowS
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 :: ByteString -> ByteString
htmlEscape ByteString
bs = (ByteString -> (Char, ByteString) -> ByteString)
-> ByteString -> [(Char, ByteString)] -> ByteString
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ByteString -> (Char, ByteString) -> ByteString
doReplacement ByteString
bs [(Char, ByteString)]
replacements
  where
    doReplacement :: ByteString -> (Char, ByteString) -> ByteString
doReplacement ByteString
acc (Char
c, ByteString
re) =
      case (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BS8.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c) ByteString
acc of
        (ByteString
before, ByteString
after)
          | ByteString -> Bool
BS.null ByteString
after -> ByteString
acc
          | Bool
otherwise -> ByteString
before ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
re ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
BS8.tail ByteString
after

    replacements :: [(Char, ByteString)]
replacements =
      [ (Char
'&', ByteString
"&amp;")
      , (Char
'<', ByteString
"&lt;")
      , (Char
'>', ByteString
"&gt;")
      , (Char
'\\', ByteString
"\\\\") -- not really an HTML escape, but still needed
      ]

parseKey :: Atto.Parser Key
parseKey :: Parser Key
parseKey = do
  ByteString
kName <- (Char -> Bool) -> Parser ByteString
Atto.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'§') Parser ByteString -> Parser ByteString Char -> Parser ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
Atto.char Char
'§'
  Word
kId <- Parser Word
forall a. Integral a => Parser a
Atto.decimal Parser Word -> Parser ByteString Char -> Parser Word
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
Atto.char Char
'§'
  Key -> Parser Key
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Key -> Parser Key) -> Key -> Parser Key
forall a b. (a -> b) -> a -> b
$ Key :: Word -> ByteString -> Key
Key { keyId :: Word
keyId = Word
kId, keyName :: ByteString
keyName = ByteString
kName }

parseLogEntry :: Atto.Parser LogEntry
parseLogEntry :: Parser ByteString LogEntry
parseLogEntry = (Parser ByteString LogEntry
parseEntryEvent Parser ByteString LogEntry
-> Parser ByteString LogEntry -> Parser ByteString LogEntry
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString LogEntry
parseTraceEvent) Parser ByteString LogEntry
-> Parser ByteString String -> Parser ByteString LogEntry
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString Char -> Parser ByteString String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
Atto.many' Parser ByteString Char
Atto.space

parseEntryEvent :: Atto.Parser LogEntry
parseEntryEvent :: Parser ByteString LogEntry
parseEntryEvent = do
  ByteString
_ <- ByteString -> Parser ByteString
Atto.string ByteString
"entry§"
  Key
curKey <- Parser Key
parseKey
  Maybe Key
mPrevKey <- Key -> Maybe Key
forall a. a -> Maybe a
Just (Key -> Maybe Key) -> Parser Key -> Parser ByteString (Maybe Key)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Key
parseKey
          Parser ByteString (Maybe Key)
-> Parser ByteString (Maybe Key) -> Parser ByteString (Maybe Key)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Key
forall a. Maybe a
Nothing Maybe Key -> Parser ByteString -> Parser ByteString (Maybe Key)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString
Atto.string ByteString
"§§"
  Maybe SrcCodeLoc
defSite <- Parser (Maybe SrcCodeLoc)
parseSrcCodeLoc
  Maybe SrcCodeLoc
callSite <- Parser (Maybe SrcCodeLoc)
parseSrcCodeLoc
  String
_ <- Parser ByteString Char -> Parser ByteString String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
Atto.many' Parser ByteString Char
Atto.space
  LogEntry -> Parser ByteString LogEntry
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LogEntry -> Parser ByteString LogEntry)
-> LogEntry -> Parser ByteString LogEntry
forall a b. (a -> b) -> a -> b
$ Key
-> Maybe Key -> Maybe SrcCodeLoc -> Maybe SrcCodeLoc -> LogEntry
Entry Key
curKey Maybe Key
mPrevKey Maybe SrcCodeLoc
defSite Maybe SrcCodeLoc
callSite

parseTraceEvent :: Atto.Parser LogEntry
parseTraceEvent :: Parser ByteString LogEntry
parseTraceEvent = do
  ByteString
_ <- ByteString -> Parser ByteString
Atto.string ByteString
"trace§"
  Key
key <- Parser Key
parseKey
  ByteString
message <- (Char -> Bool) -> Parser ByteString
Atto.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'§') Parser ByteString -> Parser ByteString Char -> Parser ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
Atto.char Char
'§'
  Maybe SrcCodeLoc
callSite <- Parser (Maybe SrcCodeLoc)
parseSrcCodeLoc
  String
_ <- Parser ByteString Char -> Parser ByteString String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
Atto.many' Parser ByteString Char
Atto.space
  let removeNewlines :: ByteString -> ByteString
removeNewlines = [ByteString] -> ByteString
BS8.unwords ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
BS8.lines
  LogEntry -> Parser ByteString LogEntry
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LogEntry -> Parser ByteString LogEntry)
-> LogEntry -> Parser ByteString LogEntry
forall a b. (a -> b) -> a -> b
$ Key -> ByteString -> Maybe SrcCodeLoc -> LogEntry
Trace Key
key (ByteString -> ByteString
htmlEscape (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
removeNewlines (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
message) Maybe SrcCodeLoc
callSite

parseSrcCodeLoc :: Atto.Parser (Maybe SrcCodeLoc)
parseSrcCodeLoc :: Parser (Maybe SrcCodeLoc)
parseSrcCodeLoc = do
  let parseLoc :: Parser ByteString SrcCodeLoc
parseLoc = do
        ByteString
srcMod <- (Char -> Bool) -> Parser ByteString
Atto.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'§') Parser ByteString -> Parser ByteString Char -> Parser ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
Atto.char Char
'§'
        Int
srcLine <- Parser Int
forall a. Integral a => Parser a
Atto.decimal Parser Int -> Parser ByteString Char -> Parser Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
Atto.char Char
'§'
        Int
srcCol <- Parser Int
forall a. Integral a => Parser a
Atto.decimal Parser Int -> Parser ByteString Char -> Parser Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
Atto.char Char
'§'
        SrcCodeLoc -> Parser ByteString SrcCodeLoc
forall (f :: * -> *) a. Applicative f => a -> f a
pure SrcCodeLoc :: ByteString -> Int -> Int -> SrcCodeLoc
SrcCodeLoc{Int
ByteString
srcCol :: Int
srcLine :: Int
srcMod :: ByteString
srcCol :: Int
srcLine :: Int
srcMod :: ByteString
..}
  SrcCodeLoc -> Maybe SrcCodeLoc
forall a. a -> Maybe a
Just (SrcCodeLoc -> Maybe SrcCodeLoc)
-> Parser ByteString SrcCodeLoc -> Parser (Maybe SrcCodeLoc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString SrcCodeLoc
parseLoc Parser (Maybe SrcCodeLoc)
-> Parser (Maybe SrcCodeLoc) -> Parser (Maybe SrcCodeLoc)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe SrcCodeLoc
forall a. Maybe a
Nothing Maybe SrcCodeLoc -> Parser ByteString -> Parser (Maybe SrcCodeLoc)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString
Atto.string ByteString
"§§§"

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 Int -> NodeEntry -> ShowS
[NodeEntry] -> ShowS
NodeEntry -> String
(Int -> NodeEntry -> ShowS)
-> (NodeEntry -> String)
-> ([NodeEntry] -> ShowS)
-> Show NodeEntry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NodeEntry] -> ShowS
$cshowList :: [NodeEntry] -> ShowS
show :: NodeEntry -> String
$cshow :: NodeEntry -> String
showsPrec :: Int -> NodeEntry -> ShowS
$cshowsPrec :: Int -> NodeEntry -> ShowS
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 :: [LogEntry] -> Graph
buildGraph = (Graph -> LogEntry -> Graph) -> Graph -> [LogEntry] -> Graph
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Graph -> LogEntry -> Graph
build Graph
forall a. Monoid a => a
mempty where
  build :: Graph -> LogEntry -> Graph
build Graph
graph LogEntry
entry =
    case LogEntry
entry of
      Trace Key
tag ByteString
msg Maybe SrcCodeLoc
callSite ->
        ((Min Int, [NodeEntry], Alt Maybe SrcCodeLoc)
 -> (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc)
 -> (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc))
-> Key
-> (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc)
-> Graph
-> Graph
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc)
-> (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc)
-> (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc)
forall a. Semigroup a => a -> a -> a
(<>)
          Key
tag
          (Min Int
graphSize, [ByteString -> Maybe SrcCodeLoc -> NodeEntry
Message ByteString
msg Maybe SrcCodeLoc
callSite], Maybe SrcCodeLoc -> Alt Maybe SrcCodeLoc
forall k (f :: k -> *) (a :: k). f a -> Alt f a
Alt Maybe SrcCodeLoc
forall a. Maybe a
Nothing)
          Graph
graph
      Entry Key
curTag (Just Key
prevTag) Maybe SrcCodeLoc
defSite Maybe SrcCodeLoc
callSite ->
          ((Min Int, [NodeEntry], Alt Maybe SrcCodeLoc)
 -> (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc)
 -> (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc))
-> Key
-> (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc)
-> Graph
-> Graph
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc)
-> (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc)
-> (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc)
forall a. Semigroup a => a -> a -> a
(<>)
            Key
curTag
            (Min Int
graphSize Min Int -> Min Int -> Min Int
forall a. Num a => a -> a -> a
+ Min Int
1, [], Maybe SrcCodeLoc -> Alt Maybe SrcCodeLoc
forall k (f :: k -> *) (a :: k). f a -> Alt f a
Alt Maybe SrcCodeLoc
defSite)
        (Graph -> Graph) -> Graph -> Graph
forall a b. (a -> b) -> a -> b
$ ((Min Int, [NodeEntry], Alt Maybe SrcCodeLoc)
 -> (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc)
 -> (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc))
-> Key
-> (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc)
-> Graph
-> Graph
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc)
-> (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc)
-> (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc)
forall a. Semigroup a => a -> a -> a
(<>)
            Key
prevTag
            (Min Int
graphSize, [Key -> Maybe SrcCodeLoc -> NodeEntry
Edge Key
curTag Maybe SrcCodeLoc
callSite], Maybe SrcCodeLoc -> Alt Maybe SrcCodeLoc
forall k (f :: k -> *) (a :: k). f a -> Alt f a
Alt Maybe SrcCodeLoc
forall a. Maybe a
Nothing)
            Graph
graph
      Entry Key
curTag Maybe Key
Nothing Maybe SrcCodeLoc
defSite Maybe SrcCodeLoc
_ ->
        ((Min Int, [NodeEntry], Alt Maybe SrcCodeLoc)
 -> (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc)
 -> (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc))
-> Key
-> (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc)
-> Graph
-> Graph
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc)
-> (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc)
-> (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc)
forall a. Semigroup a => a -> a -> a
(<>) Key
curTag (Min Int
graphSize, [], Maybe SrcCodeLoc -> Alt Maybe SrcCodeLoc
forall k (f :: k -> *) (a :: k). f a -> Alt f a
Alt Maybe SrcCodeLoc
defSite) Graph
graph
    where
      graphSize :: Min Int
graphSize = Int -> Min Int
forall a. a -> Min a
Min (Int -> Min Int) -> Int -> Min Int
forall a b. (a -> b) -> a -> b
$ Graph -> Int
forall k a. Map k a -> Int
M.size Graph
graph

graphToDot :: Graph -> BSB.Builder
graphToDot :: Graph -> Builder
graphToDot Graph
graph = Builder
header Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
graphContent Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"}"
  where
    orderedEntries :: [(Key, ([NodeEntry], Maybe SrcCodeLoc))]
orderedEntries = ((Key, (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc))
 -> (Key, ([NodeEntry], Maybe SrcCodeLoc)))
-> [(Key, (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc))]
-> [(Key, ([NodeEntry], Maybe SrcCodeLoc))]
forall a b. (a -> b) -> [a] -> [b]
map (\(Key
key, (Min Int
_, [NodeEntry]
content, Alt Maybe SrcCodeLoc
srcLoc)) -> (Key
key, ([NodeEntry]
content, Alt Maybe SrcCodeLoc -> Maybe SrcCodeLoc
forall k (f :: k -> *) (a :: k). Alt f a -> f a
getAlt Alt Maybe SrcCodeLoc
srcLoc)))
                   ([(Key, (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc))]
 -> [(Key, ([NodeEntry], Maybe SrcCodeLoc))])
-> ([(Key, (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc))]
    -> [(Key, (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc))])
-> [(Key, (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc))]
-> [(Key, ([NodeEntry], Maybe SrcCodeLoc))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Key, (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc))
 -> Down (Min Int))
-> [(Key, (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc))]
-> [(Key, (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc))]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn (Min Int -> Down (Min Int)
forall a. a -> Down a
Down (Min Int -> Down (Min Int))
-> ((Key, (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc)) -> Min Int)
-> (Key, (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc))
-> Down (Min Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(Min Int
x,[NodeEntry]
_,Alt Maybe SrcCodeLoc
_) -> Min Int
x) ((Min Int, [NodeEntry], Alt Maybe SrcCodeLoc) -> Min Int)
-> ((Key, (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc))
    -> (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc))
-> (Key, (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc))
-> Min Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key, (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc))
-> (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc)
forall a b. (a, b) -> b
snd)
                   ([(Key, (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc))]
 -> [(Key, ([NodeEntry], Maybe SrcCodeLoc))])
-> [(Key, (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc))]
-> [(Key, ([NodeEntry], Maybe SrcCodeLoc))]
forall a b. (a -> b) -> a -> b
$ Graph -> [(Key, (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc))]
forall k a. Map k a -> [(k, a)]
M.toList Graph
graph
    graphContent :: Builder
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 (Builder
output, [Builder]
_, Map Key (Key, Builder)
colorMap) =
            ((Builder, [Builder], Map Key (Key, Builder))
 -> (Key, ([NodeEntry], Maybe SrcCodeLoc))
 -> (Builder, [Builder], Map Key (Key, Builder)))
-> (Builder, [Builder], Map Key (Key, Builder))
-> [(Key, ([NodeEntry], Maybe SrcCodeLoc))]
-> (Builder, [Builder], Map Key (Key, Builder))
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
              (Map Key (Key, Builder)
-> (Builder, [Builder], Map Key (Key, Builder))
-> (Key, ([NodeEntry], Maybe SrcCodeLoc))
-> (Builder, [Builder], Map Key (Key, Builder))
forall (t :: * -> *).
Foldable t =>
Map Key (Key, Builder)
-> (Builder, [Builder], Map Key (Key, Builder))
-> (Key, ([NodeEntry], t SrcCodeLoc))
-> (Builder, [Builder], Map Key (Key, Builder))
doNode Map Key (Key, Builder)
colorMap)
              (Builder
forall a. Monoid a => a
mempty, [Builder] -> [Builder]
forall a. [a] -> [a]
cycle [Builder]
edgeColors, Map Key (Key, Builder)
forall a. Monoid a => a
mempty)
              [(Key, ([NodeEntry], Maybe SrcCodeLoc))]
orderedEntries
       in Builder
output

    header :: BSB.Builder
    header :: Builder
header = Builder
"digraph {\nnode [tooltip=\" \" shape=plaintext colorscheme=set28]\n"

    doNode :: Map Key (Key, Builder)
-> (Builder, [Builder], Map Key (Key, Builder))
-> (Key, ([NodeEntry], t SrcCodeLoc))
-> (Builder, [Builder], Map Key (Key, Builder))
doNode Map Key (Key, Builder)
finalColorMap (Builder
acc, [Builder]
colors, Map Key (Key, Builder)
colorMapAcc) (Key
key, ([NodeEntry]
entries, t SrcCodeLoc
mSrcLoc)) =
      let ([Builder]
cells, [Builder]
edges, [Builder]
colors', Map Key (Key, Builder)
colorMapAcc')
            = (([Builder], [Builder], [Builder], Map Key (Key, Builder))
 -> (NodeEntry, Word)
 -> ([Builder], [Builder], [Builder], Map Key (Key, Builder)))
-> ([Builder], [Builder], [Builder], Map Key (Key, Builder))
-> [(NodeEntry, Word)]
-> ([Builder], [Builder], [Builder], Map Key (Key, Builder))
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([Builder], [Builder], [Builder], Map Key (Key, Builder))
-> (NodeEntry, Word)
-> ([Builder], [Builder], [Builder], Map Key (Key, Builder))
doEntry ([], [], [Builder]
colors, Map Key (Key, Builder)
colorMapAcc) ([NodeEntry] -> [Word] -> [(NodeEntry, Word)]
forall a b. [a] -> [b] -> [(a, b)]
zip [NodeEntry]
entries [Word
1..])
          acc' :: Builder
acc' =
            -- don't render nodes that have in inbound edge but no content
            if [NodeEntry] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NodeEntry]
entries Bool -> Bool -> Bool
&& Maybe (Key, Builder) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Key, Builder)
mEdgeData
               then Builder
acc
               else Builder
tableStart
                 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Builder] -> Builder
tableEl [Builder]
cells
                 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
tableEnd
                 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Builder]
edges
                 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
acc
       in (Builder
acc', [Builder]
colors', Map Key (Key, Builder)
colorMapAcc')
      where
        keyStr :: Key -> Builder
keyStr (Key Word
i ByteString
k) = ByteString -> Builder
BSB.byteString ByteString
k Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word -> Builder
BSB.wordDec Word
i
        keyStrEsc :: Key -> Builder
keyStrEsc Key
k = Key -> Builder
keyStr Key
k { keyName :: ByteString
keyName = ByteString -> ByteString
htmlEscape (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Key -> ByteString
keyName Key
k }
        quoted :: a -> a
quoted a
bs = a
"\"" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
bs a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"\""
        -- Building a node
        mEdgeData :: Maybe (Key, Builder)
mEdgeData = Key -> Map Key (Key, Builder) -> Maybe (Key, Builder)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Key
key Map Key (Key, Builder)
finalColorMap
        nodeColor :: Maybe Builder
nodeColor = (Key, Builder) -> Builder
forall a b. (a, b) -> b
snd ((Key, Builder) -> Builder)
-> Maybe (Key, Builder) -> Maybe Builder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Key, Builder)
mEdgeData
        nodeToolTip :: Builder
nodeToolTip = (SrcCodeLoc -> Builder) -> t SrcCodeLoc -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Builder
"defined at " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>) (Builder -> Builder)
-> (SrcCodeLoc -> Builder) -> SrcCodeLoc -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcCodeLoc -> Builder
pprSrcCodeLoc) t SrcCodeLoc
mSrcLoc
        backHref :: Builder
backHref = ((Key, Builder) -> Builder) -> Maybe (Key, Builder) -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(Key
k, Builder
_) -> Builder
"#" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Key -> Builder
keyStr Key
k) Maybe (Key, Builder)
mEdgeData
        labelCell :: Builder
labelCell =
          Builder -> [Attr] -> [Builder] -> Builder
el Builder
"TR" []
            [ Builder -> [Attr] -> [Builder] -> Builder
el Builder
"TD" [ Builder
"HREF" Builder -> Builder -> Attr
.= Builder
backHref
                      , Builder
"TOOLTIP" Builder -> Builder -> Attr
.= Builder
nodeToolTip
                      , Builder
"BGCOLOR" Builder -> Maybe Builder -> Attr
.=? Maybe Builder
nodeColor
                      ]
                [ ((Key, Builder) -> Builder) -> Maybe (Key, Builder) -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Builder -> (Key, Builder) -> Builder
forall a b. a -> b -> a
const (Builder -> (Key, Builder) -> Builder)
-> Builder -> (Key, Builder) -> Builder
forall a b. (a -> b) -> a -> b
$ Builder -> [Attr] -> [Builder] -> Builder
el Builder
"FONT" [Builder
"POINT-SIZE" Builder -> Builder -> Attr
.= Builder
"7"] [Builder
"&larr;"])
                    Maybe (Key, Builder)
mEdgeData
                , Builder
" "
                , Builder -> [Attr] -> [Builder] -> Builder
el Builder
"B" [] [ ByteString -> Builder
BSB.byteString (ByteString -> Builder)
-> (ByteString -> ByteString) -> ByteString -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
htmlEscape (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ Key -> ByteString
keyName Key
key ]
                ]
            ]
        tableEl :: [Builder] -> Builder
tableEl [Builder]
cells =
          Builder -> [Attr] -> [Builder] -> Builder
el Builder
"TABLE" [ Builder
"BORDER" Builder -> Builder -> Attr
.= Builder
"0"
                     , Builder
"CELLBORDER" Builder -> Builder -> Attr
.= Builder
"1"
                     , Builder
"CELLSPACING" Builder -> Builder -> Attr
.= Builder
"0"
                     , Builder
"CELLPADDING" Builder -> Builder -> Attr
.= Builder
"4"
                     ]
            [ Builder
labelCell
            , [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Builder]
cells
            ]
        tableStart, tableEnd :: BSB.Builder
        tableStart :: Builder
tableStart = Builder -> Builder
forall a. (Semigroup a, IsString a) => a -> a
quoted (Key -> Builder
keyStr Key
key) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" [label=<\n"
        tableEnd :: Builder
tableEnd = Builder
">];"

        -- Building an entry in a node
        doEntry :: ([Builder], [Builder], [Builder], Map Key (Key, Builder))
-> (NodeEntry, Word)
-> ([Builder], [Builder], [Builder], Map Key (Key, Builder))
doEntry ([Builder]
cs, [Builder]
es, colors' :: [Builder]
colors'@(Builder
color:[Builder]
nextColors), Map Key (Key, Builder)
colorMap) (NodeEntry, Word)
ev = case (NodeEntry, Word)
ev of
          (Message ByteString
str Maybe SrcCodeLoc
mCallSite, Word
idx) ->
            let msgToolTip :: Builder
msgToolTip =
                  (SrcCodeLoc -> Builder) -> Maybe SrcCodeLoc -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Builder
"printed at " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>) (Builder -> Builder)
-> (SrcCodeLoc -> Builder) -> SrcCodeLoc -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcCodeLoc -> Builder
pprSrcCodeLoc) Maybe SrcCodeLoc
mCallSite
                msgEl :: Builder
msgEl =
                  Builder -> [Attr] -> [Builder] -> Builder
el Builder
"TR" []
                    [ Builder -> [Attr] -> [Builder] -> Builder
el Builder
"TD" [ Builder
"HREF" Builder -> Builder -> Attr
.= Builder
""
                              , Builder
"TOOLTIP" Builder -> Builder -> Attr
.= Builder
msgToolTip
                              , Builder
"ALIGN" Builder -> Builder -> Attr
.= Builder
"LEFT"
                              , Builder
"PORT" Builder -> Builder -> Attr
.= Word -> Builder
BSB.wordDec Word
idx
                              ]
                        [ ByteString -> Builder
BSB.byteString ByteString
str ]
                    ]
             in (Builder
msgEl Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
: [Builder]
cs, [Builder]
es, [Builder]
colors', Map Key (Key, Builder)
colorMap)
          (Edge Key
edgeKey Maybe SrcCodeLoc
mCallSite, Word
idx) ->
            let href :: Builder
href = (Builder -> Builder) -> Maybe Builder -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Builder -> Builder -> Builder
forall a b. a -> b -> a
const (Builder -> Builder -> Builder) -> Builder -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ Builder
"#" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Key -> Builder
keyStrEsc Key
edgeKey) Maybe Builder
mEdge
                elToolTip :: Builder
elToolTip =
                  (SrcCodeLoc -> Builder) -> Maybe SrcCodeLoc -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Builder
"called at " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>) (Builder -> Builder)
-> (SrcCodeLoc -> Builder) -> SrcCodeLoc -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcCodeLoc -> Builder
pprSrcCodeLoc) Maybe SrcCodeLoc
mCallSite
                edgeEl :: Builder
edgeEl =
                  Builder -> [Attr] -> [Builder] -> Builder
el Builder
"TR" []
                    [ Builder -> [Attr] -> [Builder] -> Builder
el Builder
"TD" [ Builder
"TOOLTIP" Builder -> Builder -> Attr
.= Builder
elToolTip
                              , Builder
"ALIGN" Builder -> Builder -> Attr
.= Builder
"LEFT"
                              , Builder
"CELLPADDING" Builder -> Builder -> Attr
.= Builder
"1"
                              , Builder
"BGCOLOR" Builder -> Builder -> Attr
.= Builder
color
                              , Builder
"PORT" Builder -> Builder -> Attr
.= Word -> Builder
BSB.wordDec Word
idx
                              , Builder
"HREF" Builder -> Builder -> Attr
.= Builder
href
                              ]
                        [ Builder -> [Attr] -> [Builder] -> Builder
el Builder
"FONT" [ Builder
"POINT-SIZE" Builder -> Builder -> Attr
.= Builder
"8" ]
                            [ ByteString -> Builder
BSB.byteString (ByteString -> Builder)
-> (ByteString -> ByteString) -> ByteString -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
htmlEscape (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ Key -> ByteString
keyName Key
edgeKey ]
                        ]
                    ]

                mEdge :: Maybe Builder
mEdge = do
                  (Min Int
_, [NodeEntry]
targetContent, Alt Maybe SrcCodeLoc
_) <- Key -> Graph -> Maybe (Min Int, [NodeEntry], Alt Maybe SrcCodeLoc)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Key
edgeKey Graph
graph
                  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (Bool -> Bool) -> Bool -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ [NodeEntry] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NodeEntry]
targetContent
                  Builder -> Maybe Builder
forall a. a -> Maybe a
Just (Builder -> Maybe Builder) -> Builder -> Maybe Builder
forall a b. (a -> b) -> a -> b
$
                    Builder -> Builder
forall a. (Semigroup a, IsString a) => a -> a
quoted (Key -> Builder
keyStr Key
key) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
":" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word -> Builder
BSB.wordDec Word
idx
                    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" -> " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
forall a. (Semigroup a, IsString a) => a -> a
quoted (Key -> Builder
keyStr Key
edgeKey)
                    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" [tooltip=\" \" colorscheme=set28 color=" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
color Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"];"

             in ( Builder
edgeEl Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
: [Builder]
cs
                , ([Builder] -> [Builder])
-> (Builder -> [Builder] -> [Builder])
-> Maybe Builder
-> [Builder]
-> [Builder]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Builder] -> [Builder]
forall a. a -> a
id (:) Maybe Builder
mEdge [Builder]
es
                , [Builder]
nextColors
                , Key
-> (Key, Builder)
-> Map Key (Key, Builder)
-> Map Key (Key, Builder)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Key
edgeKey (Key
key, Builder
color) Map Key (Key, Builder)
colorMap
                )
        doEntry ([Builder], [Builder], [Builder], Map Key (Key, Builder))
ac (NodeEntry, Word)
_ = ([Builder], [Builder], [Builder], Map Key (Key, Builder))
ac

type Element = BSB.Builder
type Attr = (BSB.Builder, Maybe BSB.Builder)

(.=) :: BSB.Builder -> BSB.Builder -> Attr
Builder
name .= :: Builder -> Builder -> Attr
.= Builder
val = Builder
name Builder -> Maybe Builder -> Attr
.=? Builder -> Maybe Builder
forall a. a -> Maybe a
Just Builder
val

(.=?) :: BSB.Builder -> Maybe BSB.Builder -> Attr
Builder
name .=? :: Builder -> Maybe Builder -> Attr
.=? Maybe Builder
val = (Builder
name, Maybe Builder
val)

el :: BSB.Builder -> [Attr] -> [BSB.Builder] -> Element
el :: Builder -> [Attr] -> [Builder] -> Builder
el Builder
name [Attr]
attrs [Builder]
children =
  Builder
"<" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
name Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Attr -> Builder) -> [Attr] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Attr -> Builder
forall p. (IsString p, Monoid p) => (p, Maybe p) -> p
renderAttr [Attr]
attrs Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
">"
  Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Builder]
children Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"</" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
name Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
">"
  where
    renderAttr :: (p, Maybe p) -> p
renderAttr (p
aName, Just p
aVal) = p
" " p -> p -> p
forall a. Semigroup a => a -> a -> a
<> p
aName p -> p -> p
forall a. Semigroup a => a -> a -> a
<> p
"=\"" p -> p -> p
forall a. Semigroup a => a -> a -> a
<> p
aVal p -> p -> p
forall a. Semigroup a => a -> a -> a
<> p
"\""
    renderAttr (p
_, Maybe p
Nothing) = p
forall a. Monoid a => a
mempty

edgeColors :: [BSB.Builder]
edgeColors :: [Builder]
edgeColors = Int -> Builder
BSB.intDec (Int -> Builder) -> [Int] -> [Builder]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
1..Int
8 :: Int]

pprSrcCodeLoc :: SrcCodeLoc -> BSB.Builder
pprSrcCodeLoc :: SrcCodeLoc -> Builder
pprSrcCodeLoc SrcCodeLoc
loc
  = ByteString -> Builder
BSB.byteString (SrcCodeLoc -> ByteString
srcMod SrcCodeLoc
loc) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
":"
 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
BSB.intDec (SrcCodeLoc -> Int
srcLine SrcCodeLoc
loc) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
":"
 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
BSB.intDec (SrcCodeLoc -> Int
srcCol SrcCodeLoc
loc)