{-# 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 :: DebugIP => String -> Maybe Event
mkTraceEvent !String
msg = do
DebugContext
ip <- ?_debug_ip::Maybe DebugContext
?_debug_ip
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
$ Propagation -> Bool
omitTraces (DebugContext -> Propagation
propagation DebugContext
ip)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
DebugTag -> MessageContent -> Maybe CallSite -> Event
TraceEvent
(DebugContext -> DebugTag
currentTag DebugContext
ip)
(String -> MessageContent
BSL8.pack String
msg)
(CallStack -> Maybe CallSite
callStackToCallSite forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallStack -> CallStack
popCallStack forall a b. (a -> b) -> a -> b
$ CallStack -> CallStack
popCallStack HasCallStack => CallStack
callStack)
writeEventToLog :: Event -> IO ()
writeEventToLog :: Event -> IO ()
writeEventToLog Event
event = seq :: forall a b. a -> b -> b
seq MVar Handle
fileLock forall a b. (a -> b) -> a -> b
$
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar Handle
fileLock forall a b. (a -> b) -> a -> b
$ \Handle
h ->
Handle -> Builder -> IO ()
BSB.hPutBuilder Handle
h forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Semigroup a => a -> a -> a
<> Builder
"\n") forall a b. (a -> b) -> a -> b
$ Event -> Builder
eventToLogStr Event
event
unsafeWriteTrace :: DebugIP => String -> a -> a
unsafeWriteTrace :: forall a. DebugIP => String -> a -> a
unsafeWriteTrace !String
msg a
thing =
forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
case DebugIP => String -> Maybe Event
mkTraceEvent String
msg of
Maybe Event
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just Event
event -> Event -> IO ()
writeEventToLog Event
event
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
thing
{-# NOINLINE unsafeWriteTrace #-}
trace :: DebugIP => String -> a -> a
trace :: forall a. DebugIP => String -> a -> a
trace = forall a. DebugIP => String -> a -> a
unsafeWriteTrace
{-# NOINLINE trace #-}
traceId :: DebugIP => String -> String
traceId :: DebugIP => String -> String
traceId = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a. DebugIP => String -> a -> a
unsafeWriteTrace
traceShow :: (DebugIP, Show a) => a -> b -> b
traceShow :: forall a b. (DebugIP, Show a) => a -> b -> b
traceShow = forall a. DebugIP => String -> a -> a
unsafeWriteTrace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
traceShowId :: (DebugIP, Show a) => a -> a
traceShowId :: forall a. (DebugIP, Show a) => a -> a
traceShowId = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (forall a. DebugIP => String -> a -> a
unsafeWriteTrace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show)
traceM :: (Applicative f, DebugIP) => String -> f ()
traceM :: forall (f :: * -> *). (Applicative f, DebugIP) => String -> f ()
traceM String
x = forall a. DebugIP => String -> a -> a
unsafeWriteTrace String
x forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
traceShowM :: (Applicative f, Show a, DebugIP) => a -> f ()
traceShowM :: forall (f :: * -> *) a.
(Applicative f, Show a, DebugIP) =>
a -> f ()
traceShowM a
x = forall a. DebugIP => String -> a -> a
unsafeWriteTrace (forall a. Show a => a -> String
show a
x) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
fileLock :: MVar Handle
fileLock :: MVar Handle
fileLock = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
Maybe String
mOverrideFileName <- String -> IO (Maybe String)
lookupEnv String
"GRAPH_TRACE_FILENAME"
String
logFilePath <-
case Maybe String
mOverrideFileName of
Maybe String
Nothing -> do
String
progName <- IO String
getProgName
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String
progName forall a. Semigroup a => a -> a -> a
<> String
".trace"
Just String
n -> forall (f :: * -> *) a. Applicative f => a -> f a
pure String
n
Handle
h <- String -> IOMode -> IO Handle
openFile String
logFilePath IOMode
AppendMode
Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
NoBuffering
forall a. a -> IO (MVar a)
newMVar Handle
h
{-# NOINLINE fileLock #-}
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 :: forall (m :: Multiplicity) a. DebugIP => Lev a %m -> a
entry Lev a
x =
case ?_debug_ip::Maybe DebugContext
?_debug_ip of
Maybe DebugContext
Nothing -> Lev a
x
Just DebugContext
ip
| Propagation -> Bool
omitTraces (DebugContext -> Propagation
propagation DebugContext
ip) -> Lev a
x
| Bool
otherwise ->
let !() = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
let ev :: Event
ev = DebugTag
-> Maybe DebugTag -> Maybe CallSite -> Maybe CallSite -> Event
EntryEvent
(DebugContext -> DebugTag
currentTag DebugContext
ip)
(DebugContext -> Maybe DebugTag
previousTag DebugContext
ip)
(DebugContext -> Maybe CallSite
definitionSite DebugContext
ip)
(CallStack -> Maybe CallSite
callStackToCallSite forall a b. (a -> b) -> a -> b
$ CallStack -> CallStack
popCallStack HasCallStack => CallStack
callStack)
Event -> IO ()
writeEventToLog Event
ev
in Lev a
x
{-# NOINLINE entry #-}
omitTraces :: Propagation -> Bool
omitTraces :: Propagation -> Bool
omitTraces Propagation
Mute = Bool
True
omitTraces Propagation
Inert = Bool
True
omitTraces Propagation
_ = Bool
False