{-# LANGUAGE CPP                      #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings        #-}

{-|
Module:      TextShow.Debug.Trace
Copyright:   (C) 2014-2017 Ryan Scott
License:     BSD-style (see the file LICENSE)
Maintainer:  Ryan Scott
Stability:   Provisional
Portability: GHC

Functions for tracing and monitoring execution.

These can be useful for investigating bugs or performance problems.
They should /not/ be used in production code.

If you do not wish to require 'TextShow' instances for your @trace@ functions,
the "TextShow.Debug.Trace.TH" and "Text.Show.Text.Debug.Trace.Generic" modules
exist to convert the input to a debug message using Template Haskell or generics,
respectively.

/Since: 2/
-}
module TextShow.Debug.Trace (
      -- * Tracing
      -- $tracing
      tracet
    , tracetl
    , tracetId
    , tracetlId
    , traceTextShow
    , traceTextShowId
    , tracetStack
    , tracetlStack
    , tracetIO
    , tracetlIO
    , tracetM
    , tracetlM
    , traceTextShowM

      -- * Eventlog tracing
      -- $eventlog_tracing
    , tracetEvent
    , tracetlEvent
    , tracetEventIO
    , tracetlEventIO

      -- * Execution phase markers
      -- $markers
    , tracetMarker
    , tracetlMarker
    , tracetMarkerIO
    , tracetlMarkerIO
    ) where

import           Control.Monad (unless)

import qualified Data.ByteString as BS (null, partition)
import           Data.ByteString (ByteString, useAsCString)
import qualified Data.ByteString.Char8 as BS (pack)
import           Data.ByteString.Internal (c2w)
import qualified Data.Text as TS (Text, unpack)
import           Data.Text.Encoding (encodeUtf8)
import qualified Data.Text.Lazy as TL (Text, unpack)
import           Data.Text.Lazy (toStrict)

import           Debug.Trace

import           Foreign.C.String (CString)

import           GHC.Stack (currentCallStack, renderStack)

import           Prelude ()
import           Prelude.Compat

import           System.IO.Unsafe (unsafePerformIO)

import           TextShow.Classes (TextShow(..))
import           TextShow.Instances ()

-- $tracing
--
-- The @tracet(l)@, @traceTextShow@ and @tracet(l)IO@ functions print messages to an
-- output stream. They are intended for \"printf debugging\", that is: tracing the flow
-- of execution and printing interesting values.
--
-- All these functions evaluate the message completely before printing
-- it; so if the message is not fully defined, none of it will be
-- printed.
--
-- The usual output stream is 'System.IO.stderr'. For Windows GUI applications
-- (that have no stderr) the output is directed to the Windows debug console.
-- Some implementations of these functions may decorate the @Text@ that\'s
-- output to indicate that you\'re tracing.

-- | The 'tracetIO' function outputs the trace message from the IO monad.
-- This sequences the output with respect to other IO actions.
--
-- /Since: 2/
tracetIO :: TS.Text -> IO ()
tracetIO :: Text -> IO ()
tracetIO = ByteString -> IO ()
traceIOByteString (ByteString -> IO ()) -> (Text -> ByteString) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8

-- | Like 'tracetIO' but accepts a lazy 'TL.Text' argument.
--
-- /Since: 2/
tracetlIO :: TL.Text -> IO ()
tracetlIO :: Text -> IO ()
tracetlIO = Text -> IO ()
tracetIO (Text -> IO ()) -> (Text -> Text) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
toStrict

traceIOByteString :: ByteString -> IO ()
traceIOByteString :: ByteString -> IO ()
traceIOByteString ByteString
msg = ByteString -> (CString -> IO ()) -> IO ()
forall a. ByteString -> (CString -> IO a) -> IO a
useAsCString ByteString
"%s\n" ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CString
cfmt -> do
    -- NB: debugBelch can't deal with null bytes, so filter them
    -- out so we don't accidentally truncate the message.  See Trac #9395
    let (ByteString
nulls, ByteString
msg') = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
BS.partition (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Word8
c2w Char
'\0') ByteString
msg
    ByteString -> (CString -> IO ()) -> IO ()
forall a. ByteString -> (CString -> IO a) -> IO a
useAsCString ByteString
msg' ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CString
cmsg ->
      CString -> CString -> IO ()
debugBelch CString
cfmt CString
cmsg
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
BS.null ByteString
nulls) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      ByteString -> (CString -> IO ()) -> IO ()
forall a. ByteString -> (CString -> IO a) -> IO a
useAsCString ByteString
"WARNING: previous trace message had null bytes" ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CString
cmsg ->
        CString -> CString -> IO ()
debugBelch CString
cfmt CString
cmsg

-- don't use debugBelch() directly, because we cannot call varargs functions
-- using the FFI.
foreign import ccall unsafe "HsBase.h debugBelch2"
    debugBelch :: CString -> CString -> IO ()

{-|
The 'tracet' function outputs the trace message given as its first argument,
before returning the second argument as its result.

For example, this returns the value of @f x@ but first outputs the message.

> tracet ("calling f with x = " <> showt x) (f x)

The 'tracet' function should /only/ be used for debugging, or for monitoring
execution. The function is not referentially transparent: its type indicates
that it is a pure function but it has the side effect of outputting the
trace message.

/Since: 2/
-}
tracet :: TS.Text -> a -> a
tracet :: Text -> a -> a
tracet = ByteString -> a -> a
forall a. ByteString -> a -> a
traceByteString (ByteString -> a -> a) -> (Text -> ByteString) -> Text -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8

-- | Like 'tracet' but accepts a lazy 'TL.Text' argument.
--
-- /Since: 2/
tracetl :: TL.Text -> a -> a
tracetl :: Text -> a -> a
tracetl = Text -> a -> a
forall a. Text -> a -> a
tracet (Text -> a -> a) -> (Text -> Text) -> Text -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
toStrict

{-# NOINLINE traceByteString #-}
traceByteString :: ByteString -> a -> a
traceByteString :: ByteString -> a -> a
traceByteString ByteString
bs a
expr = IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ do
    ByteString -> IO ()
traceIOByteString ByteString
bs
    a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
expr

-- | Like 'tracet' but returns the message instead of a third value.
--
-- /Since: 2/
tracetId :: TS.Text -> TS.Text
tracetId :: Text -> Text
tracetId Text
a = Text -> Text -> Text
forall a. Text -> a -> a
tracet Text
a Text
a

-- | Like 'tracetId' but accepts a lazy 'TL.Text' argument.
--
-- /Since: 2/
tracetlId :: TL.Text -> TL.Text
tracetlId :: Text -> Text
tracetlId Text
a = Text -> Text -> Text
forall a. Text -> a -> a
tracetl Text
a Text
a

{-|
Like 'tracet', but uses 'showt' on the argument to convert it to a 'TS.Text'.

This makes it convenient for printing the values of interesting variables or
expressions inside a function. For example here we print the value of the
variables @x@ and @z@:

> f x y =
>     traceTextShow (x, z) $ result
>   where
>     z = ...
>     ...

/Since: 2/
-}
traceTextShow :: TextShow a => a -> b -> b
traceTextShow :: a -> b -> b
traceTextShow = Text -> b -> b
forall a. Text -> a -> a
tracet (Text -> b -> b) -> (a -> Text) -> a -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Text
forall a. TextShow a => a -> Text
showt

-- | Like 'traceTextShow' but returns the shown value instead of a third value.
--
-- /Since: 2/
traceTextShowId :: TextShow a => a -> a
traceTextShowId :: a -> a
traceTextShowId a
a = Text -> a -> a
forall a. Text -> a -> a
tracet (a -> Text
forall a. TextShow a => a -> Text
showt a
a) a
a

{-|
Like 'tracet' but returning unit in an arbitrary 'Applicative' context. Allows for
convenient use in do-notation. Note that the application of 'tracet' is not an action
in the 'Applicative' context, as 'tracetIO' is in the 'IO' type.

> ... = do
>   x <- ...
>   tracetM $ "x: " <> showt x
>   y <- ...
>   tracetM $ "y: " <> showt y

/Since: 2/
-}
tracetM :: Applicative f => TS.Text -> f ()
tracetM :: Text -> f ()
tracetM Text
text = Text -> f () -> f ()
forall a. Text -> a -> a
tracet Text
text (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$ () -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Like 'tracetM' but accepts a lazy 'TL.Text' argument.
tracetlM :: Applicative f => TL.Text -> f ()
tracetlM :: Text -> f ()
tracetlM Text
text = Text -> f () -> f ()
forall a. Text -> a -> a
tracetl Text
text (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$ () -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

{-|
Like 'tracetM', but uses 'showt' on the argument to convert it to a 'TS.Text'.

> ... = do
>   x <- ...
>   traceTextShowM x
>   y <- ...
>   traceTextShowM $ x + y

/Since: 2/
-}
traceTextShowM :: (TextShow a, Applicative f) => a -> f ()
traceTextShowM :: a -> f ()
traceTextShowM = Text -> f ()
forall (f :: * -> *). Applicative f => Text -> f ()
tracetM (Text -> f ()) -> (a -> Text) -> a -> f ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Text
forall a. TextShow a => a -> Text
showt

-- | Like 'tracet' but additionally prints a call stack if one is
-- available.
--
-- In the current GHC implementation, the call stack is only
-- availble if the program was compiled with @-prof@; otherwise
-- 'tracetStack' behaves exactly like 'tracet'.  Entries in the call
-- stack correspond to @SCC@ annotations, so it is a good idea to use
-- @-fprof-auto@ or @-fprof-auto-calls@ to add SCC annotations automatically.
--
-- /Since: 2/
tracetStack :: TS.Text -> a -> a
tracetStack :: Text -> a -> a
tracetStack = ByteString -> a -> a
forall a. ByteString -> a -> a
traceStackByteString (ByteString -> a -> a) -> (Text -> ByteString) -> Text -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8

-- | Like 'tracetStack' but accepts a lazy 'TL.Text' argument.
--
-- /Since: 2/
tracetlStack :: TL.Text -> a -> a
tracetlStack :: Text -> a -> a
tracetlStack = Text -> a -> a
forall a. Text -> a -> a
tracetStack (Text -> a -> a) -> (Text -> Text) -> Text -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
toStrict

traceStackByteString :: ByteString -> a -> a
traceStackByteString :: ByteString -> a -> a
traceStackByteString ByteString
bs a
expr = IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ do
    ByteString -> IO ()
traceIOByteString ByteString
bs
    [String]
stack <- IO [String]
currentCallStack
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
stack) (IO () -> IO ()) -> (String -> IO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> IO ()
traceIOByteString (ByteString -> IO ()) -> (String -> ByteString) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BS.pack (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
renderStack [String]
stack
    a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
expr

-- $eventlog_tracing
--
-- Eventlog tracing is a performance profiling system. These functions emit
-- extra events into the eventlog. In combination with eventlog profiling
-- tools these functions can be used for monitoring execution and
-- investigating performance problems.
--
-- Currently only GHC provides eventlog profiling, see the GHC user guide for
-- details on how to use it. These function exists for other Haskell
-- implementations but no events are emitted. Note that the @Text@ message is
-- always evaluated, whether or not profiling is available or enabled.

-- | The 'tracetEvent' function behaves like 'tracet' with the difference that
-- the message is emitted to the eventlog, if eventlog profiling is available
-- and enabled at runtime.
--
-- It is suitable for use in pure code. In an IO context use 'tracetEventIO'
-- instead.
--
-- Note that when using GHC's SMP runtime, it is possible (but rare) to get
-- duplicate events emitted if two CPUs simultaneously evaluate the same thunk
-- that uses 'traceEvent'.
--
-- /Since: 2/
tracetEvent :: TS.Text -> a -> a
tracetEvent :: Text -> a -> a
tracetEvent = String -> a -> a
forall a. String -> a -> a
traceEvent (String -> a -> a) -> (Text -> String) -> Text -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
TS.unpack

-- | Like 'tracetEvent' but accepts a lazy 'TL.Text' argument.
--
-- /Since: 2/
tracetlEvent :: TL.Text -> a -> a
tracetlEvent :: Text -> a -> a
tracetlEvent = String -> a -> a
forall a. String -> a -> a
traceEvent (String -> a -> a) -> (Text -> String) -> Text -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
TL.unpack

-- | The 'tracetEventIO' function emits a message to the eventlog, if eventlog
-- profiling is available and enabled at runtime.
--
-- Compared to 'tracetEvent', 'tracetEventIO' sequences the event with respect to
-- other IO actions.
--
-- /Since: 2/
tracetEventIO :: TS.Text -> IO ()
tracetEventIO :: Text -> IO ()
tracetEventIO = String -> IO ()
traceEventIO (String -> IO ()) -> (Text -> String) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
TS.unpack

-- | Like 'tracetEventIO' but accepts a lazy 'TL.Text' argument.
--
-- /Since: 2/
tracetlEventIO :: TL.Text -> IO ()
tracetlEventIO :: Text -> IO ()
tracetlEventIO = String -> IO ()
traceEventIO (String -> IO ()) -> (Text -> String) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
TL.unpack

-- $markers
--
-- When looking at a profile for the execution of a program we often want to
-- be able to mark certain points or phases in the execution and see that
-- visually in the profile.

-- For example, a program might have several distinct phases with different
-- performance or resource behaviour in each phase. To properly interpret the
-- profile graph we really want to see when each phase starts and ends.
--
-- Markers let us do this: we can annotate the program to emit a marker at
-- an appropriate point during execution and then see that in a profile.
--
-- Currently this feature is only supported in GHC by the eventlog tracing
-- system, but in future it may also be supported by the heap profiling or
-- other profiling tools. These function exists for other Haskell
-- implementations but they have no effect. Note that the @Text@ message is
-- always evaluated, whether or not profiling is available or enabled.

-- | The 'tracetMarker' function emits a marker to the eventlog, if eventlog
-- profiling is available and enabled at runtime. The 'TS.Text' is the name of
-- the marker. The name is just used in the profiling tools to help you keep
-- clear which marker is which.
--
-- This function is suitable for use in pure code. In an IO context use
-- 'tracetMarkerIO' instead.
--
-- Note that when using GHC's SMP runtime, it is possible (but rare) to get
-- duplicate events emitted if two CPUs simultaneously evaluate the same thunk
-- that uses 'traceMarker'.
--
-- /Since: 2/
tracetMarker :: TS.Text -> a -> a
tracetMarker :: Text -> a -> a
tracetMarker Text
msg = String -> a -> a
forall a. String -> a -> a
traceMarker (String -> a -> a) -> String -> a -> a
forall a b. (a -> b) -> a -> b
$ Text -> String
TS.unpack Text
msg

-- | Like 'tracetMarker' but accepts a lazy 'TL.Text' argument.
--
-- /Since: 2/
tracetlMarker :: TL.Text -> a -> a
tracetlMarker :: Text -> a -> a
tracetlMarker Text
msg = String -> a -> a
forall a. String -> a -> a
traceMarker (String -> a -> a) -> String -> a -> a
forall a b. (a -> b) -> a -> b
$ Text -> String
TL.unpack Text
msg

-- | The 'tracetMarkerIO' function emits a marker to the eventlog, if eventlog
-- profiling is available and enabled at runtime.
--
-- Compared to 'tracetMarker', 'tracetMarkerIO' sequences the event with respect to
-- other IO actions.
--
-- /Since: 2/
tracetMarkerIO :: TS.Text -> IO ()
tracetMarkerIO :: Text -> IO ()
tracetMarkerIO = String -> IO ()
traceMarkerIO (String -> IO ()) -> (Text -> String) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
TS.unpack

-- | Like 'tracetMarkerIO' but accepts a lazy 'TL.Text' argument.
--
-- /Since: 2/
tracetlMarkerIO :: TL.Text -> IO ()
tracetlMarkerIO :: Text -> IO ()
tracetlMarkerIO = String -> IO ()
traceMarkerIO (String -> IO ()) -> (Text -> String) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
TL.unpack