{-# 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.Lazy.Char8 as BSL8
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

-- | 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 -> BSL.ByteString
eventToLogStr :: Event -> ByteString
eventToLogStr (EntryEvent DebugTag
current Maybe DebugTag
mPrevious Maybe DefinitionSite
mDefSite Maybe DefinitionSite
mCallSite) =
  ByteString -> [ByteString] -> ByteString
BSL8.intercalate ByteString
"§"
    [ ByteString
"entry"
    , DebugTag -> ByteString
keyStr DebugTag
current
    , String -> ByteString
BSL8.pack (String -> ByteString) -> (Word -> String) -> Word -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> String
forall a. Show a => a -> String
show (Word -> ByteString) -> Word -> ByteString
forall a b. (a -> b) -> a -> b
$ DebugTag -> Word
invocationId DebugTag
current
    , ByteString
-> (DebugTag -> ByteString) -> Maybe DebugTag -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" DebugTag -> ByteString
keyStr Maybe DebugTag
mPrevious
    , ByteString
-> (DebugTag -> ByteString) -> Maybe DebugTag -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" (String -> ByteString
BSL8.pack (String -> ByteString)
-> (DebugTag -> String) -> DebugTag -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> String
forall a. Show a => a -> String
show (Word -> String) -> (DebugTag -> Word) -> DebugTag -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DebugTag -> Word
invocationId) Maybe DebugTag
mPrevious
    , Maybe DefinitionSite -> ByteString
srcCodeLocToLogStr Maybe DefinitionSite
mDefSite
    , Maybe DefinitionSite -> ByteString
srcCodeLocToLogStr Maybe DefinitionSite
mCallSite
    ] ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"§"
eventToLogStr (TraceEvent DebugTag
current ByteString
message Maybe DefinitionSite
mCallSite) =
  ByteString -> [ByteString] -> ByteString
BSL8.intercalate ByteString
"§"
    [ ByteString
"trace"
    , DebugTag -> ByteString
keyStr DebugTag
current
    , String -> ByteString
BSL8.pack (String -> ByteString) -> (Word -> String) -> Word -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> String
forall a. Show a => a -> String
show (Word -> ByteString) -> Word -> ByteString
forall a b. (a -> b) -> a -> b
$ DebugTag -> Word
invocationId DebugTag
current
    , ByteString
message
    , Maybe DefinitionSite -> ByteString
srcCodeLocToLogStr Maybe DefinitionSite
mCallSite
    ] ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"§"

srcCodeLocToLogStr :: Maybe SrcCodeLoc -> BSL.ByteString
srcCodeLocToLogStr :: Maybe DefinitionSite -> ByteString
srcCodeLocToLogStr Maybe DefinitionSite
mLoc =
  ByteString -> [ByteString] -> ByteString
BSL8.intercalate ByteString
"§"
    [ (DefinitionSite -> ByteString)
-> Maybe DefinitionSite -> ByteString
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (String -> ByteString
BSL8.pack (String -> ByteString)
-> (DefinitionSite -> String) -> DefinitionSite -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DefinitionSite -> String
srcModule) Maybe DefinitionSite
mLoc
    , (DefinitionSite -> ByteString)
-> Maybe DefinitionSite -> ByteString
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (String -> ByteString
BSL8.pack (String -> ByteString)
-> (DefinitionSite -> String) -> DefinitionSite -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String)
-> (DefinitionSite -> Int) -> DefinitionSite -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DefinitionSite -> Int
srcLine) Maybe DefinitionSite
mLoc
    , (DefinitionSite -> ByteString)
-> Maybe DefinitionSite -> ByteString
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (String -> ByteString
BSL8.pack (String -> ByteString)
-> (DefinitionSite -> String) -> DefinitionSite -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String)
-> (DefinitionSite -> Int) -> DefinitionSite -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DefinitionSite -> Int
srcCol) Maybe DefinitionSite
mLoc
    ]

keyStr :: DebugTag -> BSL.ByteString
keyStr :: DebugTag -> ByteString
keyStr
  = (String -> ByteString)
-> (String -> ByteString) -> Either String String -> ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
      String -> ByteString
BSL8.pack
      String -> ByteString
BSL8.pack
  (Either String String -> ByteString)
-> (DebugTag -> Either String String) -> DebugTag -> ByteString
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
    }