mirror of
https://github.com/aaronallen8455/graph-trace.git
synced 2024-09-11 09:05:34 +03:00
fix srcloc of traces
This commit is contained in:
parent
26d873eda7
commit
a0e573bb88
@ -28,6 +28,7 @@ test' :: IO ()
|
||||
test' = do
|
||||
andAnother
|
||||
trace "test\ntest" pure ()
|
||||
traceM "yo"
|
||||
putStrLn $ deff (I 3)
|
||||
x <- readLn
|
||||
case x of
|
||||
|
@ -13,9 +13,10 @@ import Control.Applicative ((<|>))
|
||||
import Control.Monad
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as Atto
|
||||
import qualified Data.Attoparsec.ByteString.Lazy as AttoL
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Builder as BSB
|
||||
import qualified Data.ByteString.Char8 as BS8
|
||||
import qualified Data.ByteString.Lazy as BSL
|
||||
import qualified Data.ByteString.Lazy.Char8 as BSL8
|
||||
import Data.Foldable (foldl')
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Map as M
|
||||
@ -28,32 +29,32 @@ parseLogEntries :: BSL.ByteString -> Either String [LogEntry]
|
||||
parseLogEntries = AttoL.parseOnly (Atto.many' parseLogEntry <* Atto.endOfInput)
|
||||
|
||||
data Key = Key { keyId :: !Word
|
||||
, keyName :: !BSL.ByteString
|
||||
, keyName :: !BS.ByteString
|
||||
}
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
data LogEntry
|
||||
= Entry Key (Maybe Key) (Maybe SrcCodeLoc) (Maybe SrcCodeLoc)
|
||||
| Trace Key BSL.ByteString (Maybe SrcCodeLoc)
|
||||
| Trace Key BS.ByteString (Maybe SrcCodeLoc)
|
||||
deriving Show
|
||||
|
||||
data SrcCodeLoc =
|
||||
SrcCodeLoc
|
||||
{ srcMod :: BSL.ByteString
|
||||
{ srcMod :: BS.ByteString
|
||||
, srcLine :: Int
|
||||
, srcCol :: Int
|
||||
} deriving (Eq, Ord, Show)
|
||||
|
||||
-- | Use this to escape special characters that appear in the HTML portion of
|
||||
-- the dot code. Other strings such as node names should not be escaped.
|
||||
htmlEscape :: BSL.ByteString -> BSL.ByteString
|
||||
htmlEscape :: BS.ByteString -> BS.ByteString
|
||||
htmlEscape bs = foldl' doReplacement bs replacements
|
||||
where
|
||||
doReplacement acc (c, re) =
|
||||
case BSL8.break (== c) acc of
|
||||
case BS8.break (== c) acc of
|
||||
(before, after)
|
||||
| BSL.null after -> acc
|
||||
| otherwise -> before <> re <> BSL8.tail after
|
||||
| BS.null after -> acc
|
||||
| otherwise -> before <> re <> BS8.tail after
|
||||
|
||||
replacements =
|
||||
[ ('<', "<")
|
||||
@ -66,7 +67,7 @@ parseKey :: Atto.Parser Key
|
||||
parseKey = do
|
||||
kName <- Atto.takeTill (== '§') <* Atto.char '§'
|
||||
kId <- Atto.decimal <* Atto.char '§'
|
||||
pure $ Key { keyId = kId, keyName = BSL.fromStrict kName }
|
||||
pure $ Key { keyId = kId, keyName = kName }
|
||||
|
||||
parseLogEntry :: Atto.Parser LogEntry
|
||||
parseLogEntry = (parseEntryEvent <|> parseTraceEvent) <* Atto.many' Atto.space
|
||||
@ -89,19 +90,19 @@ parseTraceEvent = do
|
||||
message <- Atto.takeTill (== '§') <* Atto.char '§'
|
||||
callSite <- parseSrcCodeLoc
|
||||
_ <- Atto.many' Atto.space
|
||||
pure $ Trace key (htmlEscape $ BSL.fromStrict message) callSite
|
||||
pure $ Trace key (htmlEscape message) callSite
|
||||
|
||||
parseSrcCodeLoc :: Atto.Parser (Maybe SrcCodeLoc)
|
||||
parseSrcCodeLoc = do
|
||||
let parseLoc = do
|
||||
srcMod <- BSL.fromStrict <$> Atto.takeTill (== '§') <* Atto.char '§'
|
||||
srcMod <- Atto.takeTill (== '§') <* Atto.char '§'
|
||||
srcLine <- Atto.decimal <* Atto.char '§'
|
||||
srcCol <- Atto.decimal <* Atto.char '§'
|
||||
pure SrcCodeLoc{..}
|
||||
Just <$> parseLoc <|> Nothing <$ Atto.string "§§§"
|
||||
|
||||
data NodeEntry
|
||||
= Message BSL.ByteString -- ^ The trace message
|
||||
= Message BS.ByteString -- ^ The trace message
|
||||
(Maybe SrcCodeLoc) -- ^ call site
|
||||
| Edge Key -- ^ Id of the invocation to link to
|
||||
(Maybe SrcCodeLoc) -- ^ call site
|
||||
@ -166,7 +167,7 @@ graphToDot graph = header <> graphContent <> "}"
|
||||
<> acc
|
||||
in (acc', colors', colorMapAcc')
|
||||
where
|
||||
keyStr (Key i k) = BSB.lazyByteString k <> BSB.wordDec i
|
||||
keyStr (Key i k) = BSB.byteString k <> BSB.wordDec i
|
||||
quoted bs = "\"" <> bs <> "\""
|
||||
mEdgeColor = M.lookup key finalColorMap
|
||||
nodeColor = case mEdgeColor of
|
||||
@ -174,7 +175,7 @@ graphToDot graph = header <> graphContent <> "}"
|
||||
Just c -> "BGCOLOR=\"" <> c <> "\" "
|
||||
labelCell = "<TR><TD HREF=\"\" TOOLTIP=\"" <> foldMap pprSrcCodeLoc mSrcLoc
|
||||
<> "\" " <> nodeColor <> "><B>"
|
||||
<> BSB.lazyByteString (htmlEscape $ keyName key) <> "</B></TD></TR>\n"
|
||||
<> BSB.byteString (htmlEscape $ keyName key) <> "</B></TD></TR>\n"
|
||||
tableStart = quoted (keyStr key) <> " [label=<\n<TABLE BORDER=\"0\" CELLBORDER=\"1\" CELLSPACING=\"0\" CELLPADDING=\"4\">"
|
||||
tableEnd :: BSB.Builder
|
||||
tableEnd = "</TABLE>>];"
|
||||
@ -184,7 +185,7 @@ graphToDot graph = header <> graphContent <> "}"
|
||||
let el = "<TR><TD HREF=\"\" TOOLTIP=\"" <> foldMap pprSrcCodeLoc mCallSite
|
||||
<> "\" ALIGN=\"LEFT\" PORT=\""
|
||||
<> BSB.wordDec idx <> "\">"
|
||||
<> BSB.lazyByteString str <> "</TD></TR>"
|
||||
<> BSB.byteString str <> "</TD></TR>"
|
||||
in (el : cs, es, colors', colorMap)
|
||||
(Edge edgeKey mCallSite, idx) ->
|
||||
let href =
|
||||
@ -196,7 +197,7 @@ graphToDot graph = header <> graphContent <> "}"
|
||||
<> color <> "\" PORT=\"" <> BSB.wordDec idx <> "\""
|
||||
<> href
|
||||
<> "><FONT POINT-SIZE=\"8\">"
|
||||
<> BSB.lazyByteString (htmlEscape $ keyName edgeKey)
|
||||
<> BSB.byteString (htmlEscape $ keyName edgeKey)
|
||||
<> "</FONT></TD></TR>"
|
||||
mEdge = do
|
||||
(_, targetContent, _) <- M.lookup edgeKey graph
|
||||
@ -218,6 +219,6 @@ edgeColors = BSB.intDec <$> [1..8 :: Int]
|
||||
|
||||
pprSrcCodeLoc :: SrcCodeLoc -> BSB.Builder
|
||||
pprSrcCodeLoc loc
|
||||
= BSB.lazyByteString (srcMod loc) <> ":"
|
||||
= BSB.byteString (srcMod loc) <> ":"
|
||||
<> BSB.intDec (srcLine loc) <> ":"
|
||||
<> BSB.intDec (srcCol loc)
|
||||
|
@ -23,38 +23,49 @@ import System.IO.Unsafe (unsafePerformIO)
|
||||
|
||||
import Graph.Trace.Internal.Types
|
||||
|
||||
trace :: DebugIP => String -> a -> a
|
||||
mkTraceEvent :: DebugIP => String -> Maybe Event
|
||||
mkTraceEvent !msg = do
|
||||
ip <- ?_debug_ip
|
||||
guard . not $ omitTraces (propagation ip)
|
||||
pure $
|
||||
TraceEvent
|
||||
(currentTag ip)
|
||||
(BSL8.pack msg)
|
||||
(callStackToCallSite . popCallStack $ popCallStack callStack)
|
||||
|
||||
writeEventToLog :: Event -> IO ()
|
||||
-- forcing msg is required here since the file MVar could be entagled with it
|
||||
trace !msg x =
|
||||
case ?_debug_ip of
|
||||
Nothing -> x
|
||||
Just ip
|
||||
| omitTraces (propagation ip) -> x
|
||||
| otherwise ->
|
||||
unsafePerformIO $ do
|
||||
withMVar fileLock $ \h -> do
|
||||
let ev = TraceEvent
|
||||
(currentTag ip)
|
||||
(BSL8.pack msg)
|
||||
(callStackToCallSite callStack)
|
||||
BSL.hPut h . (<> "\n") $ eventToLogStr ev
|
||||
pure x
|
||||
writeEventToLog event =
|
||||
withMVar fileLock $ \h ->
|
||||
BSL.hPut h . (<> "\n") $ eventToLogStr event
|
||||
|
||||
unsafeWriteTrace :: DebugIP => String -> a -> a
|
||||
unsafeWriteTrace !msg thing =
|
||||
unsafePerformIO $ do
|
||||
case mkTraceEvent msg of
|
||||
Nothing -> pure ()
|
||||
Just event -> writeEventToLog event
|
||||
pure thing
|
||||
{-# NOINLINE unsafeWriteTrace #-}
|
||||
|
||||
trace :: DebugIP => String -> a -> a
|
||||
trace = unsafeWriteTrace
|
||||
{-# NOINLINE trace #-}
|
||||
|
||||
traceId :: DebugIP => String -> String
|
||||
traceId = join trace
|
||||
traceId = join unsafeWriteTrace
|
||||
|
||||
traceShow :: DebugIP => Show a => a -> b -> b
|
||||
traceShow = trace . show
|
||||
traceShow :: (DebugIP, Show a) => a -> b -> b
|
||||
traceShow = unsafeWriteTrace . show
|
||||
|
||||
traceShowId :: DebugIP => Show a => a -> a
|
||||
traceShowId = join traceShow
|
||||
traceShowId :: (DebugIP, Show a) => a -> a
|
||||
traceShowId = join (unsafeWriteTrace . show)
|
||||
|
||||
traceM :: (Applicative f, DebugIP) => String -> f ()
|
||||
traceM x = trace x $ pure ()
|
||||
traceM x = unsafeWriteTrace x $ pure ()
|
||||
|
||||
traceShowM :: (Applicative f, Show a, DebugIP) => a -> f ()
|
||||
traceShowM = traceM . show
|
||||
traceShowM x = unsafeWriteTrace (show x) $ pure ()
|
||||
|
||||
-- | Serializes access to the debug log file
|
||||
fileLock :: MVar Handle
|
||||
|
Loading…
Reference in New Issue
Block a user