{-# 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.Lazy as BSL
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 (LPId(..))
import           Graph.Trace.Internal.Types

mkTraceEvent :: DebugIP => String -> Maybe Event
mkTraceEvent :: String -> Maybe Event
mkTraceEvent !String
msg = do
  DebugContext
ip <- ?_debug_ip::Maybe DebugContext
Maybe DebugContext
?_debug_ip
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (Bool -> Bool) -> Bool -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Propagation -> Bool
omitTraces (DebugContext -> Propagation
propagation DebugContext
ip)
  Event -> Maybe Event
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Event -> Maybe Event) -> Event -> Maybe Event
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 (CallStack -> Maybe CallSite)
-> (CallStack -> CallStack) -> CallStack -> Maybe CallSite
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallStack -> CallStack
popCallStack (CallStack -> Maybe CallSite) -> CallStack -> Maybe CallSite
forall a b. (a -> b) -> a -> b
$ CallStack -> CallStack
popCallStack CallStack
HasCallStack => CallStack
callStack)

writeEventToLog :: Event -> IO ()
-- forcing msg is required here since the file MVar could be entagled with it
writeEventToLog :: Event -> IO ()
writeEventToLog Event
event = MVar Handle -> IO () -> IO ()
seq MVar Handle
fileLock (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
  MVar Handle -> (Handle -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar Handle
fileLock ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h ->
    Handle -> MessageContent -> IO ()
BSL.hPut Handle
h (MessageContent -> IO ())
-> (MessageContent -> MessageContent) -> MessageContent -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MessageContent -> MessageContent -> MessageContent
forall a. Semigroup a => a -> a -> a
<> MessageContent
"\n") (MessageContent -> IO ()) -> MessageContent -> IO ()
forall a b. (a -> b) -> a -> b
$ Event -> MessageContent
eventToLogStr Event
event

unsafeWriteTrace :: DebugIP => String -> a -> a
unsafeWriteTrace :: String -> a -> a
unsafeWriteTrace !String
msg a
thing =
  IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ do
    case String -> Maybe Event
DebugIP => String -> Maybe Event
mkTraceEvent String
msg of
      Maybe Event
Nothing -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just Event
event -> Event -> IO ()
writeEventToLog Event
event
    a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
thing
{-# NOINLINE unsafeWriteTrace  #-}

trace :: DebugIP => String -> a -> a
trace :: String -> a -> a
trace = String -> a -> a
forall a. DebugIP => String -> a -> a
unsafeWriteTrace
{-# NOINLINE trace  #-}

traceId :: DebugIP => String -> String
traceId :: String -> String
traceId = (String -> String -> String) -> String -> String
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join String -> String -> String
forall a. DebugIP => String -> a -> a
unsafeWriteTrace

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

traceShowId :: (DebugIP, Show a) => a -> a
traceShowId :: a -> a
traceShowId = (a -> a -> a) -> a -> a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (String -> a -> a
forall a. DebugIP => String -> a -> a
unsafeWriteTrace (String -> a -> a) -> (a -> String) -> a -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show)

traceM :: (Applicative f, DebugIP) => String -> f ()
traceM :: String -> f ()
traceM String
x = String -> f () -> f ()
forall a. DebugIP => String -> a -> a
unsafeWriteTrace String
x (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$ () -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

traceShowM :: (Applicative f, Show a, DebugIP) => a -> f ()
traceShowM :: a -> f ()
traceShowM a
x = String -> f () -> f ()
forall a. DebugIP => String -> a -> a
unsafeWriteTrace (a -> String
forall a. Show a => a -> String
show a
x) (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$ () -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Serializes access to the debug log file
fileLock :: MVar Handle
fileLock :: MVar Handle
fileLock = IO (MVar Handle) -> MVar Handle
forall a. IO a -> a
unsafePerformIO (IO (MVar Handle) -> MVar Handle)
-> IO (MVar Handle) -> MVar Handle
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
        String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
progName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".trace"
      Just String
n -> String -> IO String
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
  Handle -> IO (MVar Handle)
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, LPId rep m)
  => a %m -> a
#else
  :: forall rep (a :: TYPE rep). (DebugIP, LPId rep)
  => a -> a
#endif
entry :: a -> a
entry =
  case ?_debug_ip::Maybe DebugContext
Maybe DebugContext
?_debug_ip of
    Maybe DebugContext
Nothing -> a -> a
forall a. LPId 'LiftedRep => a -> a
lpId
    Just DebugContext
ip
      | Propagation -> Bool
omitTraces (DebugContext -> Propagation
propagation DebugContext
ip) -> a -> a
forall a. LPId 'LiftedRep => a -> a
lpId
      | Bool
otherwise ->
        let !() = IO () -> ()
forall a. IO a -> a
unsafePerformIO (IO () -> ()) -> IO () -> ()
forall a b. (a -> b) -> a -> b
$ do
              MVar Handle -> (Handle -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar Handle
fileLock ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> 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 (CallStack -> Maybe CallSite) -> CallStack -> Maybe CallSite
forall a b. (a -> b) -> a -> b
$ CallStack -> CallStack
popCallStack CallStack
HasCallStack => CallStack
callStack)
                Handle -> MessageContent -> IO ()
BSL.hPut Handle
h (MessageContent -> IO ())
-> (MessageContent -> MessageContent) -> MessageContent -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MessageContent -> MessageContent -> MessageContent
forall a. Semigroup a => a -> a -> a
<> MessageContent
"\n") (MessageContent -> IO ()) -> MessageContent -> IO ()
forall a b. (a -> b) -> a -> b
$ Event -> MessageContent
eventToLogStr Event
ev
         in a -> a
forall a. LPId 'LiftedRep => a -> a
lpId
{-# 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