{-# OPTIONS_HADDOCK hide #-}
module Debug.TraceEmbrace.Internal.TH where

import Control.DeepSeq
import Control.Lens hiding (levels)
import Control.Monad.Trans.State.Strict
import Control.Monad.Trans.Class qualified as MT
import Data.Char as C
import Data.IORef
import Data.Generics.Labels ()
import Data.Text qualified as T
import Data.IntMap.Strict qualified as IM
import Data.RadixTree.Word8.Strict qualified as T
import qualified Debug.Trace as T
import Debug.TraceEmbrace.Config
import Debug.TraceEmbrace.FileIndex
import Debug.TraceEmbrace.Internal.Rewrap
import Debug.TraceEmbrace.Show
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Prelude hiding (Show (..))
import Prelude qualified as P
import Refined
import System.IO
import System.IO.Unsafe (unsafePerformIO)
import Text.Printf

data TrMsgAndVars = TrMsgAndVars [Name] String  deriving (TrMsgAndVars -> TrMsgAndVars -> Bool
(TrMsgAndVars -> TrMsgAndVars -> Bool)
-> (TrMsgAndVars -> TrMsgAndVars -> Bool) -> Eq TrMsgAndVars
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TrMsgAndVars -> TrMsgAndVars -> Bool
== :: TrMsgAndVars -> TrMsgAndVars -> Bool
$c/= :: TrMsgAndVars -> TrMsgAndVars -> Bool
/= :: TrMsgAndVars -> TrMsgAndVars -> Bool
Eq, Int -> TrMsgAndVars -> String -> String
[TrMsgAndVars] -> String -> String
TrMsgAndVars -> String
(Int -> TrMsgAndVars -> String -> String)
-> (TrMsgAndVars -> String)
-> ([TrMsgAndVars] -> String -> String)
-> Show TrMsgAndVars
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> TrMsgAndVars -> String -> String
showsPrec :: Int -> TrMsgAndVars -> String -> String
$cshow :: TrMsgAndVars -> String
show :: TrMsgAndVars -> String
$cshowList :: [TrMsgAndVars] -> String -> String
showList :: [TrMsgAndVars] -> String -> String
P.Show)
data VarsPart = VarsPart [Name] String deriving (VarsPart -> VarsPart -> Bool
(VarsPart -> VarsPart -> Bool)
-> (VarsPart -> VarsPart -> Bool) -> Eq VarsPart
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: VarsPart -> VarsPart -> Bool
== :: VarsPart -> VarsPart -> Bool
$c/= :: VarsPart -> VarsPart -> Bool
/= :: VarsPart -> VarsPart -> Bool
Eq, Int -> VarsPart -> String -> String
[VarsPart] -> String -> String
VarsPart -> String
(Int -> VarsPart -> String -> String)
-> (VarsPart -> String)
-> ([VarsPart] -> String -> String)
-> Show VarsPart
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> VarsPart -> String -> String
showsPrec :: Int -> VarsPart -> String -> String
$cshow :: VarsPart -> String
show :: VarsPart -> String
$cshowList :: [VarsPart] -> String -> String
showList :: [VarsPart] -> String -> String
P.Show)
newtype ModTraceFlagVarName = ModTraceFlagVarName Name deriving (ModTraceFlagVarName -> ModTraceFlagVarName -> Bool
(ModTraceFlagVarName -> ModTraceFlagVarName -> Bool)
-> (ModTraceFlagVarName -> ModTraceFlagVarName -> Bool)
-> Eq ModTraceFlagVarName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ModTraceFlagVarName -> ModTraceFlagVarName -> Bool
== :: ModTraceFlagVarName -> ModTraceFlagVarName -> Bool
$c/= :: ModTraceFlagVarName -> ModTraceFlagVarName -> Bool
/= :: ModTraceFlagVarName -> ModTraceFlagVarName -> Bool
Eq, Int -> ModTraceFlagVarName -> String -> String
[ModTraceFlagVarName] -> String -> String
ModTraceFlagVarName -> String
(Int -> ModTraceFlagVarName -> String -> String)
-> (ModTraceFlagVarName -> String)
-> ([ModTraceFlagVarName] -> String -> String)
-> Show ModTraceFlagVarName
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ModTraceFlagVarName -> String -> String
showsPrec :: Int -> ModTraceFlagVarName -> String -> String
$cshow :: ModTraceFlagVarName -> String
show :: ModTraceFlagVarName -> String
$cshowList :: [ModTraceFlagVarName] -> String -> String
showList :: [ModTraceFlagVarName] -> String -> String
P.Show)

type SVarsFunM a = StateT (Maybe Name) Q a
type SVarsFun = TraceMessageFormat -> VarsPart -> SVarsFunM Exp

showTrace :: Show (ShowTrace a) => a -> String
showTrace :: forall a. Show (ShowTrace a) => a -> String
showTrace = ShowTrace a -> String
forall t. Show t => t -> String
show (ShowTrace a -> String) -> (a -> ShowTrace a) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ShowTrace a
forall a. a -> ShowTrace a
ShowTrace

-- | Extract var names from a word.
--
-- @
-- "_" => []
-- "0" => []
-- "(Just" => []
-- "x@[a,_c]"=> ["x", "a"]
-- "l@(h:t)"  => ["l", "h", "t"]
-- "{a,b}"    => ["a", "b"]
-- @
--
varNamesFromPat :: String -> [String]
varNamesFromPat :: String -> [String]
varNamesFromPat = [String] -> [String]
filterVars ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words (String -> [String]) -> (String -> String) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Char
replaceWithSpace (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
stripStrComment
  where
    filterVars :: [String] -> [String]
filterVars = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (\case { Char
h:String
_ -> Char -> Bool
C.isLower Char
h; [] -> Bool
False; })
    replaceWithSpace :: Char -> Char
replaceWithSpace Char
c
      | Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
",!@({[:]})~" = Char
' '
      | Bool
otherwise = Char
c

    dropTillEndOfString :: String -> String
dropTillEndOfString = \case
      String
"" -> String
""
      Char
'\\' : Char
'"' : String
t -> String -> String
dropTillEndOfString String
t
      Char
'"' : String
t -> String
t
      Char
_ : String
t -> String -> String
dropTillEndOfString String
t

    dropTillEndOfLine :: String -> String
dropTillEndOfLine = \case
      String
"" -> String
""
      Char
'\n' : String
t -> String
t
      Char
_ : String
t -> String -> String
dropTillEndOfLine String
t

    dropTillEndOfComment :: String -> String
dropTillEndOfComment = \case
      String
"" -> String
""
      Char
'-' : Char
'}' : String
t -> String
t
      Char
'{' : Char
'-' : String
t -> String -> String
dropTillEndOfComment (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
dropTillEndOfComment String
t
      Char
_ : String
t -> String -> String
dropTillEndOfComment String
t

    stripStrComment :: String -> String
stripStrComment = \case
      String
"" -> String
""
      Char
'"' : String
t -> String -> String
stripStrComment (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
dropTillEndOfString String
t
      Char
'-' : Char
'-' : String
t -> String -> String
stripStrComment (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
dropTillEndOfLine String
t
      Char
'{' : Char
'-' : String
t -> String -> String
stripStrComment (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
dropTillEndOfComment String
t
      Char
h : String
t -> Char
h Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
stripStrComment String
t

{- | Interpolate vars in the arugment.
Generated expression has type 'String'.
The argument has literal and interpolated parts.
There parts are separated with right slash (/).

@
foo x y = trace $(svars "get/x y") x
@

The snippet above is expanded into:

@
foo x y = trace ("get; x: " <> show x <> "; y: " <> show y) x
@

'Show' instance of some types (eg lazy ByteString) hide
internal structure which might be important in low level code.
Variables after ";" are wrapped into t'ShowTrace':

@
import Data.ByteString.Lazy
foo x = trace $(svars "get/x;x") x
@

The snippet above is expanded into:

@
foo x = trace ("get; x: " <> show x <> "; x: " <> show (ShowTrace y)) x
@

-}
svars :: SVarsFun
svars :: SVarsFun
svars TraceMessageFormat
tmf (VarsPart [Name]
patVars String
vars) = Q Exp -> StateT (Maybe Name) Q Exp
forall (m :: * -> *) a. Monad m => m a -> StateT (Maybe Name) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MT.lift (Q Exp -> StateT (Maybe Name) Q Exp)
-> Q Exp -> StateT (Maybe Name) Q Exp
forall a b. (a -> b) -> a -> b
$
  case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char
';' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=) String
vars of
    (String
showVars, Char
';' : String
traceVars) ->
      [| $([Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE (String -> [Q Exp]
noTraceVars String
showVars [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. Semigroup a => a -> a -> a
<> Name -> String -> [Q Exp]
wordsToVars 'showTrace String
traceVars)) :: [String] |]
    (String
showVars, String
"") ->
      [| $([Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE (String -> [Q Exp]
noTraceVars String
showVars)) :: [String] |]
    (String
sv, String
st) -> do
      String -> Q ()
reportError (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"No case for %s %s" String
sv String
st
      [| [] |]
  where
    noTraceVars :: String -> [Q Exp]
noTraceVars String
showVars =
      Name -> String -> [Q Exp]
wordsToVars 'show String
showVars [Q Exp] -> [Q Exp] -> [Q Exp]
forall a. Semigroup a => a -> a -> a
<> (Int -> Name -> Q Exp) -> [Int] -> [Name] -> [Q Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Name -> Int -> Name -> Q Exp
name2Var 'show) [Int
0 :: Int ..] [Name]
patVars

    name2Var :: Name -> Int -> Name -> Q Exp
name2Var Name
f Int
0 Name
vn = [| $(String -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
lift (String -> Q Exp)
-> (Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String
    -> String)
-> Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String
-> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String -> String
forall {k} (p :: k) x. Refined p x -> x
unrefine (Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String
 -> Q Exp)
-> Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String
-> Q Exp
forall a b. (a -> b) -> a -> b
$ TraceMessageFormat
tmf TraceMessageFormat
-> Getting
     (Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String)
     TraceMessageFormat
     (Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String)
-> Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String
forall s a. s -> Getting a s a -> a
^. Getting
  (Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String)
  TraceMessageFormat
  (Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String)
#entrySeparator) <> $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
vn) |]
    name2Var Name
f Int
_ Name
vn = [| " " <> $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
vn) |]

    wordsToVars :: Name -> String -> [Q Exp]
wordsToVars Name
f String
vss = (String -> Q Exp) -> [String] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Q Exp
go (String -> [String]
varNamesFromPat String
vss)
      where
        go :: String -> Q Exp
go String
vs =
          String -> Q (Maybe Name)
lookupValueName String
vs Q (Maybe Name) -> (Maybe Name -> Q Exp) -> Q Exp
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe Name
Nothing -> do
              String -> Q ()
reportError (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String
forall r. PrintfType r => String -> r
printf String
"no variable [%s]" String
vs
              [| $(String -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
lift String
vs) |]
            Just Name
vn ->
              [| $(String -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
lift (String -> Q Exp)
-> (Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String
    -> String)
-> Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String
-> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String -> String
forall {k} (p :: k) x. Refined p x -> x
unrefine (Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String
 -> Q Exp)
-> Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String
-> Q Exp
forall a b. (a -> b) -> a -> b
$ TraceMessageFormat
tmf TraceMessageFormat
-> Getting
     (Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String)
     TraceMessageFormat
     (Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String)
-> Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String
forall s a. s -> Getting a s a -> a
^. Getting
  (Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String)
  TraceMessageFormat
  (Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String)
#entrySeparator)
                 <> $(String -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
lift String
vs)
                 <> $(String -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
lift (String -> Q Exp)
-> (Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String
    -> String)
-> Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String
-> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String -> String
forall {k} (p :: k) x. Refined p x -> x
unrefine (Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String
 -> Q Exp)
-> Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String
-> Q Exp
forall a b. (a -> b) -> a -> b
$ TraceMessageFormat
tmf TraceMessageFormat
-> Getting
     (Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String)
     TraceMessageFormat
     (Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String)
-> Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String
forall s a. s -> Getting a s a -> a
^. Getting
  (Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String)
  TraceMessageFormat
  (Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String)
#keyValueSeparator)
                 <> $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
vn)
               |]

splitMessageFromVars :: TrMsgAndVars -> (String, VarsPart)
splitMessageFromVars :: TrMsgAndVars -> (String, VarsPart)
splitMessageFromVars (TrMsgAndVars [Name]
patVars String
trMsg) =
  case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char
'/' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=) String
trMsg of
    (String
msgPart, Char
'/':String
varPart) -> (String
msgPart, [Name] -> String -> VarsPart
VarsPart [Name]
patVars String
varPart)
    (String
msgPart, []) -> (String
msgPart, [Name] -> String -> VarsPart
VarsPart [Name]
patVars [])
    (String, String)
e ->  String -> (String, VarsPart)
forall a. HasCallStack => String -> a
error (String -> (String, VarsPart)) -> String -> (String, VarsPart)
forall a b. (a -> b) -> a -> b
$ String
"No case for:" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (String, String) -> String
forall t. Show t => t -> String
show (String, String)
e

traceMessageLevel :: [Name] -> String -> (TraceLevel, TrMsgAndVars)
traceMessageLevel :: [Name] -> String -> (TraceLevel, TrMsgAndVars)
traceMessageLevel [Name]
patVars = (String -> TrMsgAndVars)
-> (TraceLevel, String) -> (TraceLevel, TrMsgAndVars)
forall a b. (a -> b) -> (TraceLevel, a) -> (TraceLevel, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Name] -> String -> TrMsgAndVars
TrMsgAndVars [Name]
patVars) ((TraceLevel, String) -> (TraceLevel, TrMsgAndVars))
-> (String -> (TraceLevel, String))
-> String
-> (TraceLevel, TrMsgAndVars)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (TraceLevel, String)
charToLevel

-- | Suffix 'svars' with return value.
svarsWith :: SVarsFun
svarsWith :: SVarsFun
svarsWith TraceMessageFormat
tmf VarsPart
vp =
  StateT (Maybe Name) Q (Maybe Name)
forall (m :: * -> *) s. Monad m => StateT s m s
get StateT (Maybe Name) Q (Maybe Name)
-> (Maybe Name -> StateT (Maybe Name) Q Name)
-> StateT (Maybe Name) Q Name
forall a b.
StateT (Maybe Name) Q a
-> (a -> StateT (Maybe Name) Q b) -> StateT (Maybe Name) Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StateT (Maybe Name) Q Name
-> (Name -> StateT (Maybe Name) Q Name)
-> Maybe Name
-> StateT (Maybe Name) Q Name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((Name -> StateT (Maybe Name) Q ())
-> Name -> StateT (Maybe Name) Q Name
forall (m :: * -> *) a. Monad m => (a -> m ()) -> a -> m a
calret (Maybe Name -> StateT (Maybe Name) Q ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (Maybe Name -> StateT (Maybe Name) Q ())
-> (Name -> Maybe Name) -> Name -> StateT (Maybe Name) Q ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Maybe Name
forall a. a -> Maybe a
Just) (Name -> StateT (Maybe Name) Q Name)
-> StateT (Maybe Name) Q Name -> StateT (Maybe Name) Q Name
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q Name -> StateT (Maybe Name) Q Name
forall (m :: * -> *) a. Monad m => m a -> StateT (Maybe Name) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MT.lift (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"retVal")) Name -> StateT (Maybe Name) Q Name
forall a. a -> StateT (Maybe Name) Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StateT (Maybe Name) Q Name
-> (Name -> StateT (Maybe Name) Q Exp) -> StateT (Maybe Name) Q Exp
forall a b.
StateT (Maybe Name) Q a
-> (a -> StateT (Maybe Name) Q b) -> StateT (Maybe Name) Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Name
retValVarName -> Q Exp -> StateT (Maybe Name) Q Exp
forall (m :: * -> *) a. Monad m => m a -> StateT (Maybe Name) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MT.lift (Q Exp -> StateT (Maybe Name) Q Exp)
-> Q Exp -> StateT (Maybe Name) Q Exp
forall a b. (a -> b) -> a -> b
$
  [| $(StateT (Maybe Name) Q Exp -> Maybe Name -> Q Exp
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (SVarsFun
svars TraceMessageFormat
tmf VarsPart
vp) Maybe Name
forall a. Maybe a
Nothing)
     <> [ $(String -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
lift (String -> Q Exp)
-> (Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String
    -> String)
-> Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String
-> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String -> String
forall {k} (p :: k) x. Refined p x -> x
unrefine (Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String
 -> Q Exp)
-> Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String
-> Q Exp
forall a b. (a -> b) -> a -> b
$ TraceMessageFormat
tmf TraceMessageFormat
-> Getting
     (Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String)
     TraceMessageFormat
     (Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String)
-> Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String
forall s a. s -> Getting a s a -> a
^. Getting
  (Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String)
  TraceMessageFormat
  (Refined (And (SizeLessThan 5) (SizeGreaterThan 0)) String)
#retValPrefix)
        , show $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
retValVarName)
        ]
     {- :: (Rewrap a b, Show a) => a -> [String] -}
   |]

concat2 :: Monoid m => [[m]] -> m
concat2 :: forall m. Monoid m => [[m]] -> m
concat2 = [m] -> m
forall a. Monoid a => [a] -> a
mconcat ([m] -> m) -> ([[m]] -> [m]) -> [[m]] -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[m]] -> [m]
forall a. Monoid a => [a] -> a
mconcat
{-# INLINE concat2 #-}

currentFunName :: Q FunName
currentFunName :: Q FunName
currentFunName = do
  lc <- Q Loc
location
  let
    m = Loc -> String
loc_module Loc
lc
    line = (Int, Int) -> Int
forall a b. (a, b) -> a
fst ((Int, Int) -> Int) -> (Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ Loc -> (Int, Int)
loc_start Loc
lc
  fmap snd . IM.lookupLE line <$> getLineFileIndex lc >>= \case
    Maybe FunName
Nothing -> do
      String -> Q ()
reportWarning (String -> Int -> String -> String
forall r. PrintfType r => String -> r
printf String
"No function name for line [%d] in module [%s]" Int
line String
m)
      FunName -> Q FunName
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FunName -> Q FunName) -> FunName -> Q FunName
forall a b. (a -> b) -> a -> b
$ String -> FunName
FunName String
"N/A"
    Just FunName
fn -> FunName -> Q FunName
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FunName
fn
  where

-- | Format whole trace message
traceMessage :: TrMsgAndVars -> TraceMessageFormat -> SVarsFun -> Q Exp
traceMessage :: TrMsgAndVars -> TraceMessageFormat -> SVarsFun -> Q Exp
traceMessage TrMsgAndVars
mavs TraceMessageFormat
tmf SVarsFun
svarsFun =
  StateT (Maybe Name) Q [Exp] -> Maybe Name -> Q ([Exp], Maybe Name)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT (Maybe Name) Q [Exp]
itemExprs Maybe Name
forall a. Maybe a
Nothing Q ([Exp], Maybe Name) -> (([Exp], Maybe Name) -> Q Exp) -> Q Exp
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    ([Exp]
exprList, Maybe Name
Nothing) ->
      [| concat2 $(Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
ListE [Exp]
exprList) |]
    ([Exp]
exprList :: [Exp], Just Name
retValVarName) ->
      [| \ $(Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
retValVarName) -> concat2 $(Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
ListE [Exp]
exprList) |]
  where
    itemExprs :: SVarsFunM [Exp]
    itemExprs :: StateT (Maybe Name) Q [Exp]
itemExprs = [StateT (Maybe Name) Q Exp] -> StateT (Maybe Name) Q [Exp]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence (TraceMessageElement -> StateT (Maybe Name) Q Exp
genItem (TraceMessageElement -> StateT (Maybe Name) Q Exp)
-> [TraceMessageElement] -> [StateT (Maybe Name) Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Refined (SizeGreaterThan 0) [TraceMessageElement]
-> [TraceMessageElement]
forall {k} (p :: k) x. Refined p x -> x
unrefine (TraceMessageFormat
tmf TraceMessageFormat
-> Getting
     (Refined (SizeGreaterThan 0) [TraceMessageElement])
     TraceMessageFormat
     (Refined (SizeGreaterThan 0) [TraceMessageElement])
-> Refined (SizeGreaterThan 0) [TraceMessageElement]
forall s a. s -> Getting a s a -> a
^. Getting
  (Refined (SizeGreaterThan 0) [TraceMessageElement])
  TraceMessageFormat
  (Refined (SizeGreaterThan 0) [TraceMessageElement])
#traceLinePattern)))
    loc :: StateT (Maybe Name) Q Loc
loc = Q Loc -> StateT (Maybe Name) Q Loc
forall (m :: * -> *) a. Monad m => m a -> StateT (Maybe Name) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MT.lift Q Loc
location
    strL :: String -> Exp
strL = [Exp] -> Exp
ListE ([Exp] -> Exp) -> (String -> [Exp]) -> String -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
:[]) (Exp -> [Exp]) -> (String -> Exp) -> String -> [Exp]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lit -> Exp
LitE (Lit -> Exp) -> (String -> Lit) -> String -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL
    pStrL :: String -> StateT (Maybe Name) Q Exp
pStrL = Exp -> StateT (Maybe Name) Q Exp
forall a. a -> StateT (Maybe Name) Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> StateT (Maybe Name) Q Exp)
-> (String -> Exp) -> String -> StateT (Maybe Name) Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Exp
strL
    genItem :: TraceMessageElement -> SVarsFunM Exp
    genItem :: TraceMessageElement -> StateT (Maybe Name) Q Exp
genItem = \case
      TraceMessageElement
LiteralMessage -> String -> StateT (Maybe Name) Q Exp
pStrL (String -> StateT (Maybe Name) Q Exp)
-> ((String, VarsPart) -> String)
-> (String, VarsPart)
-> StateT (Maybe Name) Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, VarsPart) -> String
forall a b. (a, b) -> a
fst ((String, VarsPart) -> StateT (Maybe Name) Q Exp)
-> (String, VarsPart) -> StateT (Maybe Name) Q Exp
forall a b. (a -> b) -> a -> b
$ TrMsgAndVars -> (String, VarsPart)
splitMessageFromVars TrMsgAndVars
mavs
      TraceMessageElement
Variables -> SVarsFun
svarsFun TraceMessageFormat
tmf (VarsPart -> StateT (Maybe Name) Q Exp)
-> ((String, VarsPart) -> VarsPart)
-> (String, VarsPart)
-> StateT (Maybe Name) Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, VarsPart) -> VarsPart
forall a b. (a, b) -> b
snd ((String, VarsPart) -> StateT (Maybe Name) Q Exp)
-> (String, VarsPart) -> StateT (Maybe Name) Q Exp
forall a b. (a -> b) -> a -> b
$ TrMsgAndVars -> (String, VarsPart)
splitMessageFromVars TrMsgAndVars
mavs
      TraceMessageElement
FullyQualifiedModule -> String -> Exp
strL (String -> Exp) -> (Loc -> String) -> Loc -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> String
loc_module (Loc -> Exp)
-> StateT (Maybe Name) Q Loc -> StateT (Maybe Name) Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT (Maybe Name) Q Loc
loc
      TraceMessageElement
ModuleName ->
        String -> Exp
strL (String -> Exp) -> (Loc -> String) -> Loc -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (Loc -> String) -> Loc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.') (String -> String) -> (Loc -> String) -> Loc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (Loc -> String) -> Loc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> String
loc_module (Loc -> Exp)
-> StateT (Maybe Name) Q Loc -> StateT (Maybe Name) Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT (Maybe Name) Q Loc
loc
      TraceMessageElement
ShortenJavaModule -> do
        (eludom, htap) <- (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.') (String -> (String, String))
-> (Loc -> String) -> Loc -> (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (Loc -> String) -> Loc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> String
loc_module (Loc -> (String, String))
-> StateT (Maybe Name) Q Loc
-> StateT (Maybe Name) Q (String, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT (Maybe Name) Q Loc
loc
        pStrL $ shortenModPath True (reverse htap) <> (reverse eludom)
      TraceMessageElement
PackageName -> String -> Exp
strL (String -> Exp) -> (Loc -> String) -> Loc -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> String
loc_package (Loc -> Exp)
-> StateT (Maybe Name) Q Loc -> StateT (Maybe Name) Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT (Maybe Name) Q Loc
loc
      TraceMessageElement
FunctionName -> String -> Exp
strL (String -> Exp)
-> StateT (Maybe Name) Q String -> StateT (Maybe Name) Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q String -> StateT (Maybe Name) Q String
forall (m :: * -> *) a. Monad m => m a -> StateT (Maybe Name) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MT.lift (FunName -> String
unFunName (FunName -> String) -> Q FunName -> Q String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q FunName
currentFunName)
      TraceMessageElement
LineNumber -> String -> Exp
strL (String -> Exp) -> (Loc -> String) -> Loc -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
P.show (Int -> String) -> (Loc -> Int) -> Loc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> Int
forall a b. (a, b) -> a
fst ((Int, Int) -> Int) -> (Loc -> (Int, Int)) -> Loc -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> (Int, Int)
loc_start (Loc -> Exp)
-> StateT (Maybe Name) Q Loc -> StateT (Maybe Name) Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT (Maybe Name) Q Loc
loc
      Delimiter String
del -> String -> StateT (Maybe Name) Q Exp
pStrL String
del

shortenModPath :: Bool -> String -> String
shortenModPath :: Bool -> String -> String
shortenModPath Bool
prevDot
  | Bool
prevDot = \case
      Char
c : String
r -> Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: Bool -> String -> String
shortenModPath Bool
False String
r
      [] -> []
  | Bool
otherwise = \case
      Char
'.' : String
r -> Char
'.' Char -> String -> String
forall a. a -> [a] -> [a]
: Bool -> String -> String
shortenModPath Bool
True String
r
      Char
_ : String
r -> Bool -> String -> String
shortenModPath Bool
False String
r
      [] -> []

flagVarName :: Q Name
flagVarName :: Q Name
flagVarName = do
  l <- Q Loc
location
  let (line, col) = loc_start l
  newName $ "_trace_if_flag_on_line_" <> show line <> "_on_col_"  <> show col

getModTraceFlagVar :: Q Name
getModTraceFlagVar :: Q Name
getModTraceFlagVar = do
  vn <- Q Name
flagVarName
  putQ (ModTraceFlagVarName vn)
  nothingRefT <- [t| IORef (Maybe Bool) |]
  nothingRef <- [| unsafePerformIO (newIORef Nothing) |]
  addTopDecls
    [ SigD vn nothingRefT
    , ValD (VarP vn) (NormalB nothingRef) []
    , PragmaD (InlineP vn NoInline ConLike AllPhases)
    ]
  pure vn

isLevelOverThreshold :: T.Lookup TraceLevel -> TraceLevel -> Bool
isLevelOverThreshold :: Lookup TraceLevel -> TraceLevel -> Bool
isLevelOverThreshold (T.Lookup Build
_ TraceLevel
levelThreshold) TraceLevel
tl = TraceLevel
levelThreshold TraceLevel -> TraceLevel -> Bool
forall a. Ord a => a -> a -> Bool
<= TraceLevel
tl
{-# INLINE isLevelOverThreshold #-}

-- | Eval level and cache
readTraceFlag ::  T.Text -> TraceLevel -> DynConfigEnvVar -> IORef (Maybe Bool) -> IO Bool
readTraceFlag :: Text
-> TraceLevel -> DynConfigEnvVar -> IORef (Maybe Bool) -> IO Bool
readTraceFlag Text
modName TraceLevel
trLvl DynConfigEnvVar
evar IORef (Maybe Bool)
fv = do
  IORef (Maybe Bool) -> IO (Maybe Bool)
forall a. IORef a -> IO a
readIORef IORef (Maybe Bool)
fv IO (Maybe Bool) -> (Maybe Bool -> IO Bool) -> IO Bool
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Bool
r -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
r
    Maybe Bool
Nothing -> do
      Openness
-> Feed -> RadixTree TraceLevel -> Maybe (Lookup TraceLevel)
forall a. Openness -> Feed -> RadixTree a -> Maybe (Lookup a)
T.lookupL Openness
T.Open (Text -> Feed
T.feedText Text
modName) (RadixTree TraceLevel -> Maybe (Lookup TraceLevel))
-> IO (RadixTree TraceLevel) -> IO (Maybe (Lookup TraceLevel))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynConfigEnvVar -> IO (RadixTree TraceLevel)
getRuntimeConfig DynConfigEnvVar
evar IO (Maybe (Lookup TraceLevel))
-> (Maybe (Lookup TraceLevel) -> IO Bool) -> IO Bool
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just Lookup TraceLevel
threshold ->
          let !r :: Bool
r = Lookup TraceLevel -> TraceLevel -> Bool
isLevelOverThreshold Lookup TraceLevel
threshold TraceLevel
trLvl in
            IORef (Maybe Bool) -> Maybe Bool -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef (Maybe Bool)
fv (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
r) IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
r
        Maybe (Lookup TraceLevel)
Nothing ->
          IORef (Maybe Bool) -> Maybe Bool -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef (Maybe Bool)
fv (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False) IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
{-# INLINE readTraceFlag #-}

traceG :: TraceEmbraceConfig ->
  Q Exp ->
  (TrMsgAndVars -> TraceMessageFormat -> Q Exp) ->
  String ->
  [Name] ->
  Q Exp
traceG :: TraceEmbraceConfig
-> Q Exp
-> (TrMsgAndVars -> TraceMessageFormat -> Q Exp)
-> String
-> [Name]
-> Q Exp
traceG TraceEmbraceConfig
c Q Exp
idF TrMsgAndVars -> TraceMessageFormat -> Q Exp
genTraceLine String
s [Name]
patVars =
  case TraceEmbraceConfig
c TraceEmbraceConfig
-> Getting SinkMode TraceEmbraceConfig SinkMode -> SinkMode
forall s a. s -> Getting a s a -> a
^. Getting SinkMode TraceEmbraceConfig SinkMode
#mode of
    SinkMode
TraceDisabled -> Q Exp
idF
    SinkMode
TraceStd -> Q Exp
go
    TraceUnsafeIo IoSink
_ -> Q Exp
go
    SinkMode
TraceEvent -> Q Exp
go
  where
    go :: Q Exp
go =
      case [Name] -> String -> (TraceLevel, TrMsgAndVars)
traceMessageLevel [Name]
patVars String
s of
        (TraceLevel
TracingDisabled, TrMsgAndVars
_) -> Q Exp
idF
        (TraceLevel
tl, TrMsgAndVars
s') -> do
          loc <- Q Loc
location
          let modName = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Loc -> String
loc_module Loc
loc
          case T.lookupL T.Open (T.feedText modName) $ c ^. #levels of
            Maybe (Lookup TraceLevel)
Nothing -> Q Exp
idF
            Just Lookup TraceLevel
threshold
              | Lookup TraceLevel -> TraceLevel -> Bool
isLevelOverThreshold Lookup TraceLevel
threshold TraceLevel
tl ->
                case Loc -> EnvironmentVariable -> Maybe DynConfigEnvVar
envVarName Loc
loc (TraceEmbraceConfig
c TraceEmbraceConfig
-> Getting
     EnvironmentVariable TraceEmbraceConfig EnvironmentVariable
-> EnvironmentVariable
forall s a. s -> Getting a s a -> a
^. Getting EnvironmentVariable TraceEmbraceConfig EnvironmentVariable
#runtimeLevelsOverrideEnvVar) of
                  Just DynConfigEnvVar
evar -> do
                    vn <- Q Name
getModTraceFlagVar
                    [| case unsafePerformIO (readTraceFlag modName tl evar $(varE vn)) of
                         True -> $(genTraceLine s' $ c ^. #traceMessage)
                         False -> $(idF)
                     |]
                  Maybe DynConfigEnvVar
Nothing -> TrMsgAndVars -> TraceMessageFormat -> Q Exp
genTraceLine TrMsgAndVars
s' (TraceMessageFormat -> Q Exp) -> TraceMessageFormat -> Q Exp
forall a b. (a -> b) -> a -> b
$ TraceEmbraceConfig
c TraceEmbraceConfig
-> Getting TraceMessageFormat TraceEmbraceConfig TraceMessageFormat
-> TraceMessageFormat
forall s a. s -> Getting a s a -> a
^. Getting TraceMessageFormat TraceEmbraceConfig TraceMessageFormat
#traceMessage
              | Bool
otherwise -> Q Exp
idF

unsafePutStrLn :: IoSink -> String -> a -> a
unsafePutStrLn :: forall a. IoSink -> String -> a -> a
unsafePutStrLn IoSink
s String
msg a
v =
  String
msg String -> a -> a
forall a b. NFData a => a -> b -> b
`deepseq` (IO () -> ()
forall a. IO a -> a
unsafePerformIO (Handle -> String -> IO ()
hPutStrLn (IoSink -> Handle
getSinkHandle IoSink
s) String
msg)) () -> a -> a
forall a b. a -> b -> b
`seq` a
v
  where
{-# NOINLINE unsafePutStrLn #-}

getSinkHandle :: IoSink -> Handle
getSinkHandle :: IoSink -> Handle
getSinkHandle IoSink
s =
  case IoSink
s of
    IoSink
StdErrSink -> Handle
stderr
    IoSink
StdOutSink -> Handle
stdout
    FileSink String
fp -> IO Handle -> Handle
forall a. IO a -> a
unsafePerformIO (IO Handle -> Handle) -> IO Handle -> Handle
forall a b. (a -> b) -> a -> b
$ do
      IORef (Maybe Handle) -> IO (Maybe Handle)
forall a. IORef a -> IO a
readIORef IORef (Maybe Handle)
unsafeIoSink IO (Maybe Handle) -> (Maybe Handle -> IO Handle) -> IO Handle
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just Handle
h -> Handle -> IO Handle
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
h
        Maybe Handle
Nothing -> do
          nh <- String -> IOMode -> IO Handle
openFile String
fp IOMode
AppendMode
          (atomicModifyIORef' unsafeIoSink $ \case
            Maybe Handle
Nothing -> (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
nh, (Bool
False, Handle
nh))
            Just Handle
oh -> (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
oh, (Bool
True, Handle
oh))) >>= \case
               (Bool
True, Handle
h) ->  Handle -> IO ()
hClose Handle
nh IO () -> IO Handle -> IO Handle
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO Handle
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
h
               (Bool
False, Handle
h) -> Handle -> IO Handle
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
h

safePutStrLn :: IoSink -> String -> a -> IO a
safePutStrLn :: forall a. IoSink -> String -> a -> IO a
safePutStrLn IoSink
s String
msg a
v =
  Handle -> String -> IO ()
hPutStrLn (IoSink -> Handle
getSinkHandle IoSink
s) String
msg IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v

chooseTraceFunOnTh :: Show s => TraceEmbraceConfig -> s -> Q Exp
chooseTraceFunOnTh :: forall s. Show s => TraceEmbraceConfig -> s -> Q Exp
chooseTraceFunOnTh TraceEmbraceConfig
c s
s =
  case TraceEmbraceConfig
c TraceEmbraceConfig
-> Getting SinkMode TraceEmbraceConfig SinkMode -> SinkMode
forall s a. s -> Getting a s a -> a
^. Getting SinkMode TraceEmbraceConfig SinkMode
#mode of
    SinkMode
TraceDisabled -> String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"Dead code on" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> s -> String
forall t. Show t => t -> String
show s
s
    SinkMode
TraceStd -> Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'T.trace
    TraceUnsafeIo IoSink
snk -> [| unsafePutStrLn snk |]
    SinkMode
TraceEvent -> Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'T.traceEvent

tr :: Q Exp -> String -> Q Exp
tr :: Q Exp -> String -> Q Exp
tr Q Exp
idF String
rawMsg = Q Exp -> String -> [Name] -> Q Exp
tr' Q Exp
idF String
rawMsg []

tr' :: Q Exp -> String -> [Name]-> Q Exp
tr' :: Q Exp -> String -> [Name] -> Q Exp
tr' Q Exp
idF String
rawMsg [Name]
patVars = do
  c <- Q TraceEmbraceConfig
getConfig
  traceG c idF (go c) rawMsg patVars
  where
    go :: TraceEmbraceConfig -> TrMsgAndVars -> TraceMessageFormat -> Q Exp
go TraceEmbraceConfig
c TrMsgAndVars
s TraceMessageFormat
fmt =
      [| \x -> unwrap ($(TraceEmbraceConfig -> TrMsgAndVars -> Q Exp
forall s. Show s => TraceEmbraceConfig -> s -> Q Exp
chooseTraceFunOnTh TraceEmbraceConfig
c TrMsgAndVars
s) $(TrMsgAndVars -> TraceMessageFormat -> SVarsFun -> Q Exp
traceMessage TrMsgAndVars
s TraceMessageFormat
fmt SVarsFun
svars) (wrap x)) |]

tw :: Q Exp -> String -> Q Exp
tw :: Q Exp -> String -> Q Exp
tw Q Exp
idF String
rawMsg = do
  c <- Q TraceEmbraceConfig
getConfig
  traceG c idF (go c) rawMsg []
  where
    go :: TraceEmbraceConfig -> TrMsgAndVars -> TraceMessageFormat -> Q Exp
go TraceEmbraceConfig
c TrMsgAndVars
s TraceMessageFormat
fmt =
      [| \x -> unwrap ($(TraceEmbraceConfig -> TrMsgAndVars -> Q Exp
forall s. Show s => TraceEmbraceConfig -> s -> Q Exp
chooseTraceFunOnTh TraceEmbraceConfig
c TrMsgAndVars
s)
                        ($(TrMsgAndVars -> TraceMessageFormat -> SVarsFun -> Q Exp
traceMessage TrMsgAndVars
s TraceMessageFormat
fmt SVarsFun
svarsWith) x)
                        (wrap x))
       |]

tw' :: Q Exp -> String -> Q Exp
tw' :: Q Exp -> String -> Q Exp
tw' Q Exp
idF String
rawMsg = do
  c <- Q TraceEmbraceConfig
getConfig
  traceG c idF (go c) rawMsg []
  where
    go :: TraceEmbraceConfig -> TrMsgAndVars -> TraceMessageFormat -> Q Exp
go TraceEmbraceConfig
c TrMsgAndVars
s TraceMessageFormat
fmt =
      [| \x -> unwrap ($(TraceEmbraceConfig -> TrMsgAndVars -> Q Exp
forall s. Show s => TraceEmbraceConfig -> s -> Q Exp
chooseTraceFunOnTh TraceEmbraceConfig
c TrMsgAndVars
s)
                        ($(TrMsgAndVars -> TraceMessageFormat -> SVarsFun -> Q Exp
traceMessage TrMsgAndVars
s TraceMessageFormat
fmt SVarsFun
svarsWith) (ShowTrace x))
                        (wrap x))
       |]

chooseTraceIoFunOnTh :: Show s => TraceEmbraceConfig -> s -> Q Exp
chooseTraceIoFunOnTh :: forall s. Show s => TraceEmbraceConfig -> s -> Q Exp
chooseTraceIoFunOnTh TraceEmbraceConfig
c s
s =
  case TraceEmbraceConfig
c TraceEmbraceConfig
-> Getting SinkMode TraceEmbraceConfig SinkMode -> SinkMode
forall s a. s -> Getting a s a -> a
^. Getting SinkMode TraceEmbraceConfig SinkMode
#mode of
    SinkMode
TraceDisabled -> String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"Dead code on" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> s -> String
forall t. Show t => t -> String
show s
s
    SinkMode
TraceStd -> Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'T.traceIO
    TraceUnsafeIo IoSink
snk -> [| hPutStrLn (getSinkHandle snk) |]
    SinkMode
TraceEvent -> Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'T.traceEventIO

trIo :: Q Exp -> String -> Q Exp
trIo :: Q Exp -> String -> Q Exp
trIo Q Exp
idF String
rawMsg = do
  c <- Q TraceEmbraceConfig
getConfig
  traceG c idF (go c) rawMsg []
  where
    go :: TraceEmbraceConfig -> TrMsgAndVars -> TraceMessageFormat -> Q Exp
go TraceEmbraceConfig
c TrMsgAndVars
s TraceMessageFormat
fmt =
      [| $(TraceEmbraceConfig -> TrMsgAndVars -> Q Exp
forall s. Show s => TraceEmbraceConfig -> s -> Q Exp
chooseTraceIoFunOnTh TraceEmbraceConfig
c TrMsgAndVars
s) $(TrMsgAndVars -> TraceMessageFormat -> SVarsFun -> Q Exp
traceMessage TrMsgAndVars
s TraceMessageFormat
fmt SVarsFun
svars) |]

trFunMarker :: Q Exp -> Q Exp
trFunMarker :: Q Exp -> Q Exp
trFunMarker Q Exp
idF = do
  c <- Q TraceEmbraceConfig
getConfig
  let finalC = if TraceEmbraceConfig
c TraceEmbraceConfig
-> Getting SinkMode TraceEmbraceConfig SinkMode -> SinkMode
forall s a. s -> Getting a s a -> a
^. Getting SinkMode TraceEmbraceConfig SinkMode
#mode SinkMode -> SinkMode -> Bool
forall a. Eq a => a -> a -> Bool
== SinkMode
TraceDisabled then TraceEmbraceConfig
c else TraceEmbraceConfig
markerConfig
  traceG finalC idF go "/" []
  where
    go :: TrMsgAndVars -> TraceMessageFormat -> Q Exp
go TrMsgAndVars
s TraceMessageFormat
fmt =
      [| \x -> unwrap (T.traceMarker $(TrMsgAndVars -> TraceMessageFormat -> SVarsFun -> Q Exp
traceMessage TrMsgAndVars
s TraceMessageFormat
fmt SVarsFun
svars) (wrap x)) |]

trIoFunMarker :: Q Exp -> Q Exp
trIoFunMarker :: Q Exp -> Q Exp
trIoFunMarker Q Exp
idF = do
  c <- Q TraceEmbraceConfig
getConfig
  let finalC = if TraceEmbraceConfig
c TraceEmbraceConfig
-> Getting SinkMode TraceEmbraceConfig SinkMode -> SinkMode
forall s a. s -> Getting a s a -> a
^. Getting SinkMode TraceEmbraceConfig SinkMode
#mode SinkMode -> SinkMode -> Bool
forall a. Eq a => a -> a -> Bool
== SinkMode
TraceDisabled then TraceEmbraceConfig
c else TraceEmbraceConfig
markerConfig
  traceG finalC idF go "/" []
  where
    go :: TrMsgAndVars -> TraceMessageFormat -> Q Exp
go TrMsgAndVars
s TraceMessageFormat
fmt =
      [| T.traceMarkerIO $(TrMsgAndVars -> TraceMessageFormat -> SVarsFun -> Q Exp
traceMessage TrMsgAndVars
s TraceMessageFormat
fmt SVarsFun
svars) |]