{-# 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 -- ^ Does not output traces, overrides other options
  | Inert -- ^ Does not output traces, doesn't override other options
  | Shallow -- ^ Outputs traces for current scope, but does not propagate
  | Deep -- ^ Outputs traces and propagates to descendents
  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
-- These are String because they need to be lifted into TH expressions
type FunName = String
type UserKey = String
type MessageContent = BSL.ByteString

data DebugTag =
  DT { DebugTag -> Word
invocationId :: {-# UNPACK #-} !Word -- a unique identifier for a particular invocation of a function
     , DebugTag -> Either String String
debugKey :: Either FunName UserKey
         -- The name of the function containing the current execution context
     }

data Event
  = EntryEvent
      !DebugTag -- ^ Current context
      !(Maybe DebugTag) -- ^ caller's context
      !(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
'§'

-- | Serialize an Event. The § character is used as both a separator and
-- terminator. Don't use this character in trace messages, it will break!
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
    }