{-# LANGUAGE NoApplicativeDo #-}
{-# LANGUAGE CPP #-}
#include "ghc-api-version.h"
module Development.IDE.Core.Tracing
    ( otTracedHandler
    , otTracedAction
    , startTelemetry
    , measureMemory
    , getInstrumentCached
    , otTracedProvider
    , otSetUri
    )
where

import           Control.Concurrent.Async       (Async, async)
import           Control.Concurrent.Extra       (Var, modifyVar_, newVar,
                                                 readVar, threadDelay)
import           Control.Exception              (evaluate)
import           Control.Exception.Safe         (SomeException, catch)
import           Control.Monad                  (forM_, forever, unless, void,
                                                 when, (>=>))
import           Control.Monad.Extra            (whenJust)
import           Control.Monad.IO.Unlift
import           Control.Seq                    (r0, seqList, seqTuple2, using)
import           Data.ByteString                (ByteString)
import           Data.Dynamic                   (Dynamic)
import qualified Data.HashMap.Strict            as HMap
import           Data.IORef                     (modifyIORef', newIORef,
                                                 readIORef, writeIORef)
import           Data.String                    (IsString (fromString))
import           Data.Text.Encoding             (encodeUtf8)
import           Debug.Trace.Flags              (userTracingEnabled)
import           Development.IDE.Core.RuleTypes (GhcSession (GhcSession),
                                                 GhcSessionDeps (GhcSessionDeps),
                                                 GhcSessionIO (GhcSessionIO))
import           Development.IDE.Types.Location (Uri (..))
import           Development.IDE.Types.Logger   (Logger, logDebug, logInfo)
import           Development.IDE.Types.Shake    (Key (..), Value,
                                                 ValueWithDiagnostics (..),
                                                 Values)
import           Development.Shake              (Action, actionBracket)
import           Foreign.Storable               (Storable (sizeOf))
import           HeapSize                       (recursiveSize, runHeapsize)
import           Ide.PluginUtils                (installSigUsr1Handler)
import           Ide.Types                      (PluginId (..))
import           Language.LSP.Types             (NormalizedFilePath,
                                                 fromNormalizedFilePath)
import           Numeric.Natural                (Natural)
import           OpenTelemetry.Eventlog         (Instrument, SpanInFlight (..),
                                                 Synchronicity (Asynchronous),
                                                 addEvent, beginSpan, endSpan,
                                                 mkValueObserver, observe,
                                                 setTag, withSpan, withSpan_)

-- | Trace a handler using OpenTelemetry. Adds various useful info into tags in the OpenTelemetry span.
otTracedHandler
    :: MonadUnliftIO m
    => String -- ^ Message type
    -> String -- ^ Message label
    -> (SpanInFlight -> m a)
    -> m a
otTracedHandler :: String -> String -> (SpanInFlight -> m a) -> m a
otTracedHandler String
requestType String
label SpanInFlight -> m a
act
  | Bool
userTracingEnabled = do
    let !name :: String
name =
            if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
label
            then String
requestType
            else String
requestType String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
label
    -- Add an event so all requests can be quickly seen in the viewer without searching
    m a -> IO a
runInIO <- m (m a -> IO a)
forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
    IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ ByteString -> (SpanInFlight -> IO a) -> IO a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ByteString -> (SpanInFlight -> m a) -> m a
withSpan (String -> ByteString
forall a. IsString a => String -> a
fromString String
name) (\SpanInFlight
sp -> SpanInFlight -> ByteString -> ByteString -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
addEvent SpanInFlight
sp ByteString
"" (String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" received") IO () -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a -> IO a
runInIO (SpanInFlight -> m a
act SpanInFlight
sp))
  | Bool
otherwise = SpanInFlight -> m a
act (ProcessLocalSpanSerialNumber -> SpanInFlight
SpanInFlight ProcessLocalSpanSerialNumber
0)

otSetUri :: SpanInFlight -> Uri -> IO ()
otSetUri :: SpanInFlight -> Uri -> IO ()
otSetUri SpanInFlight
sp (Uri Text
t) = SpanInFlight -> ByteString -> ByteString -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"uri" (Text -> ByteString
encodeUtf8 Text
t)

-- | Trace a Shake action using opentelemetry.
otTracedAction
    :: Show k
    => k -- ^ The Action's Key
    -> NormalizedFilePath -- ^ Path to the file the action was run for
    -> (a -> Bool) -- ^ Did this action succeed?
    -> Action a -- ^ The action
    -> Action a
otTracedAction :: k -> NormalizedFilePath -> (a -> Bool) -> Action a -> Action a
otTracedAction k
key NormalizedFilePath
file a -> Bool
success Action a
act
  | Bool
userTracingEnabled =
    IO SpanInFlight
-> (SpanInFlight -> IO ())
-> (SpanInFlight -> Action a)
-> Action a
forall a b c. IO a -> (a -> IO b) -> (a -> Action c) -> Action c
actionBracket
        (do
            SpanInFlight
sp <- ByteString -> IO SpanInFlight
forall (m :: * -> *). MonadIO m => ByteString -> m SpanInFlight
beginSpan (String -> ByteString
forall a. IsString a => String -> a
fromString (k -> String
forall a. Show a => a -> String
show k
key))
            SpanInFlight -> ByteString -> ByteString -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"File" (String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
file)
            SpanInFlight -> IO SpanInFlight
forall (m :: * -> *) a. Monad m => a -> m a
return SpanInFlight
sp
        )
        SpanInFlight -> IO ()
forall (m :: * -> *). MonadIO m => SpanInFlight -> m ()
endSpan
        (\SpanInFlight
sp -> do
            a
res <- Action a
act
            Bool -> Action () -> Action ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (a -> Bool
success a
res) (Action () -> Action ()) -> Action () -> Action ()
forall a b. (a -> b) -> a -> b
$ SpanInFlight -> ByteString -> ByteString -> Action ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"error" ByteString
"1"
            a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res)
  | Bool
otherwise = Action a
act

#if MIN_GHC_API_VERSION(8,8,0)
otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a
#else
otTracedProvider :: MonadUnliftIO m => PluginId -> String -> m a -> m a
#endif
otTracedProvider :: PluginId -> ByteString -> m a -> m a
otTracedProvider (PluginId Text
pluginName) ByteString
provider m a
act
  | Bool
userTracingEnabled = do
    m a -> IO a
runInIO <- m (m a -> IO a)
forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
    IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ ByteString -> (SpanInFlight -> IO a) -> IO a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ByteString -> (SpanInFlight -> m a) -> m a
withSpan (ByteString
provider ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" provider") ((SpanInFlight -> IO a) -> IO a) -> (SpanInFlight -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \SpanInFlight
sp -> do
        SpanInFlight -> ByteString -> ByteString -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"plugin" (Text -> ByteString
encodeUtf8 Text
pluginName)
        m a -> IO a
runInIO m a
act
  | Bool
otherwise = m a
act

startTelemetry :: Bool -> Logger -> Var Values -> IO ()
startTelemetry :: Bool -> Logger -> Var Values -> IO ()
startTelemetry Bool
allTheTime Logger
logger Var Values
stateRef = do
    Maybe Key -> IO OurValueObserver
instrumentFor <- IO (Maybe Key -> IO OurValueObserver)
getInstrumentCached
    ValueObserver
mapCountInstrument <- ByteString -> IO ValueObserver
forall (m :: * -> *). MonadIO m => ByteString -> m ValueObserver
mkValueObserver ByteString
"values map count"

    IO () -> IO ()
installSigUsr1Handler (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Logger -> Text -> IO ()
logInfo Logger
logger Text
"SIGUSR1 received: performing memory measurement"
        Logger
-> Var Values
-> (Maybe Key -> IO OurValueObserver)
-> ValueObserver
-> IO ()
forall (a :: Additivity) (m' :: Monotonicity).
Logger
-> Var Values
-> (Maybe Key -> IO OurValueObserver)
-> Instrument 'Asynchronous a m'
-> IO ()
performMeasurement Logger
logger Var Values
stateRef Maybe Key -> IO OurValueObserver
instrumentFor ValueObserver
mapCountInstrument

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
allTheTime (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO (Async ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Async ()) -> IO ()) -> IO (Async ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO () -> IO (Async ())
regularly (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
seconds) (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$
        Logger
-> Var Values
-> (Maybe Key -> IO OurValueObserver)
-> ValueObserver
-> IO ()
forall (a :: Additivity) (m' :: Monotonicity).
Logger
-> Var Values
-> (Maybe Key -> IO OurValueObserver)
-> Instrument 'Asynchronous a m'
-> IO ()
performMeasurement Logger
logger Var Values
stateRef Maybe Key -> IO OurValueObserver
instrumentFor ValueObserver
mapCountInstrument
  where
        seconds :: Int
seconds = Int
1000000

        regularly :: Int -> IO () -> IO (Async ())
        regularly :: Int -> IO () -> IO (Async ())
regularly Int
delay IO ()
act = IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO ()
act IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> OurValueObserver
threadDelay Int
delay)


performMeasurement ::
  Logger ->
  Var Values ->
  (Maybe Key -> IO OurValueObserver) ->
  Instrument 'Asynchronous a m' ->
  IO ()
performMeasurement :: Logger
-> Var Values
-> (Maybe Key -> IO OurValueObserver)
-> Instrument 'Asynchronous a m'
-> IO ()
performMeasurement Logger
logger Var Values
stateRef Maybe Key -> IO OurValueObserver
instrumentFor Instrument 'Asynchronous a m'
mapCountInstrument = do
    ByteString -> IO () -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ByteString -> m a -> m a
withSpan_ ByteString
"Measure length" (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Var Values -> IO Values
forall a. Var a -> IO a
readVar Var Values
stateRef IO Values -> (Values -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Instrument 'Asynchronous a m' -> OurValueObserver
forall (m :: * -> *) (a :: Additivity) (m' :: Monotonicity).
MonadIO m =>
Instrument 'Asynchronous a m' -> Int -> m ()
observe Instrument 'Asynchronous a m'
mapCountInstrument OurValueObserver -> (Values -> Int) -> Values -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Values -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length

    Values
values <- Var Values -> IO Values
forall a. Var a -> IO a
readVar Var Values
stateRef
    let keys :: [Key]
keys = GhcSession -> Key
forall k. (Typeable k, Hashable k, Eq k, Show k) => k -> Key
Key GhcSession
GhcSession
             Key -> [Key] -> [Key]
forall a. a -> [a] -> [a]
: GhcSessionDeps -> Key
forall k. (Typeable k, Hashable k, Eq k, Show k) => k -> Key
Key GhcSessionDeps
GhcSessionDeps
             Key -> [Key] -> [Key]
forall a. a -> [a] -> [a]
: [ Key
k | (NormalizedFilePath
_,Key
k) <- Values -> [(NormalizedFilePath, Key)]
forall k v. HashMap k v -> [k]
HMap.keys Values
values
                        -- do GhcSessionIO last since it closes over stateRef itself
                        , Key
k Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
/= GhcSession -> Key
forall k. (Typeable k, Hashable k, Eq k, Show k) => k -> Key
Key GhcSession
GhcSession
                        , Key
k Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
/= GhcSessionDeps -> Key
forall k. (Typeable k, Hashable k, Eq k, Show k) => k -> Key
Key GhcSessionDeps
GhcSessionDeps
                        , Key
k Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
/= GhcSessionIO -> Key
forall k. (Typeable k, Hashable k, Eq k, Show k) => k -> Key
Key GhcSessionIO
GhcSessionIO
             ] [Key] -> [Key] -> [Key]
forall a. [a] -> [a] -> [a]
++ [GhcSessionIO -> Key
forall k. (Typeable k, Hashable k, Eq k, Show k) => k -> Key
Key GhcSessionIO
GhcSessionIO]
    [Key]
groupedForSharing <- [Key] -> IO [Key]
forall a. a -> IO a
evaluate ([Key]
keys [Key] -> Strategy [Key] -> [Key]
forall a. a -> Strategy a -> a
`using` Strategy Key -> Strategy [Key]
forall a. Strategy a -> Strategy [a]
seqList Strategy Key
forall a. Strategy a
r0)
    Logger
-> [[Key]]
-> (Maybe Key -> IO OurValueObserver)
-> Var Values
-> IO ()
measureMemory Logger
logger [[Key]
groupedForSharing] Maybe Key -> IO OurValueObserver
instrumentFor Var Values
stateRef
        IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(SomeException
e::SomeException) ->
        Logger -> Text -> IO ()
logInfo Logger
logger (Text
"MEMORY PROFILING ERROR: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. IsString a => String -> a
fromString (SomeException -> String
forall a. Show a => a -> String
show SomeException
e))


type OurValueObserver = Int -> IO ()

getInstrumentCached :: IO (Maybe Key -> IO OurValueObserver)
getInstrumentCached :: IO (Maybe Key -> IO OurValueObserver)
getInstrumentCached = do
    Var (HashMap Key ValueObserver)
instrumentMap <- HashMap Key ValueObserver -> IO (Var (HashMap Key ValueObserver))
forall a. a -> IO (Var a)
newVar HashMap Key ValueObserver
forall k v. HashMap k v
HMap.empty
    ValueObserver
mapBytesInstrument <- ByteString -> IO ValueObserver
forall (m :: * -> *). MonadIO m => ByteString -> m ValueObserver
mkValueObserver ByteString
"value map size_bytes"

    let instrumentFor :: Key -> IO (Int -> m ())
instrumentFor Key
k = do
          Maybe ValueObserver
mb_inst <- Key -> HashMap Key ValueObserver -> Maybe ValueObserver
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup Key
k (HashMap Key ValueObserver -> Maybe ValueObserver)
-> IO (HashMap Key ValueObserver) -> IO (Maybe ValueObserver)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Var (HashMap Key ValueObserver) -> IO (HashMap Key ValueObserver)
forall a. Var a -> IO a
readVar Var (HashMap Key ValueObserver)
instrumentMap
          case Maybe ValueObserver
mb_inst of
            Maybe ValueObserver
Nothing -> do
                ValueObserver
instrument <- ByteString -> IO ValueObserver
forall (m :: * -> *). MonadIO m => ByteString -> m ValueObserver
mkValueObserver (String -> ByteString
forall a. IsString a => String -> a
fromString (Key -> String
forall a. Show a => a -> String
show Key
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" size_bytes"))
                Var (HashMap Key ValueObserver)
-> (HashMap Key ValueObserver -> IO (HashMap Key ValueObserver))
-> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var (HashMap Key ValueObserver)
instrumentMap (HashMap Key ValueObserver -> IO (HashMap Key ValueObserver)
forall (m :: * -> *) a. Monad m => a -> m a
return (HashMap Key ValueObserver -> IO (HashMap Key ValueObserver))
-> (HashMap Key ValueObserver -> HashMap Key ValueObserver)
-> HashMap Key ValueObserver
-> IO (HashMap Key ValueObserver)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key
-> ValueObserver
-> HashMap Key ValueObserver
-> HashMap Key ValueObserver
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HMap.insert Key
k ValueObserver
instrument)
                (Int -> m ()) -> IO (Int -> m ())
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int -> m ()) -> IO (Int -> m ()))
-> (Int -> m ()) -> IO (Int -> m ())
forall a b. (a -> b) -> a -> b
$ ValueObserver -> Int -> m ()
forall (m :: * -> *) (a :: Additivity) (m' :: Monotonicity).
MonadIO m =>
Instrument 'Asynchronous a m' -> Int -> m ()
observe ValueObserver
instrument
            Just ValueObserver
v -> (Int -> m ()) -> IO (Int -> m ())
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int -> m ()) -> IO (Int -> m ()))
-> (Int -> m ()) -> IO (Int -> m ())
forall a b. (a -> b) -> a -> b
$ ValueObserver -> Int -> m ()
forall (m :: * -> *) (a :: Additivity) (m' :: Monotonicity).
MonadIO m =>
Instrument 'Asynchronous a m' -> Int -> m ()
observe ValueObserver
v
    (Maybe Key -> IO OurValueObserver)
-> IO (Maybe Key -> IO OurValueObserver)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe Key -> IO OurValueObserver)
 -> IO (Maybe Key -> IO OurValueObserver))
-> (Maybe Key -> IO OurValueObserver)
-> IO (Maybe Key -> IO OurValueObserver)
forall a b. (a -> b) -> a -> b
$ IO OurValueObserver
-> (Key -> IO OurValueObserver) -> Maybe Key -> IO OurValueObserver
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (OurValueObserver -> IO OurValueObserver
forall (m :: * -> *) a. Monad m => a -> m a
return (OurValueObserver -> IO OurValueObserver)
-> OurValueObserver -> IO OurValueObserver
forall a b. (a -> b) -> a -> b
$ ValueObserver -> OurValueObserver
forall (m :: * -> *) (a :: Additivity) (m' :: Monotonicity).
MonadIO m =>
Instrument 'Asynchronous a m' -> Int -> m ()
observe ValueObserver
mapBytesInstrument) Key -> IO OurValueObserver
forall (m :: * -> *). MonadIO m => Key -> IO (Int -> m ())
instrumentFor

whenNothing :: IO () -> IO (Maybe a) -> IO ()
whenNothing :: IO () -> IO (Maybe a) -> IO ()
whenNothing IO ()
act IO (Maybe a)
mb = IO (Maybe a)
mb IO (Maybe a) -> (Maybe a -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe a -> IO ()
forall a. Maybe a -> IO ()
f
  where f :: Maybe a -> IO ()
f Maybe a
Nothing = IO ()
act
        f Just{}  = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

measureMemory
    :: Logger
    -> [[Key]]     -- ^ Grouping of keys for the sharing-aware analysis
    -> (Maybe Key -> IO OurValueObserver)
    -> Var Values
    -> IO ()
measureMemory :: Logger
-> [[Key]]
-> (Maybe Key -> IO OurValueObserver)
-> Var Values
-> IO ()
measureMemory Logger
logger [[Key]]
groups Maybe Key -> IO OurValueObserver
instrumentFor Var Values
stateRef = ByteString -> IO () -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ByteString -> m a -> m a
withSpan_ ByteString
"Measure Memory" (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Values
values <- Var Values -> IO Values
forall a. Var a -> IO a
readVar Var Values
stateRef
    IORef (Maybe Int)
valuesSizeRef <- Maybe Int -> IO (IORef (Maybe Int))
forall a. a -> IO (IORef a)
newIORef (Maybe Int -> IO (IORef (Maybe Int)))
-> Maybe Int -> IO (IORef (Maybe Int))
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
    let !groupsOfGroupedValues :: [[(Key, [Value Dynamic])]]
groupsOfGroupedValues = Values -> [[(Key, [Value Dynamic])]]
groupValues Values
values
    Logger -> Text -> IO ()
logDebug Logger
logger Text
"STARTING MEMORY PROFILING"
    [[(Key, [Value Dynamic])]]
-> ([(Key, [Value Dynamic])] -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[(Key, [Value Dynamic])]]
groupsOfGroupedValues (([(Key, [Value Dynamic])] -> IO ()) -> IO ())
-> ([(Key, [Value Dynamic])] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[(Key, [Value Dynamic])]
groupedValues -> do
        Maybe Int
keepGoing <- IORef (Maybe Int) -> IO (Maybe Int)
forall a. IORef a -> IO a
readIORef IORef (Maybe Int)
valuesSizeRef
        Maybe Int -> OurValueObserver -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Int
keepGoing (OurValueObserver -> IO ()) -> OurValueObserver -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
_ ->
          IO () -> IO (Maybe ()) -> IO ()
forall a. IO () -> IO (Maybe a) -> IO ()
whenNothing (IORef (Maybe Int) -> Maybe Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Int)
valuesSizeRef Maybe Int
forall a. Maybe a
Nothing) (IO (Maybe ()) -> IO ()) -> IO (Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
          Natural -> IO (Maybe ()) -> IO (Maybe ())
forall (m :: * -> *) a.
Monad m =>
Natural -> m (Maybe a) -> m (Maybe a)
repeatUntilJust Natural
3 (IO (Maybe ()) -> IO (Maybe ())) -> IO (Maybe ()) -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
          -- logDebug logger (fromString $ show $ map fst groupedValues)
          Int -> Heapsize () -> IO (Maybe ())
forall a. Int -> Heapsize a -> IO (Maybe a)
runHeapsize Int
25000000 (Heapsize () -> IO (Maybe ())) -> Heapsize () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$
              [(Key, [Value Dynamic])]
-> ((Key, [Value Dynamic]) -> Heapsize ()) -> Heapsize ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Key, [Value Dynamic])]
groupedValues (((Key, [Value Dynamic]) -> Heapsize ()) -> Heapsize ())
-> ((Key, [Value Dynamic]) -> Heapsize ()) -> Heapsize ()
forall a b. (a -> b) -> a -> b
$ \(Key
k,[Value Dynamic]
v) -> ByteString -> (SpanInFlight -> Heapsize ()) -> Heapsize ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ByteString -> (SpanInFlight -> m a) -> m a
withSpan (ByteString
"Measure " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Key -> String
forall a. Show a => a -> String
show Key
k)) ((SpanInFlight -> Heapsize ()) -> Heapsize ())
-> (SpanInFlight -> Heapsize ()) -> Heapsize ()
forall a b. (a -> b) -> a -> b
$ \SpanInFlight
sp -> do
              IORef Int
acc <- IO (IORef Int) -> Heapsize (IORef Int)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Int) -> Heapsize (IORef Int))
-> IO (IORef Int) -> Heapsize (IORef Int)
forall a b. (a -> b) -> a -> b
$ Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0
              OurValueObserver
observe <- IO OurValueObserver -> Heapsize OurValueObserver
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO OurValueObserver -> Heapsize OurValueObserver)
-> IO OurValueObserver -> Heapsize OurValueObserver
forall a b. (a -> b) -> a -> b
$ Maybe Key -> IO OurValueObserver
instrumentFor (Maybe Key -> IO OurValueObserver)
-> Maybe Key -> IO OurValueObserver
forall a b. (a -> b) -> a -> b
$ Key -> Maybe Key
forall a. a -> Maybe a
Just Key
k
              (Value Dynamic -> Heapsize ()) -> [Value Dynamic] -> Heapsize ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Value Dynamic -> Heapsize Int
forall a. a -> Heapsize Int
recursiveSize (Value Dynamic -> Heapsize Int)
-> (Int -> Heapsize ()) -> Value Dynamic -> Heapsize ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \Int
x -> IO () -> Heapsize ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Int
acc (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x))) [Value Dynamic]
v
              Int
size <- IO Int -> Heapsize Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> Heapsize Int) -> IO Int -> Heapsize Int
forall a b. (a -> b) -> a -> b
$ IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
acc
              let !byteSize :: Int
byteSize = Word -> Int
forall a. Storable a => a -> Int
sizeOf (Word
forall a. HasCallStack => a
undefined :: Word) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
size
              SpanInFlight -> ByteString -> ByteString -> Heapsize ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"size" (String -> ByteString
forall a. IsString a => String -> a
fromString (Int -> String
forall a. Show a => a -> String
show Int
byteSize String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" bytes"))
              () <- IO () -> Heapsize ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Heapsize ()) -> IO () -> Heapsize ()
forall a b. (a -> b) -> a -> b
$ OurValueObserver
observe Int
byteSize
              IO () -> Heapsize ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Heapsize ()) -> IO () -> Heapsize ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe Int) -> (Maybe Int -> Maybe Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Maybe Int)
valuesSizeRef ((Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
byteSize))

    Maybe Int
mbValuesSize <- IORef (Maybe Int) -> IO (Maybe Int)
forall a. IORef a -> IO a
readIORef IORef (Maybe Int)
valuesSizeRef
    case Maybe Int
mbValuesSize of
        Just Int
valuesSize -> do
            OurValueObserver
observe <- Maybe Key -> IO OurValueObserver
instrumentFor Maybe Key
forall a. Maybe a
Nothing
            OurValueObserver
observe Int
valuesSize
            Logger -> Text -> IO ()
logDebug Logger
logger Text
"MEMORY PROFILING COMPLETED"
        Maybe Int
Nothing ->
            Logger -> Text -> IO ()
logInfo Logger
logger Text
"Memory profiling could not be completed: increase the size of your nursery (+RTS -Ax) and try again"

    where
        groupValues :: Values -> [ [(Key, [Value Dynamic])] ]
        groupValues :: Values -> [[(Key, [Value Dynamic])]]
groupValues Values
values =
            let !groupedValues :: [[(Key, [Value Dynamic])]]
groupedValues =
                    [ [ (Key
k, [Value Dynamic]
vv)
                      | Key
k <- [Key]
groupKeys
                      , let vv :: [Value Dynamic]
vv = [ Value Dynamic
v | ((NormalizedFilePath
_,Key
k'), ValueWithDiagnostics Value Dynamic
v Vector FileDiagnostic
_) <- Values -> [((NormalizedFilePath, Key), ValueWithDiagnostics)]
forall k v. HashMap k v -> [(k, v)]
HMap.toList Values
values , Key
k Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
k']
                      ]
                    | [Key]
groupKeys <- [[Key]]
groups
                    ]
                -- force the spine of the nested lists
            in [[(Key, [Value Dynamic])]]
groupedValues [[(Key, [Value Dynamic])]]
-> Strategy [[(Key, [Value Dynamic])]]
-> [[(Key, [Value Dynamic])]]
forall a. a -> Strategy a -> a
`using` Strategy [(Key, [Value Dynamic])]
-> Strategy [[(Key, [Value Dynamic])]]
forall a. Strategy a -> Strategy [a]
seqList (Strategy (Key, [Value Dynamic])
-> Strategy [(Key, [Value Dynamic])]
forall a. Strategy a -> Strategy [a]
seqList (Strategy Key
-> Strategy [Value Dynamic] -> Strategy (Key, [Value Dynamic])
forall a b. Strategy a -> Strategy b -> Strategy (a, b)
seqTuple2 Strategy Key
forall a. Strategy a
r0 (Strategy (Value Dynamic) -> Strategy [Value Dynamic]
forall a. Strategy a -> Strategy [a]
seqList Strategy (Value Dynamic)
forall a. Strategy a
r0)))

repeatUntilJust :: Monad m => Natural -> m (Maybe a) -> m (Maybe a)
repeatUntilJust :: Natural -> m (Maybe a) -> m (Maybe a)
repeatUntilJust Natural
0 m (Maybe a)
_ = Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
repeatUntilJust Natural
nattempts m (Maybe a)
action = do
    Maybe a
res <- m (Maybe a)
action
    case Maybe a
res of
        Maybe a
Nothing -> Natural -> m (Maybe a) -> m (Maybe a)
forall (m :: * -> *) a.
Monad m =>
Natural -> m (Maybe a) -> m (Maybe a)
repeatUntilJust (Natural
nattemptsNatural -> Natural -> Natural
forall a. Num a => a -> a -> a
-Natural
1) m (Maybe a)
action
        Just{}  -> Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
res