{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ImplicitParams #-}
module Graph.Trace.Internal.Types
( DebugTag(..)
, DebugContext(..)
, Propagation(..)
, SrcCodeLoc(..)
, DefinitionSite
, CallSite
, DebugIP
, TraceMute
, TraceDeep
, TraceDeepKey
, Trace
, TraceKey
, TraceInert
, Event(..)
, eventToLogStr
, FunName
, UserKey
, SrcModule
, SrcLine
, SrcCol
, callStackToCallSite
, DebugNames(..)
) where
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Builder as BSB
import GHC.Stack
import GHC.TypeLits
import qualified Language.Haskell.TH.Syntax as TH
import qualified Graph.Trace.Internal.GhcFacade as Ghc
data Propagation
= Mute
| Inert
| Shallow
| Deep
deriving (Propagation -> Propagation -> Bool
(Propagation -> Propagation -> Bool)
-> (Propagation -> Propagation -> Bool) -> Eq Propagation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Propagation -> Propagation -> Bool
$c/= :: Propagation -> Propagation -> Bool
== :: Propagation -> Propagation -> Bool
$c== :: Propagation -> Propagation -> Bool
Eq, Int -> Propagation -> ShowS
[Propagation] -> ShowS
Propagation -> String
(Int -> Propagation -> ShowS)
-> (Propagation -> String)
-> ([Propagation] -> ShowS)
-> Show Propagation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Propagation] -> ShowS
$cshowList :: [Propagation] -> ShowS
show :: Propagation -> String
$cshow :: Propagation -> String
showsPrec :: Int -> Propagation -> ShowS
$cshowsPrec :: Int -> Propagation -> ShowS
Show, Propagation -> Q Exp
Propagation -> Q (TExp Propagation)
(Propagation -> Q Exp)
-> (Propagation -> Q (TExp Propagation)) -> Lift Propagation
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: Propagation -> Q (TExp Propagation)
$cliftTyped :: Propagation -> Q (TExp Propagation)
lift :: Propagation -> Q Exp
$clift :: Propagation -> Q Exp
TH.Lift)
data DebugContext =
DC { DebugContext -> Maybe DebugTag
previousTag :: !(Maybe DebugTag)
, DebugContext -> DebugTag
currentTag :: {-# UNPACK #-} !DebugTag
, DebugContext -> Propagation
propagation :: !Propagation
, DebugContext -> Maybe DefinitionSite
definitionSite :: !(Maybe DefinitionSite)
}
data SrcCodeLoc =
SrcCodeLoc
{ DefinitionSite -> String
srcModule :: !SrcModule
, DefinitionSite -> Int
srcLine :: !SrcLine
, DefinitionSite -> Int
srcCol :: !SrcCol
} deriving DefinitionSite -> Q Exp
DefinitionSite -> Q (TExp DefinitionSite)
(DefinitionSite -> Q Exp)
-> (DefinitionSite -> Q (TExp DefinitionSite))
-> Lift DefinitionSite
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: DefinitionSite -> Q (TExp DefinitionSite)
$cliftTyped :: DefinitionSite -> Q (TExp DefinitionSite)
lift :: DefinitionSite -> Q Exp
$clift :: DefinitionSite -> Q Exp
TH.Lift
type SrcModule = String
type SrcLine = Int
type SrcCol = Int
type DefinitionSite = SrcCodeLoc
type CallSite = SrcCodeLoc
type DebugIP = (?_debug_ip :: Maybe DebugContext, HasCallStack)
type TraceMute = DebugIP
type TraceDeep = DebugIP
type TraceDeepKey (key :: Symbol) = DebugIP
type Trace = DebugIP
type TraceKey (key :: Symbol) = DebugIP
type TraceInert = DebugIP
type FunName = String
type UserKey = String
type MessageContent = BSL.ByteString
data DebugTag =
DT { DebugTag -> Word
invocationId :: {-# UNPACK #-} !Word
, DebugTag -> Either String String
debugKey :: Either FunName UserKey
}
data Event
= EntryEvent
!DebugTag
!(Maybe DebugTag)
!(Maybe DefinitionSite)
!(Maybe CallSite)
| TraceEvent
!DebugTag
!MessageContent
!(Maybe CallSite)
callStackToCallSite :: CallStack -> Maybe CallSite
callStackToCallSite :: CallStack -> Maybe DefinitionSite
callStackToCallSite CallStack
cs =
case CallStack -> [(String, SrcLoc)]
getCallStack CallStack
cs of
(String
_, SrcLoc
srcLoc) : [(String, SrcLoc)]
_ ->
DefinitionSite -> Maybe DefinitionSite
forall a. a -> Maybe a
Just SrcCodeLoc :: String -> Int -> Int -> DefinitionSite
SrcCodeLoc
{ srcModule :: String
srcModule = SrcLoc -> String
srcLocFile SrcLoc
srcLoc
, srcLine :: Int
srcLine = SrcLoc -> Int
srcLocStartLine SrcLoc
srcLoc
, srcCol :: Int
srcCol = SrcLoc -> Int
srcLocStartCol SrcLoc
srcLoc
}
[(String, SrcLoc)]
_ -> Maybe DefinitionSite
forall a. Maybe a
Nothing
sep :: BSB.Builder
sep :: Builder
sep = Char -> Builder
BSB.char8 Char
'§'
eventToLogStr :: Event -> BSB.Builder
eventToLogStr :: Event -> Builder
eventToLogStr (EntryEvent DebugTag
current Maybe DebugTag
mPrevious Maybe DefinitionSite
mDefSite Maybe DefinitionSite
mCallSite)
= String -> Builder
BSB.stringUtf8 String
"entry" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
sep
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> DebugTag -> Builder
keyStr DebugTag
current Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
sep
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word -> Builder
BSB.wordDec (DebugTag -> Word
invocationId DebugTag
current) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
sep
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (DebugTag -> Builder) -> Maybe DebugTag -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap DebugTag -> Builder
keyStr Maybe DebugTag
mPrevious Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
sep
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (DebugTag -> Builder) -> Maybe DebugTag -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Word -> Builder
BSB.wordDec (Word -> Builder) -> (DebugTag -> Word) -> DebugTag -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DebugTag -> Word
invocationId) Maybe DebugTag
mPrevious Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
sep
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Maybe DefinitionSite -> Builder
srcCodeLocToLogStr Maybe DefinitionSite
mDefSite Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
sep
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Maybe DefinitionSite -> Builder
srcCodeLocToLogStr Maybe DefinitionSite
mCallSite Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
sep
eventToLogStr (TraceEvent DebugTag
current MessageContent
message Maybe DefinitionSite
mCallSite)
= String -> Builder
BSB.stringUtf8 String
"trace" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
sep
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> DebugTag -> Builder
keyStr DebugTag
current Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
sep
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word -> Builder
BSB.wordDec (DebugTag -> Word
invocationId DebugTag
current) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
sep
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> MessageContent -> Builder
BSB.lazyByteString MessageContent
message Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
sep
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Maybe DefinitionSite -> Builder
srcCodeLocToLogStr Maybe DefinitionSite
mCallSite Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
sep
srcCodeLocToLogStr :: Maybe SrcCodeLoc -> BSB.Builder
srcCodeLocToLogStr :: Maybe DefinitionSite -> Builder
srcCodeLocToLogStr Maybe DefinitionSite
mLoc
= (DefinitionSite -> Builder) -> Maybe DefinitionSite -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (String -> Builder
BSB.stringUtf8 (String -> Builder)
-> (DefinitionSite -> String) -> DefinitionSite -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DefinitionSite -> String
srcModule) Maybe DefinitionSite
mLoc Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
sep
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (DefinitionSite -> Builder) -> Maybe DefinitionSite -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Int -> Builder
BSB.intDec (Int -> Builder)
-> (DefinitionSite -> Int) -> DefinitionSite -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DefinitionSite -> Int
srcLine) Maybe DefinitionSite
mLoc Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
sep
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (DefinitionSite -> Builder) -> Maybe DefinitionSite -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Int -> Builder
BSB.intDec (Int -> Builder)
-> (DefinitionSite -> Int) -> DefinitionSite -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DefinitionSite -> Int
srcCol) Maybe DefinitionSite
mLoc
keyStr :: DebugTag -> BSB.Builder
keyStr :: DebugTag -> Builder
keyStr
= String -> Builder
BSB.stringUtf8
(String -> Builder) -> (DebugTag -> String) -> DebugTag -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> ShowS -> Either String String -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
ShowS
forall a. a -> a
id
ShowS
forall a. a -> a
id
(Either String String -> String)
-> (DebugTag -> Either String String) -> DebugTag -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DebugTag -> Either String String
debugKey
data DebugNames =
DebugNames
{ DebugNames -> Name
traceMutePredName :: Ghc.Name
, DebugNames -> Name
traceDeepPredName :: Ghc.Name
, DebugNames -> Name
traceDeepKeyPredName :: Ghc.Name
, DebugNames -> Name
tracePredName :: Ghc.Name
, DebugNames -> Name
traceKeyPredName :: Ghc.Name
, DebugNames -> Name
traceInertPredName :: Ghc.Name
, DebugNames -> Name
entryName :: Ghc.Name
, DebugNames -> Name
debugContextName :: Ghc.Name
}