{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
module Graph.Trace.Dot
  ( parseLogEntries
  , parseLogEntry
  , buildTree
  , buildNexus
  , graphToDot
  , Key(..)
  , LogEntry(..)
  ) where

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.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(..))

--------------------------------------------------------------------------------
-- Types
--------------------------------------------------------------------------------

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)

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 Int -> NodeEntry key -> ShowS
[NodeEntry key] -> ShowS
NodeEntry key -> String
(Int -> NodeEntry key -> ShowS)
-> (NodeEntry key -> String)
-> ([NodeEntry key] -> ShowS)
-> Show (NodeEntry key)
forall key. Show key => Int -> NodeEntry key -> ShowS
forall key. Show key => [NodeEntry key] -> ShowS
forall key. Show key => NodeEntry key -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NodeEntry key] -> ShowS
$cshowList :: forall key. Show key => [NodeEntry key] -> ShowS
show :: NodeEntry key -> String
$cshow :: forall key. Show key => NodeEntry key -> String
showsPrec :: Int -> NodeEntry key -> ShowS
$cshowsPrec :: forall key. Show key => Int -> NodeEntry key -> ShowS
Show

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 { NexusKey -> ByteString
nexKeyName :: !BS.ByteString, NexusKey -> ByteString
nexKeyHash :: !BS.ByteString }
  deriving (NexusKey -> NexusKey -> Bool
(NexusKey -> NexusKey -> Bool)
-> (NexusKey -> NexusKey -> Bool) -> Eq NexusKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NexusKey -> NexusKey -> Bool
$c/= :: NexusKey -> NexusKey -> Bool
== :: NexusKey -> NexusKey -> Bool
$c== :: NexusKey -> NexusKey -> Bool
Eq, Eq NexusKey
Eq NexusKey
-> (NexusKey -> NexusKey -> Ordering)
-> (NexusKey -> NexusKey -> Bool)
-> (NexusKey -> NexusKey -> Bool)
-> (NexusKey -> NexusKey -> Bool)
-> (NexusKey -> NexusKey -> Bool)
-> (NexusKey -> NexusKey -> NexusKey)
-> (NexusKey -> NexusKey -> NexusKey)
-> Ord NexusKey
NexusKey -> NexusKey -> Bool
NexusKey -> NexusKey -> Ordering
NexusKey -> NexusKey -> NexusKey
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 :: NexusKey -> NexusKey -> NexusKey
$cmin :: NexusKey -> NexusKey -> NexusKey
max :: NexusKey -> NexusKey -> NexusKey
$cmax :: NexusKey -> NexusKey -> NexusKey
>= :: NexusKey -> NexusKey -> Bool
$c>= :: NexusKey -> NexusKey -> Bool
> :: NexusKey -> NexusKey -> Bool
$c> :: NexusKey -> NexusKey -> Bool
<= :: NexusKey -> NexusKey -> Bool
$c<= :: NexusKey -> NexusKey -> Bool
< :: NexusKey -> NexusKey -> Bool
$c< :: NexusKey -> NexusKey -> Bool
compare :: NexusKey -> NexusKey -> Ordering
$ccompare :: NexusKey -> NexusKey -> Ordering
$cp1Ord :: Eq NexusKey
Ord, Int -> NexusKey -> ShowS
[NexusKey] -> ShowS
NexusKey -> String
(Int -> NexusKey -> ShowS)
-> (NexusKey -> String) -> ([NexusKey] -> ShowS) -> Show NexusKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NexusKey] -> ShowS
$cshowList :: [NexusKey] -> ShowS
show :: NexusKey -> String
$cshow :: NexusKey -> String
showsPrec :: Int -> NexusKey -> ShowS
$cshowsPrec :: Int -> NexusKey -> ShowS
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 :: NexusKey -> ByteString
getKeyName = NexusKey -> ByteString
nexKeyName
  keyStr :: NexusKey -> Builder
keyStr (NexusKey ByteString
name ByteString
hash) = ByteString -> Builder
BSB.byteString ByteString
name Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
BSB.byteString ByteString
hash
  keyStrEsc :: NexusKey -> Builder
keyStrEsc NexusKey
k = NexusKey -> Builder
forall key. IsKey key => key -> Builder
keyStr NexusKey
k { nexKeyName :: ByteString
nexKeyName = ByteString -> ByteString
htmlEscape (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ NexusKey -> ByteString
nexKeyName NexusKey
k }

instance IsKey Key where
  getKeyName :: Key -> ByteString
getKeyName = Key -> ByteString
keyName
  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
forall key. IsKey key => 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 }

--------------------------------------------------------------------------------
-- Parsing
--------------------------------------------------------------------------------

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)

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
"§§§"

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

--------------------------------------------------------------------------------
-- Graph construction
--------------------------------------------------------------------------------

buildTree :: [LogEntry] -> Tree
buildTree :: [LogEntry] -> Tree
buildTree = (Tree -> LogEntry -> Tree) -> Tree -> [LogEntry] -> Tree
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Tree -> LogEntry -> Tree
build Tree
forall a. Monoid a => a
mempty where
  build :: Tree -> LogEntry -> Tree
build Tree
graph LogEntry
entry =
    case LogEntry
entry of
      Trace Key
tag ByteString
msg Maybe SrcCodeLoc
callSite ->
        ((Min Int,
  ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key)))
 -> (Min Int,
     ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key)))
 -> (Min Int,
     ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key))))
-> Key
-> (Min Int,
    ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key)))
-> Tree
-> Tree
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (Min Int,
 ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key)))
-> (Min Int,
    ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key)))
-> (Min Int,
    ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key)))
forall a. Semigroup a => a -> a -> a
(<>)
          Key
tag
          (Min Int
graphSize, ([ByteString -> Maybe SrcCodeLoc -> NodeEntry Key
forall key. ByteString -> Maybe SrcCodeLoc -> NodeEntry key
Message ByteString
msg Maybe SrcCodeLoc
callSite], Alt Maybe SrcCodeLoc
forall a. Monoid a => a
mempty, Alt Maybe (Maybe Key)
forall a. Monoid a => a
mempty))
          Tree
graph

      Entry Key
curTag (Just Key
prevTag) Maybe SrcCodeLoc
defSite Maybe SrcCodeLoc
callSite ->
          ((Min Int,
  ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key)))
 -> (Min Int,
     ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key)))
 -> (Min Int,
     ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key))))
-> Key
-> (Min Int,
    ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key)))
-> Tree
-> Tree
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (Min Int,
 ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key)))
-> (Min Int,
    ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key)))
-> (Min Int,
    ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key)))
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, Maybe (Maybe Key) -> Alt Maybe (Maybe Key)
forall k (f :: k -> *) (a :: k). f a -> Alt f a
Alt (Maybe (Maybe Key) -> Alt Maybe (Maybe Key))
-> (Maybe Key -> Maybe (Maybe Key))
-> Maybe Key
-> Alt Maybe (Maybe Key)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> Maybe (Maybe Key)
forall a. a -> Maybe a
Just (Maybe Key -> Alt Maybe (Maybe Key))
-> Maybe Key -> Alt Maybe (Maybe Key)
forall a b. (a -> b) -> a -> b
$ Key -> Maybe Key
forall a. a -> Maybe a
Just Key
prevTag))
        (Tree -> Tree) -> Tree -> Tree
forall a b. (a -> b) -> a -> b
$ ((Min Int,
  ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key)))
 -> (Min Int,
     ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key)))
 -> (Min Int,
     ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key))))
-> Key
-> (Min Int,
    ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key)))
-> Tree
-> Tree
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (Min Int,
 ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key)))
-> (Min Int,
    ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key)))
-> (Min Int,
    ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key)))
forall a. Semigroup a => a -> a -> a
(<>)
            Key
prevTag
            (Min Int
graphSize, ([Key -> Maybe SrcCodeLoc -> NodeEntry Key
forall key. key -> Maybe SrcCodeLoc -> NodeEntry key
Edge Key
curTag Maybe SrcCodeLoc
callSite], Alt Maybe SrcCodeLoc
forall a. Monoid a => a
mempty, Alt Maybe (Maybe Key)
forall a. Monoid a => a
mempty))
            Tree
graph

      Entry Key
curTag Maybe Key
Nothing Maybe SrcCodeLoc
defSite Maybe SrcCodeLoc
_ ->
        ((Min Int,
  ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key)))
 -> (Min Int,
     ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key)))
 -> (Min Int,
     ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key))))
-> Key
-> (Min Int,
    ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key)))
-> Tree
-> Tree
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (Min Int,
 ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key)))
-> (Min Int,
    ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key)))
-> (Min Int,
    ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key)))
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, Alt Maybe (Maybe Key)
forall a. Monoid a => a
mempty))
          Tree
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
$ Tree -> Int
forall k a. Map k a -> Int
M.size Tree
graph

-- | Constructs a nexus by merging tree nodes that have identical content based
-- on their hash.
buildNexus :: Tree -> Nexus
buildNexus :: Tree -> Nexus
buildNexus Tree
tree =
  let hashes :: Map Key ByteString
hashes = Tree -> Map Key ByteString
calcHashes Tree
tree
      toNexusKey :: Key -> NexusKey
toNexusKey Key
key =
        case Key -> Map Key ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Key
key Map Key ByteString
hashes of
          Maybe ByteString
Nothing -> String -> NexusKey
forall a. HasCallStack => String -> a
error String
"missing hash"
          Just ByteString
hash ->
            NexusKey :: ByteString -> ByteString -> NexusKey
NexusKey { nexKeyName :: ByteString
nexKeyName = Key -> ByteString
keyName Key
key, nexKeyHash :: ByteString
nexKeyHash = ByteString
hash }

      mapNode :: ((a, (f (NodeEntry Key), b, Alt Maybe (Maybe Key))), Bool)
-> (a, (f (NodeEntry NexusKey), b, Alt Maybe (Maybe NexusKey)))
mapNode ((a
order, (f (NodeEntry Key)
entries, b
loc, Alt Maybe (Maybe Key)
mKey)), Bool
multipleParents) =
        (a
order, ( NodeEntry Key -> NodeEntry NexusKey
mapEntry (NodeEntry Key -> NodeEntry NexusKey)
-> f (NodeEntry Key) -> f (NodeEntry NexusKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (NodeEntry Key)
entries
                , b
loc
                , if Bool
multipleParents
                     then Maybe (Maybe NexusKey) -> Alt Maybe (Maybe NexusKey)
forall k (f :: k -> *) (a :: k). f a -> Alt f a
Alt (Maybe NexusKey -> Maybe (Maybe NexusKey)
forall a. a -> Maybe a
Just Maybe NexusKey
forall a. Maybe a
Nothing)
                     else (Key -> NexusKey) -> Maybe Key -> Maybe NexusKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Key -> NexusKey
toNexusKey (Maybe Key -> Maybe NexusKey)
-> Alt Maybe (Maybe Key) -> Alt Maybe (Maybe NexusKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Alt Maybe (Maybe Key)
mKey
                )
        )

      mapEntry :: NodeEntry Key -> NodeEntry NexusKey
mapEntry = \case
        Message ByteString
msg Maybe SrcCodeLoc
loc -> ByteString -> Maybe SrcCodeLoc -> NodeEntry NexusKey
forall key. ByteString -> Maybe SrcCodeLoc -> NodeEntry key
Message ByteString
msg Maybe SrcCodeLoc
loc
        Edge Key
key Maybe SrcCodeLoc
loc ->
          let nexKey :: NexusKey
nexKey = Key -> NexusKey
toNexusKey Key
key
           in NexusKey -> Maybe SrcCodeLoc -> NodeEntry NexusKey
forall key. key -> Maybe SrcCodeLoc -> NodeEntry key
Edge NexusKey
nexKey
                   Maybe SrcCodeLoc
loc

      -- Used to determine if a node has inbound edges from two different parents
      multipleInEdges :: ((a, (a, b, Alt Maybe (Maybe Key))), Bool)
-> ((a, (a, b, Alt Maybe (Maybe Key))), Bool)
-> ((a, (a, b, Alt Maybe (Maybe Key))), Bool)
multipleInEdges
          a :: ((a, (a, b, Alt Maybe (Maybe Key))), Bool)
a@((a
_, (a
_, b
_, Alt Maybe (Maybe Key)
ia)), Bool
multInA)
          ((a
_, (a
_, b
_, Alt Maybe (Maybe Key)
ib)), Bool
multInB) =
        case NexusKey -> NexusKey -> Bool
forall a. Eq a => a -> a -> Bool
(==) (NexusKey -> NexusKey -> Bool)
-> Maybe NexusKey -> Maybe (NexusKey -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Key -> NexusKey
toNexusKey (Key -> NexusKey) -> Maybe Key -> Maybe NexusKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Maybe Key) -> Maybe Key
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join Maybe (Maybe Key)
ia) Maybe (NexusKey -> Bool) -> Maybe NexusKey -> Maybe Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Key -> NexusKey
toNexusKey (Key -> NexusKey) -> Maybe Key -> Maybe NexusKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Maybe Key) -> Maybe Key
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join Maybe (Maybe Key)
ib) of
          (Just Bool
False) -> (((a, (a, b, Alt Maybe (Maybe Key))), Bool)
-> (a, (a, b, Alt Maybe (Maybe Key)))
forall a b. (a, b) -> a
fst ((a, (a, b, Alt Maybe (Maybe Key))), Bool)
a, Bool
True)
          Maybe Bool
_ -> (((a, (a, b, Alt Maybe (Maybe Key))), Bool)
-> (a, (a, b, Alt Maybe (Maybe Key)))
forall a b. (a, b) -> a
fst ((a, (a, b, Alt Maybe (Maybe Key))), Bool)
a, Bool
multInA Bool -> Bool -> Bool
|| Bool
multInB)

   in (((Min Int,
   ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key))),
  Bool)
 -> (Min Int,
     ([NodeEntry NexusKey], Alt Maybe SrcCodeLoc,
      Alt Maybe (Maybe NexusKey))))
-> Map
     NexusKey
     ((Min Int,
       ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key))),
      Bool)
-> Nexus
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((Min Int,
  ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key))),
 Bool)
-> (Min Int,
    ([NodeEntry NexusKey], Alt Maybe SrcCodeLoc,
     Alt Maybe (Maybe NexusKey)))
forall (f :: * -> *) a b.
Functor f =>
((a, (f (NodeEntry Key), b, Alt Maybe (Maybe Key))), Bool)
-> (a, (f (NodeEntry NexusKey), b, Alt Maybe (Maybe NexusKey)))
mapNode (Map
   NexusKey
   ((Min Int,
     ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key))),
    Bool)
 -> Nexus)
-> Map
     NexusKey
     ((Min Int,
       ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key))),
      Bool)
-> Nexus
forall a b. (a -> b) -> a -> b
$
        (((Min Int,
   ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key))),
  Bool)
 -> ((Min Int,
      ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key))),
     Bool)
 -> ((Min Int,
      ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key))),
     Bool))
-> (Key -> NexusKey)
-> Map
     Key
     ((Min Int,
       ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key))),
      Bool)
-> Map
     NexusKey
     ((Min Int,
       ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key))),
      Bool)
forall k2 a k1.
Ord k2 =>
(a -> a -> a) -> (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeysWith
          ((Min Int,
  ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key))),
 Bool)
-> ((Min Int,
     ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key))),
    Bool)
-> ((Min Int,
     ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key))),
    Bool)
forall a a b a a b.
((a, (a, b, Alt Maybe (Maybe Key))), Bool)
-> ((a, (a, b, Alt Maybe (Maybe Key))), Bool)
-> ((a, (a, b, Alt Maybe (Maybe Key))), Bool)
multipleInEdges
          Key -> NexusKey
toNexusKey
          ((,Bool
False) ((Min Int,
  ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key)))
 -> ((Min Int,
      ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key))),
     Bool))
-> Tree
-> Map
     Key
     ((Min Int,
       ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key))),
      Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tree
tree)

-- | Produce a mapping of tree keys to the hash for that node.
calcHashes :: Tree -> M.Map Key BS.ByteString
calcHashes :: Tree -> Map Key ByteString
calcHashes Tree
tree =
  -- this relies on knot tying and must therefore use the lazy Map api
  let hashes :: Map Key ByteString
hashes = (Map Key ByteString
 -> Key
 -> (Min Int,
     ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key)))
 -> Map Key ByteString)
-> Map Key ByteString -> Tree -> Map Key ByteString
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
ML.foldlWithKey Map Key ByteString
-> Key
-> (Min Int,
    ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key)))
-> Map Key ByteString
buildHash Map Key ByteString
forall a. Monoid a => a
mempty Tree
tree

      buildHash :: Map Key ByteString
-> Key
-> (Min Int,
    ([NodeEntry Key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe Key)))
-> Map Key ByteString
buildHash Map Key ByteString
acc Key
key (Min Int
_, ([NodeEntry Key]
entries, Alt Maybe SrcCodeLoc
defSite, Alt Maybe (Maybe Key)
_)) =
        let entryHashes :: Builder
entryHashes = (NodeEntry Key -> Builder) -> [NodeEntry Key] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap NodeEntry Key -> Builder
hashEntry [NodeEntry Key]
entries
            hash :: ByteString
hash = ByteString -> ByteString
Base16.encode (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Sha.hash
                 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Key -> ByteString
keyName Key
key
                ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
BSL.toStrict (Builder -> ByteString
BSB.toLazyByteString Builder
entryHashes)
                ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> String -> ByteString
BS8.pack (Alt Maybe SrcCodeLoc -> String
forall a. Show a => a -> String
show Alt Maybe SrcCodeLoc
defSite)
         in Key -> ByteString -> Map Key ByteString -> Map Key ByteString
forall k a. Ord k => k -> a -> Map k a -> Map k a
ML.insert Key
key ByteString
hash Map Key ByteString
acc

      hashEntry :: NodeEntry Key -> Builder
hashEntry = \case
        Message ByteString
msg Maybe SrcCodeLoc
loc ->
          ByteString -> Builder
BSB.byteString (ByteString -> Builder)
-> (ByteString -> ByteString) -> ByteString -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base16.encode (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Sha.hash
            (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ ByteString
msg ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> String -> ByteString
BS8.pack (Maybe SrcCodeLoc -> String
forall a. Show a => a -> String
show Maybe SrcCodeLoc
loc)
        Edge Key
key Maybe SrcCodeLoc
_ -> ByteString -> Builder
BSB.byteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ ByteString -> Key -> Map Key ByteString -> ByteString
forall k a. Ord k => a -> k -> Map k a -> a
ML.findWithDefault ByteString
forall a. Monoid a => a
mempty Key
key Map Key ByteString
hashes
   in Map Key ByteString
hashes

--------------------------------------------------------------------------------
-- Dot
--------------------------------------------------------------------------------

graphToDot :: IsKey key => Graph key -> BSB.Builder
graphToDot :: Graph key -> Builder
graphToDot Graph key
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 key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key)))]
orderedEntries = ((key,
  (Min Int,
   ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key))))
 -> (key,
     ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key))))
-> [(key,
     (Min Int,
      ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key))))]
-> [(key,
     ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key)))]
forall a b. (a -> b) -> [a] -> [b]
map (((Min Int,
  ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key)))
 -> ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key)))
-> (key,
    (Min Int,
     ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key))))
-> (key,
    ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key)))
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Min Int,
 ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key)))
-> ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key))
forall a b. (a, b) -> b
snd)
                   ([(key,
   (Min Int,
    ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key))))]
 -> [(key,
      ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key)))])
-> ([(key,
      (Min Int,
       ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key))))]
    -> [(key,
         (Min Int,
          ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key))))])
-> [(key,
     (Min Int,
      ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key))))]
-> [(key,
     ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key)))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((key,
  (Min Int,
   ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key))))
 -> Down (Min Int))
-> [(key,
     (Min Int,
      ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key))))]
-> [(key,
     (Min Int,
      ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key))))]
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 key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key))))
    -> Min Int)
-> (key,
    (Min Int,
     ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key))))
-> Down (Min Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Min Int,
 ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key)))
-> Min Int
forall a b. (a, b) -> a
fst ((Min Int,
  ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key)))
 -> Min Int)
-> ((key,
     (Min Int,
      ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key))))
    -> (Min Int,
        ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key))))
-> (key,
    (Min Int,
     ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key))))
-> Min Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (key,
 (Min Int,
  ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key))))
-> (Min Int,
    ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key)))
forall a b. (a, b) -> b
snd)
                   ([(key,
   (Min Int,
    ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key))))]
 -> [(key,
      ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key)))])
-> [(key,
     (Min Int,
      ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key))))]
-> [(key,
     ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key)))]
forall a b. (a -> b) -> a -> b
$ Graph key
-> [(key,
     (Min Int,
      ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key))))]
forall k a. Map k a -> [(k, a)]
M.toList Graph key
graph
    graphContent :: Builder
graphContent =
      let (Builder
output, [Builder]
_, Map key Builder
colorMap) =
            ((Builder, [Builder], Map key Builder)
 -> (key,
     ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key)))
 -> (Builder, [Builder], Map key Builder))
-> (Builder, [Builder], Map key Builder)
-> [(key,
     ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key)))]
-> (Builder, [Builder], Map key Builder)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
              (Map key Builder
-> (Builder, [Builder], Map key Builder)
-> (key,
    ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key)))
-> (Builder, [Builder], Map key Builder)
forall key (t :: * -> *) a (t :: * -> *).
(IsKey a, Foldable t, Foldable t, IsKey key) =>
Map key Builder
-> (Builder, [Builder], Map key Builder)
-> (key, ([NodeEntry key], Alt t SrcCodeLoc, Alt Maybe (t a)))
-> (Builder, [Builder], Map key Builder)
doNode Map key Builder
colorMap)
              (Builder
forall a. Monoid a => a
mempty, [Builder] -> [Builder]
forall a. [a] -> [a]
cycle [Builder]
edgeColors, Map key Builder
forall a. Monoid a => a
mempty)
              [(key,
  ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key)))]
orderedEntries
       in Builder
output

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

    doNode :: Map key Builder
-> (Builder, [Builder], Map key Builder)
-> (key, ([NodeEntry key], Alt t SrcCodeLoc, Alt Maybe (t a)))
-> (Builder, [Builder], Map key Builder)
doNode Map key Builder
finalColorMap (Builder
acc, [Builder]
colors, Map key Builder
colorMapAcc)
                         (key
key, ([NodeEntry key]
entries, Alt t SrcCodeLoc
mSrcLoc, Alt Maybe (t a)
mBacklink)) =
      let ([Builder]
cells, [Builder]
edges, [Builder]
colors', Map key Builder
colorMapAcc')
            = (([Builder], [Builder], [Builder], Map key Builder)
 -> (NodeEntry key, Word)
 -> ([Builder], [Builder], [Builder], Map key Builder))
-> ([Builder], [Builder], [Builder], Map key Builder)
-> [(NodeEntry key, Word)]
-> ([Builder], [Builder], [Builder], Map key Builder)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([Builder], [Builder], [Builder], Map key Builder)
-> (NodeEntry key, Word)
-> ([Builder], [Builder], [Builder], Map key Builder)
doEntry ([], [], [Builder]
colors, Map key Builder
colorMapAcc) ([NodeEntry key] -> [Word] -> [(NodeEntry key, Word)]
forall a b. [a] -> [b] -> [(a, b)]
zip [NodeEntry key]
entries [Word
1..])
          acc' :: Builder
acc' =
            -- don't render nodes that have inbound edge(s) but no content
            if [NodeEntry key] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NodeEntry key]
entries Bool -> Bool -> Bool
&& Maybe (t a) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (t a)
mBacklink
               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 Builder
colorMapAcc')
      where
        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
        nodeColor :: Maybe Builder
nodeColor = key -> Map key Builder -> Maybe Builder
forall k a. Ord k => k -> Map k a -> Maybe a
ML.lookup key
key Map key Builder
finalColorMap
        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 = ((t a -> Builder) -> Maybe (t a) -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((t a -> Builder) -> Maybe (t a) -> Builder)
-> ((a -> Builder) -> t a -> Builder)
-> (a -> Builder)
-> Maybe (t a)
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Builder) -> t a -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap) (\a
k -> Builder
"#" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> a -> Builder
forall key. IsKey key => key -> Builder
keyStr a
k) Maybe (t a)
mBacklink
        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
                      ]
                [ ((t a -> Builder) -> Maybe (t a) -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((t a -> Builder) -> Maybe (t a) -> Builder)
-> ((a -> Builder) -> t a -> Builder)
-> (a -> Builder)
-> Maybe (t a)
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Builder) -> t a -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap) (Builder -> a -> Builder
forall a b. a -> b -> a
const (Builder -> a -> Builder) -> Builder -> a -> 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 (t a)
mBacklink
                , 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
forall key. IsKey key => key -> ByteString
getKeyName 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
forall key. IsKey key => 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 Builder)
-> (NodeEntry key, Word)
-> ([Builder], [Builder], [Builder], Map key Builder)
doEntry ([Builder]
cs, [Builder]
es, colors' :: [Builder]
colors'@(Builder
color:[Builder]
nextColors), Map key Builder
colorMap) = \case
          (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 Builder
colorMap)
          (Edge key
edgeKey Maybe SrcCodeLoc
mCallSite, Word
idx) ->
            let mTargetNode :: Maybe
  (Min Int,
   ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key)))
mTargetNode = key
-> Graph key
-> Maybe
     (Min Int,
      ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key)))
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup key
edgeKey Graph key
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 :: Builder
edgeColor =
                  case Maybe
  (Min Int,
   ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key)))
mTargetNode of
                    Just (Min Int
_, ([NodeEntry key]
content, Alt Maybe SrcCodeLoc
_, Alt Maybe (Maybe key)
_))
                      | Bool -> Bool
not ([NodeEntry key] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NodeEntry key]
content) ->
                          Builder -> key -> Map key Builder -> Builder
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Builder
color key
edgeKey Map key Builder
colorMap
                    Maybe
  (Min Int,
   ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key)))
_ -> Builder
color
                -- TODO ^ don't need this lookup if not a nexus
                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
forall key. IsKey key => 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
edgeColor
                              , 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
forall key. IsKey key => key -> ByteString
getKeyName key
edgeKey ]
                        ]
                    ]

                mEdge :: Maybe Builder
mEdge = do
                  (Min Int
_, ([NodeEntry key]
targetContent, Alt Maybe SrcCodeLoc
_, Alt Maybe (Maybe key)
_)) <- Maybe
  (Min Int,
   ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key)))
mTargetNode
                  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 key] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NodeEntry key]
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
forall key. IsKey key => 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
forall key. IsKey key => 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
edgeColor 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 -> Builder -> Map key Builder -> Map key Builder
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert key
edgeKey Builder
edgeColor Map key Builder
colorMap
                )
        doEntry ([Builder], [Builder], [Builder], Map key Builder)
_ = (NodeEntry key, Word)
-> ([Builder], [Builder], [Builder], Map key Builder)
forall a. Monoid a => a
mempty

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 :: [Color]
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)