update

Author: soulomoon

ghcide/ghcide.cabal

@@ -357,7 +357,6 @@ test-suite ghcide-tests
     ClientSettingsTests
     CodeLensTests
     CPPTests
-    CradleTests
     DependentFileTest
     DiagnosticTests
     ExceptionTests

ghcide/session-loader/Development/IDE/Session.hs

@@ -647,15 +647,17 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
            -- Display a user friendly progress message here: They probably don't know what a cradle is
            let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle))
                          <> " (for " <> T.pack lfp <> ")"
+           mRunLspT lspEnv $ sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/eopts/before")) (toJSON cfp)
            eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $
               withTrace "Load cradle" $ \addTag -> do
                   addTag "file" lfp
                   old_files <- readIORef cradle_files
                   res <- cradleToOptsAndLibDir recorder cradle cfp old_files
                   addTag "result" (show res)
                   return res
-
+           mRunLspT lspEnv $ sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/eopts/after")) (toJSON cfp)
            logWith recorder Debug $ LogSessionLoadingResult eopts
+           mRunLspT lspEnv $ sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/eopts/afterLog")) (toJSON (show $ pretty (LogSessionLoadingResult eopts)))
            case eopts of
              -- The cradle gave us some options so get to work turning them
              -- into and HscEnv.

ghcide/src/Development/IDE/Core/Rules.hs

@@ -162,6 +162,7 @@ import           Language.LSP.Protocol.Types                  (MessageType (Mess
                                                                ShowMessageParams (ShowMessageParams))
 import           Language.LSP.Server                          (LspT)
 import qualified Language.LSP.Server                          as LSP
+import qualified Language.LSP.Protocol.Message            as LSP
 import           Language.LSP.VFS
 import           Prelude                                      hiding (mod)
 import           System.Directory                             (doesFileExist,
@@ -170,6 +171,7 @@ import           System.Info.Extra                            (isWindows)
 
 
 import           GHC.Fingerprint
+import qualified Development.IDE.Session as Session
 
 -- See Note [Guidelines For Using CPP In GHCIDE Import Statements]
 
@@ -179,12 +181,14 @@ import           GHC                                          (mgModSummaries)
 
 #if MIN_VERSION_ghc(9,3,0)
 import qualified Data.IntMap                                  as IM
+import Data.Row (KnownSymbol)
 #endif
 
 
 
 data Log
   = LogShake Shake.Log
+  | LogSession Session.Log
   | LogReindexingHieFile !NormalizedFilePath
   | LogLoadingHieFile !NormalizedFilePath
   | LogLoadingHieFileFail !FilePath !SomeException
@@ -214,6 +218,7 @@ instance Pretty Log where
         <+> "the HLS version being used, the plugins enabled, and if possible the codebase and file which"
         <+> "triggered this warning."
       ]
+    LogSession msg -> pretty msg
 
 templateHaskellInstructions :: T.Text
 templateHaskellInstructions = "https://haskell-language-server.readthedocs.io/en/latest/troubleshooting.html#static-binaries"
@@ -707,8 +712,24 @@ loadGhcSession recorder ghcSessionDepsConfig = do
         return (fingerprint, res)
 
     defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GhcSession file -> do
+        -- todo add signal
+        ShakeExtras{exportsMap, ideTesting = IdeTesting testing, lspEnv, progress} <- getShakeExtras
+        let
+            signal' :: KnownSymbol s => Proxy s -> String -> Action ()
+            signal' msg str = when testing $ liftIO $
+                mRunLspT lspEnv $
+                    LSP.sendNotification (LSP.SMethod_CustomMethod msg) $
+                    toJSON $ [str]
+            signal :: KnownSymbol s => Proxy s -> Action ()
+            signal msg = signal' msg (show file)
+
+
+
+        signal (Proxy @"GhcSession/start")
         IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO
+        signal (Proxy @"GhcSession/loadSessionFun/before")
         (val,deps) <- liftIO $ loadSessionFun $ fromNormalizedFilePath file
+        signal (Proxy @"GhcSession/loadSessionFun/after")
 
         -- add the deps to the Shake graph
         let addDependency fp = do
@@ -721,6 +742,7 @@ loadGhcSession recorder ghcSessionDepsConfig = do
         mapM_ addDependency deps
 
         let cutoffHash = LBS.toStrict $ B.encode (hash (snd val))
+        signal (Proxy @"GhcSession/done")
         return (Just cutoffHash, val)
 
     defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \(GhcSessionDeps_ fullModSummary) file -> do

ghcide/src/Development/IDE/Core/Shake.hs

@@ -137,6 +137,7 @@ import           Development.IDE.Graph.Database         (ShakeDatabase,
                                                          shakeNewDatabase,
                                                          shakeProfileDatabase,
                                                          shakeRunDatabaseForKeys)
+import           Development.IDE.Graph.Internal.Profile (collectProfileMemory)
 import           Development.IDE.Graph.Rule
 import           Development.IDE.Types.Action
 import           Development.IDE.Types.Diagnostics
@@ -716,6 +717,7 @@ shakeShut IdeState{..} = do
     -- request so we first abort that.
     for_ runner cancelShakeSession
     void $ shakeDatabaseProfile shakeDb
+    void $ collectProfileMemory shakeDb
     progressStop $ progress shakeExtras
     stopMonitoring
 

ghcide/test/exe/CradleTests.hs

@@ -205,19 +205,21 @@ sessionDepsArePickedUp :: TestTree
 sessionDepsArePickedUp = testSession'
   "session-deps-are-picked-up"
   $ \dir -> do
-    liftIO $
-      writeFileUTF8
-        (dir </> "hie.yaml")
-        "cradle: {direct: {arguments: []}}"
     -- Open without OverloadedStrings and expect an error.
     doc <- createDoc "Foo.hs" "haskell" fooContent
-    expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (3, 6), "Couldn't match type")])]
-
     -- Update hie.yaml to enable OverloadedStrings.
     liftIO $
       writeFileUTF8
         (dir </> "hie.yaml")
         "cradle: {direct: {arguments: [-XOverloadedStrings]}}"
+    -- Now no errors.
+    -- expectDiagnostics [("Foo.hs", [])]
+    expectNoMoreDiagnostics 3
+
+    liftIO $
+      writeFileUTF8
+        (dir </> "hie.yaml")
+        "cradle: {direct: {arguments: []}}"
     sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams
         [FileEvent (filePathToUri $ dir </> "hie.yaml") FileChangeType_Changed ]
     -- Send change event.
@@ -226,8 +228,7 @@ sessionDepsArePickedUp = testSession'
                                               .+ #rangeLength .== Nothing
                                               .+ #text .== "\n"
     changeDoc doc [change]
-    -- Now no errors.
-    expectDiagnostics [("Foo.hs", [])]
+    expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (3, 6), "Couldn't match type")])]
   where
     fooContent =
       T.unlines

haskell-language-server.cabal

@@ -1769,6 +1769,7 @@ test-suite hls-core-plugin-tests
     CompletionTests
     HighlightTests
     ReferenceTests
+    CradleTests
 
 
   build-depends:

hls-graph/hls-graph.cabal

@@ -62,6 +62,7 @@ library
     Development.IDE.Graph.Internal.Profile
     Development.IDE.Graph.Internal.Rules
     Development.IDE.Graph.Internal.Types
+    Development.IDE.Graph.Internal.DataSize
     Development.IDE.Graph.KeyMap
     Development.IDE.Graph.KeySet
     Development.IDE.Graph.Rule
@@ -92,6 +93,7 @@ library
     , transformers
     , unliftio
     , unordered-containers
+    , ghc-heap
 
   if flag(embed-files)
     cpp-options:   -DFILE_EMBED

hls-graph/src/Development/IDE/Graph/Internal/DataSize.hs

@@ -0,0 +1,94 @@
+{-# LANGUAGE BangPatterns  #-}
+{-# LANGUAGE MagicHash     #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+{- |
+   Module      : GHC.DataSize
+   Copyright   : (c) Dennis Felsing
+   License     : 3-Clause BSD-style
+   Maintainer  : [email protected]
+ -}
+module Development.IDE.Graph.Internal.DataSize (
+  closureSize,
+  recursiveSize,
+  recursiveSizeNF
+  )
+  where
+
+import           Control.DeepSeq         (NFData, ($!!))
+
+import           GHC.Exts
+import           GHC.Exts.Heap           hiding (size)
+import           GHC.Exts.Heap.Constants (wORD_SIZE)
+
+import           Control.Monad
+
+import           System.Mem
+
+-- Inspired by Simon Marlow:
+-- https://ghcmutterings.wordpress.com/2009/02/12/53/
+
+-- | Calculate size of GHC objects in Bytes. Note that an object may not be
+--   evaluated yet and only the size of the initial closure is returned.
+closureSize :: a -> IO Word
+closureSize x = do
+  rawWds <- getClosureRawWords x
+  return . fromIntegral $ length rawWds * wORD_SIZE
+
+-- | Calculate the recursive size of GHC objects in Bytes. Note that the actual
+--   size in memory is calculated, so shared values are only counted once.
+--
+--   Call with
+--   @
+--    recursiveSize $! 2
+--   @
+--   to force evaluation to WHNF before calculating the size.
+--
+--   Call with
+--   @
+--    recursiveSize $!! \"foobar\"
+--   @
+--   ($!! from Control.DeepSeq) to force full evaluation before calculating the
+--   size.
+--
+--   A garbage collection is performed before the size is calculated, because
+--   the garbage collector would make heap walks difficult.
+--
+--   This function works very quickly on small data structures, but can be slow
+--   on large and complex ones. If speed is an issue it's probably possible to
+--   get the exact size of a small portion of the data structure and then
+--   estimate the total size from that.
+
+recursiveSize :: a -> IO Word
+recursiveSize x = do
+  performGC
+  liftM snd $ go ([], 0) $ asBox x
+  where go (!vs, !acc) b@(Box y) = do
+          isElem <- liftM or $ mapM (areBoxesEqual b) vs
+          if isElem
+            then return (vs, acc)
+            else do
+             size    <- closureSize y
+             closure <- getClosureData y
+             foldM go (b : vs, acc + size) $ allClosures closure
+
+-- | Calculate the recursive size of GHC objects in Bytes after calling
+-- Control.DeepSeq.force on the data structure to force it into Normal Form.
+-- Using this function requires that the data structure has an `NFData`
+-- typeclass instance.
+
+recursiveSizeNF :: NFData a => a -> IO Word
+recursiveSizeNF x = recursiveSize $!! x
+
+-- | Adapted from 'GHC.Exts.Heap.getClosureRaw' which isn't exported.
+--
+-- This returns the raw words of the closure on the heap. Once back in the
+-- Haskell world, the raw words that hold pointers may be outdated after a
+-- garbage collector run.
+getClosureRawWords :: a -> IO [Word]
+getClosureRawWords x = do
+    case unpackClosure# x of
+        (# _iptr, dat, _pointers #) -> do
+            let nelems = (I# (sizeofByteArray# dat)) `div` wORD_SIZE
+                end = fromIntegral nelems - 1
+            pure [W# (indexWordArray# dat i) | I# i <- [0.. end] ]

hls-graph/src/Development/IDE/Graph/Internal/Profile.hs

@@ -5,8 +5,9 @@
 
 {- HLINT ignore "Redundant bracket" -} -- a result of CPP expansion
 
-module Development.IDE.Graph.Internal.Profile (writeProfile) where
+module Development.IDE.Graph.Internal.Profile (writeProfile, collectProfileMemory) where
 
+import           Control.Concurrent.STM                  (atomically)
 import           Control.Concurrent.STM.Stats            (readTVarIO)
 import           Data.Bifunctor
 import qualified Data.ByteString.Lazy.Char8              as LBS
@@ -23,13 +24,16 @@ import           Data.Maybe
 import           Data.Time                               (getCurrentTime)
 import           Data.Time.Format.ISO8601                (iso8601Show)
 import           Development.IDE.Graph.Internal.Database (getDirtySet)
+import           Development.IDE.Graph.Internal.DataSize
 import           Development.IDE.Graph.Internal.Key
 import           Development.IDE.Graph.Internal.Paths
 import           Development.IDE.Graph.Internal.Types
 import qualified Language.Javascript.DGTable             as DGTable
 import qualified Language.Javascript.Flot                as Flot
 import qualified Language.Javascript.JQuery              as JQuery
+import           ListT                                   (toList)
 import           Numeric.Extra                           (showDP)
+import qualified StmContainers.Map                       as SMap
 import           System.FilePath
 import           System.IO.Unsafe                        (unsafePerformIO)
 import           System.Time.Extra                       (Seconds)
@@ -39,6 +43,16 @@ import           Data.FileEmbed
 import           Language.Haskell.TH.Syntax              (runIO)
 #endif
 
+data DataBaseProfileMemory = ProfileMemory
+    {}
+
+collectProfileMemory :: ShakeDatabase -> IO DataBaseProfileMemory
+collectProfileMemory (ShakeDatabase _ _ Database{databaseValues}) = do
+    kvss <- atomically $ (fmap . fmap) (first renderKey) $ toList $ SMap.listT databaseValues
+    kvs <- mapM  (\(k, v)->  fmap (k, ) (recursiveSize v)) $ kvss
+    writeFile "profile-memory.txt" $ show kvs
+    pure ProfileMemory
+
 -- | Generates an report given some build system profiling data.
 writeProfile :: FilePath -> Database -> IO ()
 writeProfile out db = do