{-# LANGUAGE CPP #-}
{-# 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
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
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
Ord, Int -> Key -> ShowS
[Key] -> ShowS
Key -> String
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
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
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
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
Ord, Int -> SrcCodeLoc -> ShowS
[SrcCodeLoc] -> ShowS
SrcCodeLoc -> String
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
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

-- 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
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
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
Ord, Int -> NexusKey -> ShowS
[NexusKey] -> ShowS
NexusKey -> String
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 forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
BSB.byteString ByteString
hash
  keyStrEsc :: NexusKey -> Builder
keyStrEsc NexusKey
k = forall key. IsKey key => key -> Builder
keyStr NexusKey
k { nexKeyName :: ByteString
nexKeyName = ByteString -> ByteString
htmlEscape 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 forall a. Semigroup a => a -> a -> a
<> Word -> Builder
BSB.wordDec Word
i
  keyStrEsc :: Key -> Builder
keyStrEsc Key
k = forall key. IsKey key => key -> Builder
keyStr Key
k { keyName :: ByteString
keyName = ByteString -> ByteString
htmlEscape 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 =
  forall a. Parser a -> ByteString -> Either String a
AttoL.parseOnly (forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
AttoL.many' Parser LogEntry
parseLogEntry forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall t. Chunk t => Parser t ()
AttoL.endOfInput)
#if !MIN_VERSION_attoparsec(0,14,0)
  . BSL.toStrict
#endif

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

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

parseEntryEvent :: Atto.Parser LogEntry
parseEntryEvent :: Parser LogEntry
parseEntryEvent = do
  ByteString
_ <- ByteString -> Parser ByteString ByteString
Atto.string ByteString
"entry§"
  Key
curKey <- Parser Key
parseKey
  Maybe Key
mPrevKey <- forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Key
parseKey
          forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString ByteString
Atto.string ByteString
"§§"
  Maybe SrcCodeLoc
defSite <- Parser (Maybe SrcCodeLoc)
parseSrcCodeLoc
  Maybe SrcCodeLoc
callSite <- Parser (Maybe SrcCodeLoc)
parseSrcCodeLoc
  String
_ <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
Atto.many' Parser Char
Atto.space
  forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 LogEntry
parseTraceEvent = do
  ByteString
_ <- ByteString -> Parser ByteString ByteString
Atto.string ByteString
"trace§"
  Key
key <- Parser Key
parseKey
  ByteString
message <- (Char -> Bool) -> Parser ByteString ByteString
Atto.takeTill (forall a. Eq a => a -> a -> Bool
== Char
'§') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
Atto.char Char
'§'
  Maybe SrcCodeLoc
callSite <- Parser (Maybe SrcCodeLoc)
parseSrcCodeLoc
  String
_ <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
Atto.many' Parser Char
Atto.space
  let removeNewlines :: ByteString -> ByteString
removeNewlines = [ByteString] -> ByteString
BS8.unwords forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
BS8.lines
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Key -> ByteString -> Maybe SrcCodeLoc -> LogEntry
Trace Key
key (ByteString -> ByteString
htmlEscape forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
removeNewlines 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 ByteString
Atto.takeTill (forall a. Eq a => a -> a -> Bool
== Char
'§') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
Atto.char Char
'§'
        Int
srcLine <- forall a. Integral a => Parser a
Atto.decimal forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
Atto.char Char
'§'
        Int
srcCol <- forall a. Integral a => Parser a
Atto.decimal forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
Atto.char Char
'§'
        forall (f :: * -> *) a. Applicative f => a -> f a
pure SrcCodeLoc{Int
ByteString
srcCol :: Int
srcLine :: Int
srcMod :: ByteString
srcCol :: Int
srcLine :: Int
srcMod :: ByteString
..}
  forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString SrcCodeLoc
parseLoc forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString 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 = 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 (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 forall a. Semigroup a => a -> a -> a
<> ByteString
re forall a. Semigroup a => a -> a -> a
<> HasCallStack => 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 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Tree -> LogEntry -> Tree
build 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 ->
        forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith forall a. Semigroup a => a -> a -> a
(<>)
          Key
tag
          (Min Int
graphSize, ([forall key. ByteString -> Maybe SrcCodeLoc -> NodeEntry key
Message ByteString
msg Maybe SrcCodeLoc
callSite], forall a. Monoid a => a
mempty, forall a. Monoid a => a
mempty))
          Tree
graph

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

      Entry Key
curTag Maybe Key
Nothing Maybe SrcCodeLoc
defSite Maybe SrcCodeLoc
_ ->
        forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith forall a. Semigroup a => a -> a -> a
(<>)
          Key
curTag
          (Min Int
graphSize, ([], forall {k} (f :: k -> *) (a :: k). f a -> Alt f a
Alt Maybe SrcCodeLoc
defSite, forall a. Monoid a => a
mempty))
          Tree
graph
    where
      graphSize :: Min Int
graphSize = forall a. a -> Min a
Min forall a b. (a -> b) -> a -> b
$ 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 forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Key
key Map Key ByteString
hashes of
          Maybe ByteString
Nothing -> forall a. HasCallStack => String -> a
error String
"missing hash"
          Just ByteString
hash ->
            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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (NodeEntry Key)
entries
                , b
loc
                , if Bool
multipleParents
                     then forall {k} (f :: k -> *) (a :: k). f a -> Alt f a
Alt (forall a. a -> Maybe a
Just forall a. Maybe a
Nothing)
                     else forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Key -> NexusKey
toNexusKey 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 -> 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 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 forall a. Eq a => a -> a -> Bool
(==) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Key -> NexusKey
toNexusKey forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Monad m => m (m a) -> m a
join Maybe (Maybe Key)
ia) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Key -> NexusKey
toNexusKey forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Monad m => m (m a) -> m a
join Maybe (Maybe Key)
ib) of
          (Just Bool
False) -> (forall a b. (a, b) -> a
fst ((a, (a, b, Alt Maybe (Maybe Key))), Bool)
a, Bool
True)
          Maybe Bool
_ -> (forall a b. (a, b) -> a
fst ((a, (a, b, Alt Maybe (Maybe Key))), Bool)
a, Bool
multInA Bool -> Bool -> Bool
|| Bool
multInB)

   in forall a b k. (a -> b) -> Map k a -> Map k b
M.map 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 forall a b. (a -> b) -> a -> b
$
        forall k2 a k1.
Ord k2 =>
(a -> a -> a) -> (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeysWith
          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) 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 = 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 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 = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Sha.hash
                 forall a b. (a -> b) -> a -> b
$ Key -> ByteString
keyName Key
key
                forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
BSL.toStrict (Builder -> ByteString
BSB.toLazyByteString Builder
entryHashes)
                forall a. Semigroup a => a -> a -> a
<> String -> ByteString
BS8.pack (forall a. Show a => a -> String
show Alt Maybe SrcCodeLoc
defSite)
         in 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base16.encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Sha.hash
            forall a b. (a -> b) -> a -> b
$ ByteString
msg forall a. Semigroup a => a -> a -> a
<> String -> ByteString
BS8.pack (forall a. Show a => a -> String
show Maybe SrcCodeLoc
loc)
        Edge Key
key Maybe SrcCodeLoc
_ -> ByteString -> Builder
BSB.byteString forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => a -> k -> Map k a -> a
ML.findWithDefault 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 :: forall key. IsKey key => Graph key -> Builder
graphToDot Graph key
graph = Builder
header forall a. Semigroup a => a -> a -> a
<> Builder
graphContent forall a. Semigroup a => a -> a -> a
<> Builder
"}"
  where
    orderedEntries :: [(key,
  ([NodeEntry key], Alt Maybe SrcCodeLoc, Alt Maybe (Maybe key)))]
orderedEntries = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall a b. (a, b) -> b
snd)
                   forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn (forall a. a -> Down a
Down forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
                   forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList Graph key
graph
    graphContent :: Builder
graphContent =
      let (Builder
output, [Builder]
_, Map key Builder
colorMap) =
            forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
              (forall {key} {t :: * -> *} {key} {f :: * -> *}.
(IsKey key, Foldable f, Foldable t, IsKey key) =>
Map key Builder
-> (Builder, [Builder], Map key Builder)
-> (key, ([NodeEntry key], Alt f SrcCodeLoc, Alt Maybe (t key)))
-> (Builder, [Builder], Map key Builder)
doNode Map key Builder
colorMap)
              (forall a. Monoid a => a
mempty, forall a. [a] -> [a]
cycle [Builder]
edgeColors, 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 f SrcCodeLoc, Alt Maybe (t key)))
-> (Builder, [Builder], Map key Builder)
doNode Map key Builder
finalColorMap (Builder
acc, [Builder]
colors, Map key Builder
colorMapAcc)
                         (key
key, ([NodeEntry key]
entries, Alt f SrcCodeLoc
mSrcLoc, Alt Maybe (t key)
mBacklink)) =
      let ([Builder]
cells, [Builder]
edges, [Builder]
colors', Map key Builder
colorMapAcc')
            = 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) (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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NodeEntry key]
entries Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isJust Maybe (t key)
mBacklink
               then Builder
acc
               else Builder
tableStart
                 forall a. Semigroup a => a -> a -> a
<> [Builder] -> Builder
tableEl [Builder]
cells
                 forall a. Semigroup a => a -> a -> a
<> Builder
tableEnd
                 forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat [Builder]
edges
                 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
"\"" forall a. Semigroup a => a -> a -> a
<> a
bs forall a. Semigroup a => a -> a -> a
<> a
"\""
        -- Building a node
        nodeColor :: Maybe Builder
nodeColor = forall k a. Ord k => k -> Map k a -> Maybe a
ML.lookup key
key Map key Builder
finalColorMap
        nodeToolTip :: Builder
nodeToolTip = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Builder
"defined at " forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcCodeLoc -> Builder
pprSrcCodeLoc) f SrcCodeLoc
mSrcLoc
        backHref :: Builder
backHref = (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap) (\key
k -> Builder
"#" forall a. Semigroup a => a -> a -> a
<> forall key. IsKey key => key -> Builder
keyStr key
k) Maybe (t key)
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
                      ]
                [ (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap) (forall a b. a -> b -> a
const 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 key)
mBacklink
                , Builder
" "
                , Builder -> [Attr] -> [Builder] -> Builder
el Builder
"B" [] [ ByteString -> Builder
BSB.byteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
htmlEscape forall a b. (a -> b) -> a -> b
$ 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
            , forall a. Monoid a => [a] -> a
mconcat [Builder]
cells
            ]
        tableStart, tableEnd :: BSB.Builder
        tableStart :: Builder
tableStart = forall {a}. (Semigroup a, IsString a) => a -> a
quoted (forall key. IsKey key => key -> Builder
keyStr key
key) 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 =
                  forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Builder
"printed at " forall a. Semigroup a => a -> a -> a
<>) 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 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 = 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 (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NodeEntry key]
content) ->
                          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 = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Builder
"#" forall a. Semigroup a => a -> a -> a
<> forall key. IsKey key => key -> Builder
keyStrEsc key
edgeKey) Maybe Builder
mEdge
                elToolTip :: Builder
elToolTip =
                  forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Builder
"called at " forall a. Semigroup a => a -> a -> a
<>) 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
htmlEscape forall a b. (a -> b) -> a -> b
$ 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
                  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NodeEntry key]
targetContent
                  forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                    forall {a}. (Semigroup a, IsString a) => a -> a
quoted (forall key. IsKey key => key -> Builder
keyStr key
key) forall a. Semigroup a => a -> a -> a
<> Builder
":" forall a. Semigroup a => a -> a -> a
<> Word -> Builder
BSB.wordDec Word
idx
                    forall a. Semigroup a => a -> a -> a
<> Builder
" -> " forall a. Semigroup a => a -> a -> a
<> forall {a}. (Semigroup a, IsString a) => a -> a
quoted (forall key. IsKey key => key -> Builder
keyStr key
edgeKey)
                    forall a. Semigroup a => a -> a -> a
<> Builder
" [tooltip=\" \" colorscheme=set28 color=" forall a. Semigroup a => a -> a -> a
<> Builder
edgeColor forall a. Semigroup a => a -> a -> a
<> Builder
"];"

             in ( Builder
edgeEl forall a. a -> [a] -> [a]
: [Builder]
cs
                , forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (:) Maybe Builder
mEdge [Builder]
es
                , [Builder]
nextColors
                , 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)
_ = forall a. Monoid a => a
mempty

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

(.=) :: BSB.Builder -> BSB.Builder -> Attr
Builder
name .= :: Builder -> Builder -> Attr
.= Builder
val = Builder
name Builder -> Maybe Builder -> Attr
.=? 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
"<" forall a. Semigroup a => a -> a -> a
<> Builder
name forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall {a}. (IsString a, Monoid a) => (a, Maybe a) -> a
renderAttr [Attr]
attrs forall a. Semigroup a => a -> a -> a
<> Builder
">"
  forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat [Builder]
children forall a. Semigroup a => a -> a -> a
<> Builder
"</" forall a. Semigroup a => a -> a -> a
<> Builder
name forall a. Semigroup a => a -> a -> a
<> Builder
">"
  where
    renderAttr :: (a, Maybe a) -> a
renderAttr (a
aName, Just a
aVal) = a
" " forall a. Semigroup a => a -> a -> a
<> a
aName forall a. Semigroup a => a -> a -> a
<> a
"=\"" forall a. Semigroup a => a -> a -> a
<> a
aVal forall a. Semigroup a => a -> a -> a
<> a
"\""
    renderAttr (a
_, Maybe a
Nothing) = forall a. Monoid a => a
mempty

edgeColors :: [Color]
edgeColors :: [Builder]
edgeColors = Int -> Builder
BSB.intDec 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) forall a. Semigroup a => a -> a -> a
<> Builder
":"
 forall a. Semigroup a => a -> a -> a
<> Int -> Builder
BSB.intDec (SrcCodeLoc -> Int
srcLine SrcCodeLoc
loc) forall a. Semigroup a => a -> a -> a
<> Builder
":"
 forall a. Semigroup a => a -> a -> a
<> Int -> Builder
BSB.intDec (SrcCodeLoc -> Int
srcCol SrcCodeLoc
loc)