{-# OPTIONS_HADDOCK hide, prune #-}

-- | Tracing with TH
module Debug.TraceEmbrace.TH (tr, tw, tw', trIo, u, a, s_, tg, tg', underbar, trFunMarker, trIoFunMarker) where

import Debug.Trace
import Debug.TraceEmbrace.Config
import Debug.TraceEmbrace.FileIndex (FunName (..))
import Debug.TraceEmbrace.Internal.Rewrap
import Debug.TraceEmbrace.Internal.TH qualified as I
import Haddock.UseRefs
import Language.Haskell.TH
import Language.Haskell.TH.Syntax

Proxy HaddockRefsCounter -> Int
(Proxy HaddockRefsCounter -> Int)
-> CountHaddockRefs HaddockRefsCounter
forall a. (Proxy a -> Int) -> CountHaddockRefs a
$ccountHaddockRefs :: Proxy HaddockRefsCounter -> Int
countHaddockRefs :: Proxy HaddockRefsCounter -> Int
countDocRefs

-- | TH version of 'trace' and 'traceEvent'
-- The message is formatted according to 'TraceMessageFormat'.
-- The generated expression has type @forall r (a :: TYPE r) b a. 'Rewrap' a b => a -> a@.
-- 'id' is generated if effective trace level is lower than trace level threshold.
-- Example:
--
-- > foo x = $(tr "get/x") x
--
-- Output:
--
-- > Module::foo get; x : 132
tr :: String -> Q Exp
tr :: String -> Q Exp
tr String
tm = Q Exp -> String -> Q Exp
I.tr [| \x -> x |] String
tm

-- | TH version of 'traceWith' and 'traceEventWith'
-- The message is formatted according to 'TraceMessageFormat'.
-- The generated expression has type @forall r (a :: TYPE r) b a. (Show a, Rewrap a b) => a -> a@.
-- 'id' is generated if effective trace level is lower than trace level threshold.
-- Example:
--
-- > foo x = $(tw "get/x") (x + 1)
--
-- Output:
--
-- > Module::foo get; x : 132 => 133
tw :: String -> Q Exp
tw :: String -> Q Exp
tw = Q Exp -> String -> Q Exp
I.tw [| \x -> x |]

-- | Like 'tw' but return value is wrapped with 'ShowTrace'.
tw' :: String -> Q Exp
tw' :: String -> Q Exp
tw' = Q Exp -> String -> Q Exp
I.tw' [| \x -> x |]

-- | TH version of 'traceIO' and 'traceEventIO'
-- The message is formatted according to 'TraceMessageFormat'.
-- Example:
--
-- > foo x = $(trIo "get/x") >> pure x
--
-- Output:
--
-- > Module::foo get; x : 132
trIo :: String -> Q Exp
trIo :: String -> Q Exp
trIo = Q Exp -> String -> Q Exp
I.trIo [| pure () |]

-- | TH version of 'traceMarker' where module and function
-- are used as a marker. Trace level is used.
trFunMarker :: Q Exp
trFunMarker :: Q Exp
trFunMarker = Q Exp -> Q Exp
I.trFunMarker [| \x -> x |]

-- | TH version of 'traceMarkerIO' where module and function
-- are used as a marker. Trace level is not used.
trIoFunMarker :: Q Exp
trIoFunMarker :: Q Exp
trIoFunMarker = Q Exp -> Q Exp
I.trIoFunMarker [| pure () |]

data ArgPatCounter
  = ArgPatCounter
    { ArgPatCounter -> FunName
funName :: FunName
    , ArgPatCounter -> [Name]
argNames :: [Name]
    } deriving (Int -> ArgPatCounter -> ShowS
[ArgPatCounter] -> ShowS
ArgPatCounter -> String
(Int -> ArgPatCounter -> ShowS)
-> (ArgPatCounter -> String)
-> ([ArgPatCounter] -> ShowS)
-> Show ArgPatCounter
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ArgPatCounter -> ShowS
showsPrec :: Int -> ArgPatCounter -> ShowS
$cshow :: ArgPatCounter -> String
show :: ArgPatCounter -> String
$cshowList :: [ArgPatCounter] -> ShowS
showList :: [ArgPatCounter] -> ShowS
Show)

data Undebar = Undebar

instance Show Undebar where
  show :: Undebar -> String
show Undebar
_ = String
"_"

underbar :: Undebar
underbar :: Undebar
underbar = Undebar
Undebar
-- | Generates consequent pattern variable for tracing arguments of a guarded function.
-- It is assumed that 'a' is used together with 'tg' and 'u'.
--
-- > foo $a $a $a | $tg = $u
-- > foo 0  _  _ = 0
-- > foo x y z = x + y + z
--
a :: Q Pat
a :: Q Pat
a = do
  cfn <- Q FunName
I.currentFunName
  getQ >>= \case
    Maybe ArgPatCounter
Nothing -> FunName -> Q Pat
reset FunName
cfn
    Just (ArgPatCounter FunName
fn [Name]
aNames)
      | FunName
fn FunName -> FunName -> Bool
forall a. Eq a => a -> a -> Bool
== FunName
cfn -> [Name] -> FunName -> Q Pat
go [Name]
aNames FunName
cfn
      | Bool
otherwise -> FunName -> Q Pat
reset FunName
cfn
  where
    reset :: FunName -> Q Pat
reset FunName
cfn = [Name] -> FunName -> Q Pat
go [] FunName
cfn
    go :: [Name] -> FunName -> Q Pat
go [Name]
ans FunName
cfn = do
      nn <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ String
"traceEmbracePatArg" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ [Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
ans)
      putQ (ArgPatCounter cfn $ nn : ans)
      varP nn

-- | Similar to 'a', but argument is not included in trace message.
s_ :: Q Pat
s_ :: Q Pat
s_ = do
  cfn <- Q FunName
I.currentFunName
  getQ >>= \case
    Maybe ArgPatCounter
Nothing -> FunName -> Q Pat
reset FunName
cfn
    Just (ArgPatCounter FunName
fn [Name]
aNames)
      | FunName
fn FunName -> FunName -> Bool
forall a. Eq a => a -> a -> Bool
== FunName
cfn -> [Name] -> FunName -> Q Pat
go [Name]
aNames FunName
cfn
      | Bool
otherwise -> FunName -> Q Pat
reset FunName
cfn
  where
    reset :: FunName -> Q Pat
reset FunName
cfn = [Name] -> FunName -> Q Pat
go [] FunName
cfn
    go :: [Name] -> FunName -> Q Pat
go [Name]
ans FunName
cfn = ArgPatCounter -> Q ()
forall a. Typeable a => a -> Q ()
putQ (FunName -> [Name] -> ArgPatCounter
ArgPatCounter FunName
cfn ([Name] -> ArgPatCounter) -> [Name] -> ArgPatCounter
forall a b. (a -> b) -> a -> b
$ 'underbar Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
ans) Q () -> Q Pat -> Q Pat
forall a b. Q a -> Q b -> Q b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [p|_|]

-- | Expands to @$(tr "/a b c d...") False@
tg :: Q Exp
tg :: Q Exp
tg = String -> Q Exp
tg' String
""

-- | Similar to 'tg' with message prefix with the argument.
tg' :: String -> Q Exp
tg' :: String -> Q Exp
tg' String
msgPrefix = do
  cfn <- Q FunName
I.currentFunName
  getQ >>= \case
    Maybe ArgPatCounter
Nothing -> Q Exp
forall {a}. Q a
er
    Just (ArgPatCounter FunName
fn [Name]
aNames)
      | FunName
fn FunName -> FunName -> Bool
forall a. Eq a => a -> a -> Bool
== FunName
cfn -> [|$(Q Exp -> String -> [Name] -> Q Exp
I.tr' [| \x -> x |] String
msgPrefix ([Name] -> Q Exp) -> [Name] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name]
forall a. [a] -> [a]
reverse [Name]
aNames) False|]
      | Bool
otherwise -> Q Exp
forall {a}. Q a
er
  where
    er :: Q a
er = String -> Q a
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Use 'Debug.TraceEmbrace.TH.a' macro to capture function arguments before calling 'tg'"

-- | Shortcut for 'undefined'
u :: Q Exp
u :: Q Exp
u = [| undefined |]