{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
module Platform.Internal where
import Basics
import Control.Applicative ((<|>))
import qualified Control.AutoUpdate as AutoUpdate
import qualified Control.Exception.Safe as Exception
import qualified Data.Aeson as Aeson
import qualified Data.IORef as IORef
import qualified Data.Text
import qualified Data.Typeable as Typeable
import qualified GHC.Clock as Clock
import qualified GHC.Stack as Stack
import qualified GHC.Word
import qualified Internal.Shortcut as Shortcut
import Internal.Shortcut (andThen, map)
import qualified List
import Maybe (Maybe (..))
import Result (Result (Err, Ok))
import qualified System.Mem
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 -> 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)
emptyTracingSpan :: TracingSpan
emptyTracingSpan :: TracingSpan
emptyTracingSpan =
TracingSpan :: Text
-> MonotonicTime
-> MonotonicTime
-> Maybe (Text, SrcLoc)
-> Maybe SomeTracingSpanDetails
-> 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,
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 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 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
class (Typeable.Typeable e, Aeson.ToJSON e) => TracingSpanDetails e where
toTracingSpanDetails :: e -> SomeTracingSpanDetails
toTracingSpanDetails = e -> SomeTracingSpanDetails
forall a. TracingSpanDetails a => a -> 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 -> 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 ())
-> 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 a. TracingSpanDetails a => a -> SomeTracingSpanDetails
toTracingSpanDetails d
details')}),
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
)
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
-> 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,
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 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
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)