{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE RankNTypes #-}
module Platform.Internal where
import Basics
import Control.Applicative ((<|>))
import qualified Control.AutoUpdate as AutoUpdate
import qualified Control.Concurrent.Async as Async
import qualified Control.Exception.Safe as Exception
import Data.Aeson ((.:), (.:?), (.=))
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Encoding as Aeson.Encoding
import qualified Data.IORef as IORef
import qualified Data.Text
import qualified Data.Typeable as Typeable
import qualified GHC.Clock as Clock
import GHC.Generics (Generic)
import qualified GHC.Stack as Stack
import qualified GHC.Word
import Internal.Shortcut (andThen, map)
import qualified Internal.Shortcut as Shortcut
import qualified List
import Maybe (Maybe (..))
import Result (Result (Err, Ok))
import qualified System.Mem
import qualified System.Mem as Mem
import qualified System.Timeout as Timeout
import Text (Text)
import qualified Tuple
import Prelude
( Applicative (pure, (<*>)),
Functor,
IO,
Monad ((>>=)),
)
import qualified Prelude
newtype Task x a = Task {Task x a -> LogHandler -> IO (Result x a)
_run :: LogHandler -> IO (Result x a)}
deriving (a -> Task x b -> Task x a
(a -> b) -> Task x a -> Task x b
(forall a b. (a -> b) -> Task x a -> Task x b)
-> (forall a b. a -> Task x b -> Task x a) -> Functor (Task x)
forall a b. a -> Task x b -> Task x a
forall a b. (a -> b) -> Task x a -> Task x b
forall x a b. a -> Task x b -> Task x a
forall x a b. (a -> b) -> Task x a -> Task x b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Task x b -> Task x a
$c<$ :: forall x a b. a -> Task x b -> Task x a
fmap :: (a -> b) -> Task x a -> Task x b
$cfmap :: forall x a b. (a -> b) -> Task x a -> Task x b
Functor)
instance Applicative (Task a) where
pure :: a -> Task a a
pure a
a =
(LogHandler -> IO (Result a a)) -> Task a a
forall x a. (LogHandler -> IO (Result x a)) -> Task x a
Task (\LogHandler
_ -> Result a a -> IO (Result a a)
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure (a -> Result a a
forall error value. value -> Result error value
Ok a
a))
<*> :: Task a (a -> b) -> Task a a -> Task a b
(<*>) Task a (a -> b)
func Task a a
task =
(LogHandler -> IO (Result a b)) -> Task a b
forall x a. (LogHandler -> IO (Result x a)) -> Task x a
Task ((LogHandler -> IO (Result a b)) -> Task a b)
-> (LogHandler -> IO (Result a b)) -> Task a b
forall a b. (a -> b) -> a -> b
<| \LogHandler
key ->
let onResult :: Result error (t -> value) -> Result error t -> Result error value
onResult Result error (t -> value)
resultFunc Result error t
resultTask =
case (Result error (t -> value)
resultFunc, Result error t
resultTask) of
(Ok t -> value
func_, Ok t
task_) ->
value -> Result error value
forall error value. value -> Result error value
Ok (t -> value
func_ t
task_)
(Err error
x, Result error t
_) ->
error -> Result error value
forall error value. error -> Result error value
Err error
x
(Result error (t -> value)
_, Err error
x) ->
error -> Result error value
forall error value. error -> Result error value
Err error
x
in do
Result a (a -> b)
func_ <- Task a (a -> b) -> LogHandler -> IO (Result a (a -> b))
forall x a. Task x a -> LogHandler -> IO (Result x a)
_run Task a (a -> b)
func LogHandler
key
Result a a
task_ <- Task a a -> LogHandler -> IO (Result a a)
forall x a. Task x a -> LogHandler -> IO (Result x a)
_run Task a a
task LogHandler
key
Result a b -> IO (Result a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result a (a -> b) -> Result a a -> Result a b
forall error t value.
Result error (t -> value) -> Result error t -> Result error value
onResult Result a (a -> b)
func_ Result a a
task_)
instance Monad (Task a) where
Task a a
task >>= :: Task a a -> (a -> Task a b) -> Task a b
>>= a -> Task a b
func =
(LogHandler -> IO (Result a b)) -> Task a b
forall x a. (LogHandler -> IO (Result x a)) -> Task x a
Task ((LogHandler -> IO (Result a b)) -> Task a b)
-> (LogHandler -> IO (Result a b)) -> Task a b
forall a b. (a -> b) -> a -> b
<| \LogHandler
key ->
let onResult :: Result a a -> IO (Result a b)
onResult Result a a
result =
case Result a a
result of
Ok a
ok ->
Task a b -> LogHandler -> IO (Result a b)
forall x a. Task x a -> LogHandler -> IO (Result x a)
_run (a -> Task a b
func a
ok) LogHandler
key
Err a
err ->
Result a b -> IO (Result a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Result a b
forall error value. error -> Result error value
Err a
err)
in Task a a -> LogHandler -> IO (Result a a)
forall x a. Task x a -> LogHandler -> IO (Result x a)
_run Task a a
task LogHandler
key IO (Result a a)
-> (IO (Result a a) -> IO (Result a b)) -> IO (Result a b)
forall a b. a -> (a -> b) -> b
|> (Result a a -> IO (Result a b))
-> IO (Result a a) -> IO (Result a b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
andThen Result a a -> IO (Result a b)
onResult
data TracingSpan = TracingSpan
{
TracingSpan -> Text
name :: Text,
TracingSpan -> MonotonicTime
started :: MonotonicTime,
TracingSpan -> MonotonicTime
finished :: MonotonicTime,
TracingSpan -> Maybe (Text, SrcLoc)
frame :: Maybe (Text, Stack.SrcLoc),
TracingSpan -> Maybe SomeTracingSpanDetails
details :: Maybe SomeTracingSpanDetails,
TracingSpan -> Maybe Text
summary :: Maybe Text,
TracingSpan -> Succeeded
succeeded :: Succeeded,
TracingSpan -> Int
allocated :: Int,
TracingSpan -> [TracingSpan]
children :: [TracingSpan]
}
deriving (Int -> TracingSpan -> ShowS
[TracingSpan] -> ShowS
TracingSpan -> String
(Int -> TracingSpan -> ShowS)
-> (TracingSpan -> String)
-> ([TracingSpan] -> ShowS)
-> Show TracingSpan
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TracingSpan] -> ShowS
$cshowList :: [TracingSpan] -> ShowS
show :: TracingSpan -> String
$cshow :: TracingSpan -> String
showsPrec :: Int -> TracingSpan -> ShowS
$cshowsPrec :: Int -> TracingSpan -> ShowS
Prelude.Show, (forall x. TracingSpan -> Rep TracingSpan x)
-> (forall x. Rep TracingSpan x -> TracingSpan)
-> Generic TracingSpan
forall x. Rep TracingSpan x -> TracingSpan
forall x. TracingSpan -> Rep TracingSpan x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TracingSpan x -> TracingSpan
$cfrom :: forall x. TracingSpan -> Rep TracingSpan x
Generic)
instance Aeson.ToJSON TracingSpan where
toJSON :: TracingSpan -> Value
toJSON TracingSpan
span =
[Pair] -> Value
Aeson.object
[ Text
"name" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TracingSpan -> Text
name TracingSpan
span,
Text
"started" Text -> MonotonicTime -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TracingSpan -> MonotonicTime
started TracingSpan
span,
Text
"finished" Text -> MonotonicTime -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TracingSpan -> MonotonicTime
finished TracingSpan
span,
Text
"frame" Text -> Maybe SrcLocForEncoding -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ((Text, SrcLoc) -> SrcLocForEncoding)
-> Maybe (Text, SrcLoc) -> Maybe SrcLocForEncoding
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map (Text, SrcLoc) -> SrcLocForEncoding
SrcLocForEncoding (TracingSpan -> Maybe (Text, SrcLoc)
frame TracingSpan
span),
Text
"details" Text -> Maybe SomeTracingSpanDetails -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TracingSpan -> Maybe SomeTracingSpanDetails
details TracingSpan
span,
Text
"summary" Text -> Maybe Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TracingSpan -> Maybe Text
summary TracingSpan
span,
Text
"succeeded" Text -> Succeeded -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TracingSpan -> Succeeded
succeeded TracingSpan
span,
Text
"allocated" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TracingSpan -> Int
allocated TracingSpan
span,
Text
"children" Text -> [TracingSpan] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TracingSpan -> [TracingSpan]
children TracingSpan
span
]
toEncoding :: TracingSpan -> Encoding
toEncoding TracingSpan
span =
Series -> Encoding
Aeson.pairs
( Text
"name" Text -> Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TracingSpan -> Text
name TracingSpan
span
Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"started" Text -> MonotonicTime -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TracingSpan -> MonotonicTime
started TracingSpan
span
Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"finished" Text -> MonotonicTime -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TracingSpan -> MonotonicTime
finished TracingSpan
span
Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"frame" Text -> Maybe SrcLocForEncoding -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ((Text, SrcLoc) -> SrcLocForEncoding)
-> Maybe (Text, SrcLoc) -> Maybe SrcLocForEncoding
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map (Text, SrcLoc) -> SrcLocForEncoding
SrcLocForEncoding (TracingSpan -> Maybe (Text, SrcLoc)
frame TracingSpan
span)
Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"details" Text -> Maybe SomeTracingSpanDetails -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TracingSpan -> Maybe SomeTracingSpanDetails
details TracingSpan
span
Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"summary" Text -> Maybe Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TracingSpan -> Maybe Text
summary TracingSpan
span
Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"succeeded" Text -> Succeeded -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TracingSpan -> Succeeded
succeeded TracingSpan
span
Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"allocated" Text -> Int -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TracingSpan -> Int
allocated TracingSpan
span
Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"children" Text -> [TracingSpan] -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TracingSpan -> [TracingSpan]
children TracingSpan
span
)
instance Aeson.FromJSON TracingSpan where
parseJSON :: Value -> Parser TracingSpan
parseJSON =
String
-> (Object -> Parser TracingSpan) -> Value -> Parser TracingSpan
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject
String
"TracingSpan"
( \Object
object -> do
Text
name <- Object
object Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"name"
MonotonicTime
started <- Object
object Object -> Text -> Parser MonotonicTime
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"started"
MonotonicTime
finished <- Object
object Object -> Text -> Parser MonotonicTime
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"finished"
Maybe (Text, SrcLoc)
frame <- (Maybe SrcLocForEncoding -> Maybe (Text, SrcLoc))
-> Parser (Maybe SrcLocForEncoding)
-> Parser (Maybe (Text, SrcLoc))
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map ((SrcLocForEncoding -> (Text, SrcLoc))
-> Maybe SrcLocForEncoding -> Maybe (Text, SrcLoc)
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map SrcLocForEncoding -> (Text, SrcLoc)
unSrcLocForEncoding) (Object
object Object -> Text -> Parser (Maybe SrcLocForEncoding)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"frame")
Maybe SomeTracingSpanDetails
details <- Object
object Object -> Text -> Parser (Maybe SomeTracingSpanDetails)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"details"
Maybe Text
summary <- Object
object Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"summary"
Succeeded
succeeded <- Object
object Object -> Text -> Parser Succeeded
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"succeeded"
Int
allocated <- Object
object Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"allocated"
[TracingSpan]
children <- Object
object Object -> Text -> Parser [TracingSpan]
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"children"
TracingSpan -> Parser TracingSpan
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure
TracingSpan :: Text
-> MonotonicTime
-> MonotonicTime
-> Maybe (Text, SrcLoc)
-> Maybe SomeTracingSpanDetails
-> Maybe Text
-> Succeeded
-> Int
-> [TracingSpan]
-> TracingSpan
TracingSpan
{ Text
name :: Text
name :: Text
name,
MonotonicTime
started :: MonotonicTime
started :: MonotonicTime
started,
MonotonicTime
finished :: MonotonicTime
finished :: MonotonicTime
finished,
Maybe (Text, SrcLoc)
frame :: Maybe (Text, SrcLoc)
frame :: Maybe (Text, SrcLoc)
frame,
Maybe SomeTracingSpanDetails
details :: Maybe SomeTracingSpanDetails
details :: Maybe SomeTracingSpanDetails
details,
Maybe Text
summary :: Maybe Text
summary :: Maybe Text
summary,
Succeeded
succeeded :: Succeeded
succeeded :: Succeeded
succeeded,
Int
allocated :: Int
allocated :: Int
allocated,
[TracingSpan]
children :: [TracingSpan]
children :: [TracingSpan]
children
}
)
newtype SrcLocForEncoding = SrcLocForEncoding {SrcLocForEncoding -> (Text, SrcLoc)
unSrcLocForEncoding :: (Text, Stack.SrcLoc)}
instance Aeson.ToJSON SrcLocForEncoding where
toJSON :: SrcLocForEncoding -> Value
toJSON (SrcLocForEncoding (Text
name, SrcLoc
loc)) =
[Pair] -> Value
Aeson.object
[ Text
"name" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
name,
Text
"package" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SrcLoc -> String
Stack.srcLocPackage SrcLoc
loc,
Text
"module" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SrcLoc -> String
Stack.srcLocModule SrcLoc
loc,
Text
"file" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SrcLoc -> String
Stack.srcLocFile SrcLoc
loc,
Text
"startLine" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SrcLoc -> Int
Stack.srcLocStartLine SrcLoc
loc,
Text
"startCol" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SrcLoc -> Int
Stack.srcLocStartCol SrcLoc
loc,
Text
"endLine" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SrcLoc -> Int
Stack.srcLocEndLine SrcLoc
loc,
Text
"endCol" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SrcLoc -> Int
Stack.srcLocEndCol SrcLoc
loc
]
toEncoding :: SrcLocForEncoding -> Encoding
toEncoding (SrcLocForEncoding (Text
name, SrcLoc
loc)) =
Series -> Encoding
Aeson.pairs
( Text
"name" Text -> Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
name
Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"package" Text -> String -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SrcLoc -> String
Stack.srcLocPackage SrcLoc
loc
Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"module" Text -> String -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SrcLoc -> String
Stack.srcLocModule SrcLoc
loc
Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"file" Text -> String -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SrcLoc -> String
Stack.srcLocFile SrcLoc
loc
Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"startLine" Text -> Int -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SrcLoc -> Int
Stack.srcLocStartLine SrcLoc
loc
Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"startCol" Text -> Int -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SrcLoc -> Int
Stack.srcLocStartCol SrcLoc
loc
Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"endLine" Text -> Int -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SrcLoc -> Int
Stack.srcLocEndLine SrcLoc
loc
Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"endCol" Text -> Int -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SrcLoc -> Int
Stack.srcLocEndCol SrcLoc
loc
)
instance Aeson.FromJSON SrcLocForEncoding where
parseJSON :: Value -> Parser SrcLocForEncoding
parseJSON =
String
-> (Object -> Parser SrcLocForEncoding)
-> Value
-> Parser SrcLocForEncoding
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject
String
"SrcLocForEncoding"
( \Object
object -> do
Text
name <- Object
object Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"name"
String
srcLocPackage <- Object
object Object -> Text -> Parser String
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"package"
String
srcLocModule <- Object
object Object -> Text -> Parser String
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"module"
String
srcLocFile <- Object
object Object -> Text -> Parser String
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"file"
Int
srcLocStartLine <- Object
object Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"startLine"
Int
srcLocStartCol <- Object
object Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"startCol"
Int
srcLocEndLine <- Object
object Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"endLine"
Int
srcLocEndCol <- Object
object Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"endCol"
SrcLocForEncoding -> Parser SrcLocForEncoding
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure
( (Text, SrcLoc) -> SrcLocForEncoding
SrcLocForEncoding
( Text
name,
SrcLoc :: String -> String -> String -> Int -> Int -> Int -> Int -> SrcLoc
Stack.SrcLoc
{ String
srcLocPackage :: String
srcLocPackage :: String
Stack.srcLocPackage,
String
srcLocModule :: String
srcLocModule :: String
Stack.srcLocModule,
String
srcLocFile :: String
srcLocFile :: String
Stack.srcLocFile,
Int
srcLocStartLine :: Int
srcLocStartLine :: Int
Stack.srcLocStartLine,
Int
srcLocStartCol :: Int
srcLocStartCol :: Int
Stack.srcLocStartCol,
Int
srcLocEndLine :: Int
srcLocEndLine :: Int
Stack.srcLocEndLine,
Int
srcLocEndCol :: Int
srcLocEndCol :: Int
Stack.srcLocEndCol
}
)
)
)
emptyTracingSpan :: TracingSpan
emptyTracingSpan :: TracingSpan
emptyTracingSpan =
TracingSpan :: Text
-> MonotonicTime
-> MonotonicTime
-> Maybe (Text, SrcLoc)
-> Maybe SomeTracingSpanDetails
-> Maybe Text
-> Succeeded
-> Int
-> [TracingSpan]
-> TracingSpan
TracingSpan
{ name :: Text
name = Text
"",
started :: MonotonicTime
started = MonotonicTime
0,
finished :: MonotonicTime
finished = MonotonicTime
0,
frame :: Maybe (Text, SrcLoc)
frame = Maybe (Text, SrcLoc)
forall a. Maybe a
Nothing,
details :: Maybe SomeTracingSpanDetails
details = Maybe SomeTracingSpanDetails
forall a. Maybe a
Nothing,
summary :: Maybe Text
summary = Maybe Text
forall a. Maybe a
Nothing,
succeeded :: Succeeded
succeeded = Succeeded
Succeeded,
allocated :: Int
allocated = Int
0,
children :: [TracingSpan]
children = []
}
data Succeeded
=
Succeeded
|
Failed
|
FailedWith Exception.SomeException
deriving (Int -> Succeeded -> ShowS
[Succeeded] -> ShowS
Succeeded -> String
(Int -> Succeeded -> ShowS)
-> (Succeeded -> String)
-> ([Succeeded] -> ShowS)
-> Show Succeeded
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Succeeded] -> ShowS
$cshowList :: [Succeeded] -> ShowS
show :: Succeeded -> String
$cshow :: Succeeded -> String
showsPrec :: Int -> Succeeded -> ShowS
$cshowsPrec :: Int -> Succeeded -> ShowS
Prelude.Show)
instance Aeson.ToJSON Succeeded where
toJSON :: Succeeded -> Value
toJSON Succeeded
Succeeded = Text -> Value
Aeson.String Text
"Succeeded"
toJSON Succeeded
Failed = Text -> Value
Aeson.String Text
"Failed"
toJSON (FailedWith SomeException
exception) =
SomeException -> String
forall e. Exception e => e -> String
Exception.displayException SomeException
exception
String -> (String -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> String -> Text
Data.Text.pack
Text -> (Text -> Value) -> Value
forall a b. a -> (a -> b) -> b
|> Text -> Value
Aeson.String
toEncoding :: Succeeded -> Encoding
toEncoding Succeeded
Succeeded = Text -> Encoding
forall a. Text -> Encoding' a
Aeson.Encoding.text Text
"Succeeded"
toEncoding Succeeded
Failed = Text -> Encoding
forall a. Text -> Encoding' a
Aeson.Encoding.text Text
"Failed"
toEncoding (FailedWith SomeException
exception) =
SomeException -> String
forall e. Exception e => e -> String
Exception.displayException SomeException
exception
String -> (String -> Encoding) -> Encoding
forall a b. a -> (a -> b) -> b
|> String -> Encoding
forall a. String -> Encoding' a
Aeson.Encoding.string
instance Aeson.FromJSON Succeeded where
parseJSON :: Value -> Parser Succeeded
parseJSON =
String -> (Text -> Parser Succeeded) -> Value -> Parser Succeeded
forall a. String -> (Text -> Parser a) -> Value -> Parser a
Aeson.withText
String
"Succeeded"
( \Text
text ->
case Text
text of
Text
"Succeeded" -> Succeeded -> Parser Succeeded
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure Succeeded
Succeeded
Text
"Failed" -> Succeeded -> Parser Succeeded
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure Succeeded
Failed
Text
_ ->
Text -> ParsedException
ParsedException Text
text
ParsedException
-> (ParsedException -> SomeException) -> SomeException
forall a b. a -> (a -> b) -> b
|> ParsedException -> SomeException
forall e. Exception e => e -> SomeException
Exception.toException
SomeException -> (SomeException -> Succeeded) -> Succeeded
forall a b. a -> (a -> b) -> b
|> SomeException -> Succeeded
FailedWith
Succeeded -> (Succeeded -> Parser Succeeded) -> Parser Succeeded
forall a b. a -> (a -> b) -> b
|> Succeeded -> Parser Succeeded
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure
)
newtype ParsedException = ParsedException Text
deriving ([ParsedException] -> Encoding
[ParsedException] -> Value
ParsedException -> Encoding
ParsedException -> Value
(ParsedException -> Value)
-> (ParsedException -> Encoding)
-> ([ParsedException] -> Value)
-> ([ParsedException] -> Encoding)
-> ToJSON ParsedException
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ParsedException] -> Encoding
$ctoEncodingList :: [ParsedException] -> Encoding
toJSONList :: [ParsedException] -> Value
$ctoJSONList :: [ParsedException] -> Value
toEncoding :: ParsedException -> Encoding
$ctoEncoding :: ParsedException -> Encoding
toJSON :: ParsedException -> Value
$ctoJSON :: ParsedException -> Value
Aeson.ToJSON)
instance Prelude.Show ParsedException where
show :: ParsedException -> String
show (ParsedException Text
text) = Text -> String
Data.Text.unpack Text
text
instance Exception.Exception ParsedException
instance Prelude.Semigroup Succeeded where
FailedWith SomeException
err <> :: Succeeded -> Succeeded -> Succeeded
<> Succeeded
_ = SomeException -> Succeeded
FailedWith SomeException
err
Succeeded
_ <> FailedWith SomeException
err = SomeException -> Succeeded
FailedWith SomeException
err
Succeeded
Failed <> Succeeded
_ = Succeeded
Failed
Succeeded
_ <> Succeeded
Failed = Succeeded
Failed
Succeeded
_ <> Succeeded
_ = Succeeded
Succeeded
instance Prelude.Monoid Succeeded where
mempty :: Succeeded
mempty = Succeeded
Succeeded
data SomeTracingSpanDetails where
SomeTracingSpanDetails :: (TracingSpanDetails a) => a -> SomeTracingSpanDetails
instance Aeson.ToJSON SomeTracingSpanDetails where
toJSON :: SomeTracingSpanDetails -> Value
toJSON (SomeTracingSpanDetails a
details) = a -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON a
details
toEncoding :: SomeTracingSpanDetails -> Encoding
toEncoding (SomeTracingSpanDetails a
details) = a -> Encoding
forall a. ToJSON a => a -> Encoding
Aeson.toEncoding a
details
instance Aeson.FromJSON SomeTracingSpanDetails where
parseJSON :: Value -> Parser SomeTracingSpanDetails
parseJSON Value
x =
Value -> Parser Value
forall a. FromJSON a => Value -> Parser a
Aeson.parseJSON Value
x
Parser Value
-> (Parser Value -> Parser SomeTracingSpanDetails)
-> Parser SomeTracingSpanDetails
forall a b. a -> (a -> b) -> b
|> (Value -> SomeTracingSpanDetails)
-> Parser Value -> Parser SomeTracingSpanDetails
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Prelude.fmap
(ParsedTracingSpandetails -> SomeTracingSpanDetails
forall e. TracingSpanDetails e => e -> SomeTracingSpanDetails
toTracingSpanDetails (ParsedTracingSpandetails -> SomeTracingSpanDetails)
-> (Value -> ParsedTracingSpandetails)
-> Value
-> SomeTracingSpanDetails
forall b c a. (b -> c) -> (a -> b) -> a -> c
<< Value -> ParsedTracingSpandetails
ParsedTracingSpandetails)
instance TracingSpanDetails SomeTracingSpanDetails where
toTracingSpanDetails :: SomeTracingSpanDetails -> SomeTracingSpanDetails
toTracingSpanDetails SomeTracingSpanDetails
details = SomeTracingSpanDetails
details
fromTracingSpanDetails :: SomeTracingSpanDetails -> Maybe SomeTracingSpanDetails
fromTracingSpanDetails = SomeTracingSpanDetails -> Maybe SomeTracingSpanDetails
forall a. a -> Maybe a
Just
instance Prelude.Show SomeTracingSpanDetails where
show :: SomeTracingSpanDetails -> String
show (SomeTracingSpanDetails a
details) =
a -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode a
details
ByteString -> (ByteString -> String) -> String
forall a b. a -> (a -> b) -> b
|> ByteString -> String
forall a. Show a => a -> String
Prelude.show
newtype ParsedTracingSpandetails = ParsedTracingSpandetails Aeson.Value
deriving ([ParsedTracingSpandetails] -> Encoding
[ParsedTracingSpandetails] -> Value
ParsedTracingSpandetails -> Encoding
ParsedTracingSpandetails -> Value
(ParsedTracingSpandetails -> Value)
-> (ParsedTracingSpandetails -> Encoding)
-> ([ParsedTracingSpandetails] -> Value)
-> ([ParsedTracingSpandetails] -> Encoding)
-> ToJSON ParsedTracingSpandetails
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ParsedTracingSpandetails] -> Encoding
$ctoEncodingList :: [ParsedTracingSpandetails] -> Encoding
toJSONList :: [ParsedTracingSpandetails] -> Value
$ctoJSONList :: [ParsedTracingSpandetails] -> Value
toEncoding :: ParsedTracingSpandetails -> Encoding
$ctoEncoding :: ParsedTracingSpandetails -> Encoding
toJSON :: ParsedTracingSpandetails -> Value
$ctoJSON :: ParsedTracingSpandetails -> Value
Aeson.ToJSON)
instance TracingSpanDetails ParsedTracingSpandetails
class (Typeable.Typeable e, Aeson.ToJSON e) => TracingSpanDetails e where
toTracingSpanDetails :: e -> SomeTracingSpanDetails
toTracingSpanDetails = e -> SomeTracingSpanDetails
forall e. TracingSpanDetails e => e -> SomeTracingSpanDetails
SomeTracingSpanDetails
fromTracingSpanDetails :: SomeTracingSpanDetails -> Maybe e
fromTracingSpanDetails (SomeTracingSpanDetails a
d) = a -> Maybe e
forall a b. (Typeable a, Typeable b) => a -> Maybe b
Typeable.cast a
d
data Renderer a where
Renderer :: TracingSpanDetails s => (s -> a) -> Renderer a
renderTracingSpanDetails :: [Renderer a] -> SomeTracingSpanDetails -> Maybe a
renderTracingSpanDetails :: [Renderer a] -> SomeTracingSpanDetails -> Maybe a
renderTracingSpanDetails [Renderer a]
rs SomeTracingSpanDetails
s =
case [Renderer a]
rs of
[] -> Maybe a
forall a. Maybe a
Nothing
(Renderer s -> a
r) : [Renderer a]
rest -> (s -> a) -> Maybe s -> Maybe a
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
Shortcut.map s -> a
r (SomeTracingSpanDetails -> Maybe s
forall e. TracingSpanDetails e => SomeTracingSpanDetails -> Maybe e
fromTracingSpanDetails SomeTracingSpanDetails
s) Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Renderer a] -> SomeTracingSpanDetails -> Maybe a
forall a. [Renderer a] -> SomeTracingSpanDetails -> Maybe a
renderTracingSpanDetails [Renderer a]
rest SomeTracingSpanDetails
s
data LogHandler = LogHandler
{
LogHandler -> Text
requestId :: Text,
LogHandler -> HasCallStack => Text -> IO LogHandler
startChildTracingSpan :: Stack.HasCallStack => Text -> IO LogHandler,
LogHandler -> forall d. TracingSpanDetails d => d -> IO ()
setTracingSpanDetailsIO :: forall d. TracingSpanDetails d => d -> IO (),
LogHandler -> Text -> IO ()
setTracingSpanSummaryIO :: Text -> IO (),
LogHandler -> IO ()
markTracingSpanFailedIO :: IO (),
LogHandler -> Maybe SomeException -> IO ()
finishTracingSpan :: Maybe Exception.SomeException -> IO ()
}
mkHandler ::
Stack.HasCallStack =>
Text ->
Clock ->
(TracingSpan -> IO ()) ->
Text ->
IO LogHandler
mkHandler :: Text -> Clock -> (TracingSpan -> IO ()) -> Text -> IO LogHandler
mkHandler Text
requestId Clock
clock TracingSpan -> IO ()
onFinish Text
name' = do
IORef TracingSpan
tracingSpanRef <-
(HasCallStack => Clock -> Text -> IO TracingSpan)
-> Clock -> Text -> IO TracingSpan
forall a. HasCallStack => (HasCallStack => a) -> a
Stack.withFrozenCallStack HasCallStack => Clock -> Text -> IO TracingSpan
startTracingSpan Clock
clock Text
name'
IO TracingSpan
-> (IO TracingSpan -> IO (IORef TracingSpan))
-> IO (IORef TracingSpan)
forall a b. a -> (a -> b) -> b
|> (TracingSpan -> IO (IORef TracingSpan))
-> IO TracingSpan -> IO (IORef TracingSpan)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
andThen TracingSpan -> IO (IORef TracingSpan)
forall a. a -> IO (IORef a)
IORef.newIORef
Int
allocationCounterStartVal <- IO Int
System.Mem.getAllocationCounter
LogHandler -> IO LogHandler
forall (f :: * -> *) a. Applicative f => a -> f a
pure
LogHandler :: Text
-> (HasCallStack => Text -> IO LogHandler)
-> (forall d. TracingSpanDetails d => d -> IO ())
-> (Text -> IO ())
-> IO ()
-> (Maybe SomeException -> IO ())
-> LogHandler
LogHandler
{ Text
requestId :: Text
requestId :: Text
requestId,
startChildTracingSpan :: HasCallStack => Text -> IO LogHandler
startChildTracingSpan = HasCallStack =>
Text -> Clock -> (TracingSpan -> IO ()) -> Text -> IO LogHandler
Text -> Clock -> (TracingSpan -> IO ()) -> Text -> IO LogHandler
mkHandler Text
requestId Clock
clock (IORef TracingSpan -> TracingSpan -> IO ()
appendTracingSpanToParent IORef TracingSpan
tracingSpanRef),
setTracingSpanDetailsIO :: forall d. TracingSpanDetails d => d -> IO ()
setTracingSpanDetailsIO = \d
details' ->
IORef TracingSpan -> (TracingSpan -> TracingSpan) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
updateIORef
IORef TracingSpan
tracingSpanRef
(\TracingSpan
tracingSpan' -> TracingSpan
tracingSpan' {details :: Maybe SomeTracingSpanDetails
details = SomeTracingSpanDetails -> Maybe SomeTracingSpanDetails
forall a. a -> Maybe a
Just (d -> SomeTracingSpanDetails
forall e. TracingSpanDetails e => e -> SomeTracingSpanDetails
toTracingSpanDetails d
details')}),
setTracingSpanSummaryIO :: Text -> IO ()
setTracingSpanSummaryIO = \Text
text ->
IORef TracingSpan -> (TracingSpan -> TracingSpan) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
updateIORef
IORef TracingSpan
tracingSpanRef
(\TracingSpan
tracingSpan' -> TracingSpan
tracingSpan' {summary :: Maybe Text
summary = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
text}),
markTracingSpanFailedIO :: IO ()
markTracingSpanFailedIO =
IORef TracingSpan -> (TracingSpan -> TracingSpan) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
updateIORef
IORef TracingSpan
tracingSpanRef
(\TracingSpan
tracingSpan' -> TracingSpan
tracingSpan' {succeeded :: Succeeded
succeeded = TracingSpan -> Succeeded
succeeded TracingSpan
tracingSpan' Succeeded -> Succeeded -> Succeeded
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Succeeded
Failed}),
finishTracingSpan :: Maybe SomeException -> IO ()
finishTracingSpan = Clock
-> Int
-> IORef TracingSpan
-> Maybe SomeException
-> IO TracingSpan
finalizeTracingSpan Clock
clock Int
allocationCounterStartVal IORef TracingSpan
tracingSpanRef (Maybe SomeException -> IO TracingSpan)
-> (IO TracingSpan -> IO ()) -> Maybe SomeException -> IO ()
forall a b c. (a -> b) -> (b -> c) -> a -> c
>> (TracingSpan -> IO ()) -> IO TracingSpan -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
andThen TracingSpan -> IO ()
onFinish
}
setTracingSpanDetails :: TracingSpanDetails d => d -> Task e ()
setTracingSpanDetails :: d -> Task e ()
setTracingSpanDetails d
details =
(LogHandler -> IO (Result e ())) -> Task e ()
forall x a. (LogHandler -> IO (Result x a)) -> Task x a
Task
( \LogHandler
handler ->
LogHandler -> d -> IO ()
LogHandler -> forall d. TracingSpanDetails d => d -> IO ()
setTracingSpanDetailsIO LogHandler
handler d
details
IO () -> (IO () -> IO (Result e ())) -> IO (Result e ())
forall a b. a -> (a -> b) -> b
|> (() -> Result e ()) -> IO () -> IO (Result e ())
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map () -> Result e ()
forall error value. value -> Result error value
Ok
)
setTracingSpanSummary :: Text -> Task e ()
setTracingSpanSummary :: Text -> Task e ()
setTracingSpanSummary Text
text =
(LogHandler -> IO (Result e ())) -> Task e ()
forall x a. (LogHandler -> IO (Result x a)) -> Task x a
Task
( \LogHandler
handler ->
LogHandler -> Text -> IO ()
setTracingSpanSummaryIO LogHandler
handler Text
text
IO () -> (IO () -> IO (Result e ())) -> IO (Result e ())
forall a b. a -> (a -> b) -> b
|> (() -> Result e ()) -> IO () -> IO (Result e ())
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map () -> Result e ()
forall error value. value -> Result error value
Ok
)
markTracingSpanFailed :: Task e ()
markTracingSpanFailed :: Task e ()
markTracingSpanFailed =
(LogHandler -> IO (Result e ())) -> Task e ()
forall x a. (LogHandler -> IO (Result x a)) -> Task x a
Task ((() -> Result e ()) -> IO () -> IO (Result e ())
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map () -> Result e ()
forall error value. value -> Result error value
Ok (IO () -> IO (Result e ()))
-> (LogHandler -> IO ()) -> LogHandler -> IO (Result e ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
<< LogHandler -> IO ()
markTracingSpanFailedIO)
startTracingSpan :: Stack.HasCallStack => Clock -> Text -> IO TracingSpan
startTracingSpan :: Clock -> Text -> IO TracingSpan
startTracingSpan Clock
clock Text
name = do
MonotonicTime
started <- Clock -> IO MonotonicTime
monotonicTimeInMsec Clock
clock
TracingSpan -> IO TracingSpan
forall (f :: * -> *) a. Applicative f => a -> f a
pure
TracingSpan :: Text
-> MonotonicTime
-> MonotonicTime
-> Maybe (Text, SrcLoc)
-> Maybe SomeTracingSpanDetails
-> Maybe Text
-> Succeeded
-> Int
-> [TracingSpan]
-> TracingSpan
TracingSpan
{ Text
name :: Text
name :: Text
name,
MonotonicTime
started :: MonotonicTime
started :: MonotonicTime
started,
finished :: MonotonicTime
finished = MonotonicTime
started,
frame :: Maybe (Text, SrcLoc)
frame =
CallStack
HasCallStack => CallStack
Stack.callStack
CallStack
-> (CallStack -> [(String, SrcLoc)]) -> [(String, SrcLoc)]
forall a b. a -> (a -> b) -> b
|> CallStack -> [(String, SrcLoc)]
Stack.getCallStack
[(String, SrcLoc)]
-> ([(String, SrcLoc)] -> Maybe (String, SrcLoc))
-> Maybe (String, SrcLoc)
forall a b. a -> (a -> b) -> b
|> [(String, SrcLoc)] -> Maybe (String, SrcLoc)
forall a. List a -> Maybe a
List.head
Maybe (String, SrcLoc)
-> (Maybe (String, SrcLoc) -> Maybe (Text, SrcLoc))
-> Maybe (Text, SrcLoc)
forall a b. a -> (a -> b) -> b
|> ((String, SrcLoc) -> (Text, SrcLoc))
-> Maybe (String, SrcLoc) -> Maybe (Text, SrcLoc)
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
Shortcut.map ((String -> Text) -> (String, SrcLoc) -> (Text, SrcLoc)
forall a x b. (a -> x) -> (a, b) -> (x, b)
Tuple.mapFirst String -> Text
Data.Text.pack),
details :: Maybe SomeTracingSpanDetails
details = Maybe SomeTracingSpanDetails
forall a. Maybe a
Nothing,
summary :: Maybe Text
summary = Maybe Text
forall a. Maybe a
Nothing,
succeeded :: Succeeded
succeeded = Succeeded
Succeeded,
allocated :: Int
allocated = Int
0,
children :: [TracingSpan]
children = []
}
finalizeTracingSpan :: Clock -> Int -> IORef.IORef TracingSpan -> Maybe Exception.SomeException -> IO TracingSpan
finalizeTracingSpan :: Clock
-> Int
-> IORef TracingSpan
-> Maybe SomeException
-> IO TracingSpan
finalizeTracingSpan Clock
clock Int
allocationCounterStartVal IORef TracingSpan
tracingSpanRef Maybe SomeException
maybeException = do
MonotonicTime
finished <- Clock -> IO MonotonicTime
monotonicTimeInMsec Clock
clock
Int
allocationCounterEndVal <- IO Int
System.Mem.getAllocationCounter
TracingSpan
tracingSpan' <- IORef TracingSpan -> IO TracingSpan
forall a. IORef a -> IO a
IORef.readIORef IORef TracingSpan
tracingSpanRef
TracingSpan -> IO TracingSpan
forall (f :: * -> *) a. Applicative f => a -> f a
pure
TracingSpan
tracingSpan'
{ MonotonicTime
finished :: MonotonicTime
finished :: MonotonicTime
finished,
succeeded :: Succeeded
succeeded =
TracingSpan -> Succeeded
succeeded TracingSpan
tracingSpan'
Succeeded -> Succeeded -> Succeeded
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ case Maybe SomeException
maybeException of
Just SomeException
exception -> SomeException -> Succeeded
FailedWith SomeException
exception
Maybe SomeException
Nothing ->
(TracingSpan -> Succeeded) -> [TracingSpan] -> [Succeeded]
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map TracingSpan -> Succeeded
Platform.Internal.succeeded (TracingSpan -> [TracingSpan]
children TracingSpan
tracingSpan')
[Succeeded] -> ([Succeeded] -> Succeeded) -> Succeeded
forall a b. a -> (a -> b) -> b
|> [Succeeded] -> Succeeded
forall a. Monoid a => [a] -> a
Prelude.mconcat,
allocated :: Int
allocated = Int
allocationCounterStartVal Int -> Int -> Int
forall number. Num number => number -> number -> number
- Int
allocationCounterEndVal
}
appendTracingSpanToParent :: IORef.IORef TracingSpan -> TracingSpan -> IO ()
appendTracingSpanToParent :: IORef TracingSpan -> TracingSpan -> IO ()
appendTracingSpanToParent IORef TracingSpan
parentRef TracingSpan
child =
IORef TracingSpan -> (TracingSpan -> TracingSpan) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
updateIORef IORef TracingSpan
parentRef ((TracingSpan -> TracingSpan) -> IO ())
-> (TracingSpan -> TracingSpan) -> IO ()
forall a b. (a -> b) -> a -> b
<| \TracingSpan
parentTracingSpan ->
TracingSpan
parentTracingSpan {children :: [TracingSpan]
children = TracingSpan
child TracingSpan -> [TracingSpan] -> [TracingSpan]
forall a. a -> [a] -> [a]
: TracingSpan -> [TracingSpan]
children TracingSpan
parentTracingSpan}
updateIORef :: IORef.IORef a -> (a -> a) -> IO ()
updateIORef :: IORef a -> (a -> a) -> IO ()
updateIORef IORef a
ref a -> a
f = IORef a -> (a -> (a, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef a
ref (\a
x -> (a -> a
f a
x, ()))
tracingSpan :: Stack.HasCallStack => Text -> Task e a -> Task e a
tracingSpan :: Text -> Task e a -> Task e a
tracingSpan Text
name (Task LogHandler -> IO (Result e a)
run) =
(LogHandler -> IO (Result e a)) -> Task e a
forall x a. (LogHandler -> IO (Result x a)) -> Task x a
Task
( \LogHandler
handler ->
(HasCallStack =>
LogHandler
-> Text -> (LogHandler -> IO (Result e a)) -> IO (Result e a))
-> LogHandler
-> Text
-> (LogHandler -> IO (Result e a))
-> IO (Result e a)
forall a. HasCallStack => (HasCallStack => a) -> a
Stack.withFrozenCallStack
HasCallStack =>
LogHandler
-> Text -> (LogHandler -> IO (Result e a)) -> IO (Result e a)
forall a.
HasCallStack =>
LogHandler -> Text -> (LogHandler -> IO a) -> IO a
tracingSpanIO
LogHandler
handler
Text
name
LogHandler -> IO (Result e a)
run
)
tracingSpanIO :: Stack.HasCallStack => LogHandler -> Text -> (LogHandler -> IO a) -> IO a
tracingSpanIO :: LogHandler -> Text -> (LogHandler -> IO a) -> IO a
tracingSpanIO LogHandler
handler Text
name LogHandler -> IO a
run =
IO LogHandler
-> (Maybe SomeException -> LogHandler -> IO ())
-> (LogHandler -> IO a)
-> IO a
forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (Maybe SomeException -> a -> m b) -> (a -> m c) -> m c
Exception.bracketWithError
((HasCallStack => LogHandler -> Text -> IO LogHandler)
-> LogHandler -> Text -> IO LogHandler
forall a. HasCallStack => (HasCallStack => a) -> a
Stack.withFrozenCallStack HasCallStack => LogHandler -> Text -> IO LogHandler
LogHandler -> HasCallStack => Text -> IO LogHandler
startChildTracingSpan LogHandler
handler Text
name)
((LogHandler -> Maybe SomeException -> IO ())
-> Maybe SomeException -> LogHandler -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
Prelude.flip LogHandler -> Maybe SomeException -> IO ()
finishTracingSpan)
LogHandler -> IO a
run
rootTracingSpanIO :: Stack.HasCallStack => Text -> (TracingSpan -> IO ()) -> Text -> (LogHandler -> IO a) -> IO a
rootTracingSpanIO :: Text
-> (TracingSpan -> IO ()) -> Text -> (LogHandler -> IO a) -> IO a
rootTracingSpanIO Text
requestId TracingSpan -> IO ()
onFinish Text
name LogHandler -> IO a
runIO = do
Clock
clock' <- IO Clock
mkClock
IO LogHandler
-> (Maybe SomeException -> LogHandler -> IO ())
-> (LogHandler -> IO a)
-> IO a
forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (Maybe SomeException -> a -> m b) -> (a -> m c) -> m c
Exception.bracketWithError
((HasCallStack =>
Text -> Clock -> (TracingSpan -> IO ()) -> Text -> IO LogHandler)
-> Text -> Clock -> (TracingSpan -> IO ()) -> Text -> IO LogHandler
forall a. HasCallStack => (HasCallStack => a) -> a
Stack.withFrozenCallStack HasCallStack =>
Text -> Clock -> (TracingSpan -> IO ()) -> Text -> IO LogHandler
mkHandler Text
requestId Clock
clock' (TracingSpan -> IO ()
onFinish (TracingSpan -> IO ()) -> (IO () -> IO ()) -> TracingSpan -> IO ()
forall a b c. (a -> b) -> (b -> c) -> a -> c
>> IO () -> IO ()
reportSafely) Text
name)
((LogHandler -> Maybe SomeException -> IO ())
-> Maybe SomeException -> LogHandler -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
Prelude.flip LogHandler -> Maybe SomeException -> IO ()
finishTracingSpan)
LogHandler -> IO a
runIO
reportSafely :: IO () -> IO ()
reportSafely :: IO () -> IO ()
reportSafely IO ()
report = do
Async (Maybe ())
_ <-
IO (Maybe ()) -> IO (Async (Maybe ()))
forall a. IO a -> IO (Async a)
Async.async (IO (Maybe ()) -> IO (Async (Maybe ())))
-> IO (Maybe ()) -> IO (Async (Maybe ()))
forall a b. (a -> b) -> a -> b
<| do
Int -> IO ()
Mem.setAllocationCounter Int
reportingAllocationLimitInBytes
IO ()
Mem.enableAllocationLimit
Int -> IO () -> IO (Maybe ())
forall a. Int -> IO a -> IO (Maybe a)
Timeout.timeout Int
reportingTimeoutInMicroSeconds IO ()
report
() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure ()
reportingAllocationLimitInBytes :: Int
reportingAllocationLimitInBytes :: Int
reportingAllocationLimitInBytes = Int
1024 Int -> Int -> Int
forall number. Num number => number -> number -> number
* Int
1024 Int -> Int -> Int
forall number. Num number => number -> number -> number
* Int
1024
reportingTimeoutInMicroSeconds :: Prelude.Int
reportingTimeoutInMicroSeconds :: Int
reportingTimeoutInMicroSeconds = Int
5_000_000
newtype Clock = Clock {Clock -> IO MonotonicTime
monotonicTimeInMsec :: IO MonotonicTime}
mkClock :: IO Clock
mkClock :: IO Clock
mkClock =
UpdateSettings MonotonicTime -> IO (IO MonotonicTime)
forall a. UpdateSettings a -> IO (IO a)
AutoUpdate.mkAutoUpdate
UpdateSettings ()
AutoUpdate.defaultUpdateSettings
{ updateAction :: IO MonotonicTime
AutoUpdate.updateAction =
IO Word64
Clock.getMonotonicTimeNSec
IO Word64 -> (IO Word64 -> IO MonotonicTime) -> IO MonotonicTime
forall a b. a -> (a -> b) -> b
|> (Word64 -> MonotonicTime) -> IO Word64 -> IO MonotonicTime
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map (\Word64
n -> Word64 -> MonotonicTime
MonotonicTime (Word64
n Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`Prelude.div` Word64
1000)),
updateFreq :: Int
AutoUpdate.updateFreq = Int
100
}
IO (IO MonotonicTime)
-> (IO (IO MonotonicTime) -> IO Clock) -> IO Clock
forall a b. a -> (a -> b) -> b
|> (IO MonotonicTime -> Clock) -> IO (IO MonotonicTime) -> IO Clock
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map IO MonotonicTime -> Clock
Clock
newtype MonotonicTime = MonotonicTime
{
MonotonicTime -> Word64
inMicroseconds :: GHC.Word.Word64
}
deriving (Int -> MonotonicTime -> ShowS
[MonotonicTime] -> ShowS
MonotonicTime -> String
(Int -> MonotonicTime -> ShowS)
-> (MonotonicTime -> String)
-> ([MonotonicTime] -> ShowS)
-> Show MonotonicTime
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MonotonicTime] -> ShowS
$cshowList :: [MonotonicTime] -> ShowS
show :: MonotonicTime -> String
$cshow :: MonotonicTime -> String
showsPrec :: Int -> MonotonicTime -> ShowS
$cshowsPrec :: Int -> MonotonicTime -> ShowS
Prelude.Show, Integer -> MonotonicTime
MonotonicTime -> MonotonicTime
MonotonicTime -> MonotonicTime -> MonotonicTime
(MonotonicTime -> MonotonicTime -> MonotonicTime)
-> (MonotonicTime -> MonotonicTime -> MonotonicTime)
-> (MonotonicTime -> MonotonicTime -> MonotonicTime)
-> (MonotonicTime -> MonotonicTime)
-> (MonotonicTime -> MonotonicTime)
-> (MonotonicTime -> MonotonicTime)
-> (Integer -> MonotonicTime)
-> Num MonotonicTime
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> MonotonicTime
$cfromInteger :: Integer -> MonotonicTime
signum :: MonotonicTime -> MonotonicTime
$csignum :: MonotonicTime -> MonotonicTime
abs :: MonotonicTime -> MonotonicTime
$cabs :: MonotonicTime -> MonotonicTime
negate :: MonotonicTime -> MonotonicTime
$cnegate :: MonotonicTime -> MonotonicTime
* :: MonotonicTime -> MonotonicTime -> MonotonicTime
$c* :: MonotonicTime -> MonotonicTime -> MonotonicTime
- :: MonotonicTime -> MonotonicTime -> MonotonicTime
$c- :: MonotonicTime -> MonotonicTime -> MonotonicTime
+ :: MonotonicTime -> MonotonicTime -> MonotonicTime
$c+ :: MonotonicTime -> MonotonicTime -> MonotonicTime
Prelude.Num, MonotonicTime -> MonotonicTime -> Bool
(MonotonicTime -> MonotonicTime -> Bool)
-> (MonotonicTime -> MonotonicTime -> Bool) -> Eq MonotonicTime
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MonotonicTime -> MonotonicTime -> Bool
$c/= :: MonotonicTime -> MonotonicTime -> Bool
== :: MonotonicTime -> MonotonicTime -> Bool
$c== :: MonotonicTime -> MonotonicTime -> Bool
Prelude.Eq, Eq MonotonicTime
Eq MonotonicTime
-> (MonotonicTime -> MonotonicTime -> Ordering)
-> (MonotonicTime -> MonotonicTime -> Bool)
-> (MonotonicTime -> MonotonicTime -> Bool)
-> (MonotonicTime -> MonotonicTime -> Bool)
-> (MonotonicTime -> MonotonicTime -> Bool)
-> (MonotonicTime -> MonotonicTime -> MonotonicTime)
-> (MonotonicTime -> MonotonicTime -> MonotonicTime)
-> Ord MonotonicTime
MonotonicTime -> MonotonicTime -> Bool
MonotonicTime -> MonotonicTime -> Ordering
MonotonicTime -> MonotonicTime -> MonotonicTime
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: MonotonicTime -> MonotonicTime -> MonotonicTime
$cmin :: MonotonicTime -> MonotonicTime -> MonotonicTime
max :: MonotonicTime -> MonotonicTime -> MonotonicTime
$cmax :: MonotonicTime -> MonotonicTime -> MonotonicTime
>= :: MonotonicTime -> MonotonicTime -> Bool
$c>= :: MonotonicTime -> MonotonicTime -> Bool
> :: MonotonicTime -> MonotonicTime -> Bool
$c> :: MonotonicTime -> MonotonicTime -> Bool
<= :: MonotonicTime -> MonotonicTime -> Bool
$c<= :: MonotonicTime -> MonotonicTime -> Bool
< :: MonotonicTime -> MonotonicTime -> Bool
$c< :: MonotonicTime -> MonotonicTime -> Bool
compare :: MonotonicTime -> MonotonicTime -> Ordering
$ccompare :: MonotonicTime -> MonotonicTime -> Ordering
$cp1Ord :: Eq MonotonicTime
Prelude.Ord, [MonotonicTime] -> Encoding
[MonotonicTime] -> Value
MonotonicTime -> Encoding
MonotonicTime -> Value
(MonotonicTime -> Value)
-> (MonotonicTime -> Encoding)
-> ([MonotonicTime] -> Value)
-> ([MonotonicTime] -> Encoding)
-> ToJSON MonotonicTime
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [MonotonicTime] -> Encoding
$ctoEncodingList :: [MonotonicTime] -> Encoding
toJSONList :: [MonotonicTime] -> Value
$ctoJSONList :: [MonotonicTime] -> Value
toEncoding :: MonotonicTime -> Encoding
$ctoEncoding :: MonotonicTime -> Encoding
toJSON :: MonotonicTime -> Value
$ctoJSON :: MonotonicTime -> Value
Aeson.ToJSON, Value -> Parser [MonotonicTime]
Value -> Parser MonotonicTime
(Value -> Parser MonotonicTime)
-> (Value -> Parser [MonotonicTime]) -> FromJSON MonotonicTime
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [MonotonicTime]
$cparseJSONList :: Value -> Parser [MonotonicTime]
parseJSON :: Value -> Parser MonotonicTime
$cparseJSON :: Value -> Parser MonotonicTime
Aeson.FromJSON)