{-# 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
-- forcing msg is required here since the file MVar could be entagled with it
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 ()

-- | Serializes access to the debug log file
fileLock :: MVar Handle
fileLock :: MVar Handle
fileLock = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
  -- check for env variable with file name
  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  #-}

-- | 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 :: 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)
                         -- need to call popCallStack here to get actual call site
                         (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

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