Trace.hs

{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE CPP #-}
# if MIN_VERSION_ghc(9,0,0)
{-# LANGUAGE LinearTypes #-}
# endif
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE BangPatterns #-}
module Graph.Trace.Internal.Trace
  ( trace
  , traceId
  , traceShow
  , traceShowId
  , traceM
  , traceShowM
  , entry
  , omitTraces
  ) where

import           Control.Concurrent.MVar
import           Control.Monad
import qualified Data.ByteString.Builder as BSB
import qualified Data.ByteString.Lazy.Char8 as BSL8
import           GHC.Exts
import           GHC.Stack (callStack, popCallStack)
import           System.Environment (getProgName, lookupEnv)
import           System.IO
import           System.IO.Unsafe (unsafePerformIO)

import           Graph.Trace.Internal.RuntimeRep (Lev)
import           Graph.Trace.Internal.Types

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 ()
writeEventToLog event = seq fileLock $
  withMVar fileLock $ \h ->
    BSB.hPutBuilder h . (<> "\n") $ eventToLogStr event

unsafeWriteTrace :: DebugIP => String -> a -> a
-- forcing msg is required here since the file MVar could be entagled with it
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 unsafeWriteTrace

traceShow :: (DebugIP, Show a) => a -> b -> b
traceShow = unsafeWriteTrace . show

traceShowId :: (DebugIP, Show a) => a -> a
traceShowId = join (unsafeWriteTrace . show)

traceM :: (Applicative f, DebugIP) => String -> f ()
traceM x = unsafeWriteTrace x $ pure ()

traceShowM :: (Applicative f, Show a, DebugIP) => a -> f ()
traceShowM x = unsafeWriteTrace (show x) $ pure ()

-- | Serializes access to the debug log file
fileLock :: MVar Handle
fileLock = unsafePerformIO $ do
  -- check for env variable with file name
  mOverrideFileName <- lookupEnv "GRAPH_TRACE_FILENAME"
  logFilePath <-
    case mOverrideFileName of
      Nothing -> do
        progName <- getProgName
        pure $ progName <> ".trace"
      Just n -> pure n
  h <- openFile logFilePath AppendMode
  hSetBuffering h NoBuffering
  newMVar h
{-# NOINLINE fileLock  #-}

-- | Emits a message to the log signaling a function invocation
entry
#if MIN_VERSION_ghc(9,0,0)
  :: forall rep m (a :: TYPE rep). DebugIP
  => Lev a %m -> a
#else
  :: forall rep (a :: TYPE rep). DebugIP
  => Lev a -> a
#endif
entry x =
  case ?_debug_ip of
    Nothing -> x
    Just ip
      | omitTraces (propagation ip) -> x
      | otherwise ->
        let !() = unsafePerformIO $ do
              let ev = EntryEvent
                         (currentTag ip)
                         (previousTag ip)
                         (definitionSite ip)
                         -- need to call popCallStack here to get actual call site
                         (callStackToCallSite $ popCallStack callStack)
              writeEventToLog ev
         in x
{-# NOINLINE entry  #-}

omitTraces :: Propagation -> Bool
omitTraces Mute = True
omitTraces Inert = True
omitTraces _ = False

-- TODO allow to apply a function to mute some specific thing
-- mute :: DebugIP => a -> a