fix srcloc of traces

exe/app/Main.hs

@@ -28,6 +28,7 @@ test' :: IO ()
 test' = do
   andAnother
   trace "test\ntest" pure ()
+  traceM "yo"
   putStrLn $ deff (I 3)
   x <- readLn
   case x of

graph-trace-dot/src/Graph/Trace/Dot.hs

@@ -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 =
       [ ('<', "&lt;")
@@ -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)

graph-trace/src/Graph/Trace/Internal/Trace.hs

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