add core plugin

.github/workflows/test.yml

@@ -114,6 +114,10 @@ jobs:
         name: Test hls-graph
         run: cabal test hls-graph
 
+      - if: matrix.test
+        name: Test hls-core-plugin test suite
+        run: cabal test hls-core-plugin-tests
+
       - if: needs.pre_job.outputs.should_skip_ghcide != 'true' && matrix.test
         name: Test ghcide
         # run the tests without parallelism to avoid running out of memory
@@ -254,6 +258,7 @@ jobs:
         name: Test hls-notes-plugin test suite
         run: cabal test hls-notes-plugin-tests || cabal test hls-notes-plugin-tests
 
+
   test_post_job:
     if: always()
     runs-on: ubuntu-latest

.pre-commit-config.yaml

@@ -4,7 +4,8 @@
       "hooks": [
         {
           "entry": "stylish-haskell --inplace",
-          "exclude": "(^Setup.hs$|test/testdata/.*$|test/data/.*$|test/manual/lhs/.*$|^hie-compat/.*$|^plugins/hls-tactics-plugin/.*$|^ghcide/src/Development/IDE/GHC/Compat.hs$|^plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs$|^ghcide/src/Development/IDE/GHC/Compat/Core.hs$|^ghcide/src/Development/IDE/Spans/Pragmas.hs$|^ghcide/src/Development/IDE/LSP/Outline.hs$|^plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs$|^ghcide/test/exe/Main.hs$|^ghcide/src/Development/IDE/Core/Rules.hs$|^hls-test-utils/src/Test/Hls/Util.hs$|^ghcide/src/Development/IDE/Core/Compile.hs$|^plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs$|^plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs$)",
+          "exclude": "(^Setup.hs$|test/testdata/.*$|test/data/.*$|test/manual/lhs/.*$|^hie-compat/.*$|^plugins/hls-tactics-plugin/.*$|^ghcide/src/Development/IDE/GHC/Compat.hs$|^plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs$|^ghcide/src/Development/IDE/GHC/Compat/Core.hs$|^ghcide/src/Development/IDE/Spans/Pragmas.hs$|^ghcide/src/Development/IDE/LSP/Outline.hs$|^plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs$|^ghcide/test/exe/Main.hs$|^ghcide/src/Development/IDE/Core/Rules.hs$|^hls-test-utils/src/Test/Hls/Util.hs$|^ghcide/src/Development/IDE/Core/Compile.hs$|^plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs$|^plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs$
+            |^plugins/hls-core-plugin/Core/Outline.hs$)",
           "files": "\\.l?hs$",
           "id": "stylish-haskell",
           "language": "system",

ghcide/src/Development/IDE/LSP/LanguageServer.hs

@@ -42,7 +42,6 @@ import           Ide.Logger
 import           Language.LSP.Server                   (LanguageContextEnv,
                                                         LspServerLog,
                                                         type (<~>))
-import           System.IO.Unsafe                      (unsafeInterleaveIO)
 data Log
   = LogRegisteringIdeConfig !IdeConfiguration
   | LogReactorThreadException !SomeException
@@ -197,18 +196,10 @@ handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId wa
     let root = LSP.resRootPath env
     dir <- maybe getCurrentDirectory return root
     dbLoc <- getHieDbLoc dir
-
-    -- The database needs to be open for the duration of the reactor thread, but we need to pass in a reference
-    -- to 'getIdeState', so we use this dirty trick
-    dbMVar <- newEmptyMVar
-    ~(WithHieDbShield withHieDb,hieChan) <- unsafeInterleaveIO $ takeMVar dbMVar
-
-    ide <- getIdeState env root withHieDb hieChan
-
     let initConfig = parseConfiguration params
-
     logWith recorder Info $ LogRegisteringIdeConfig initConfig
-    registerIdeConfiguration (shakeExtras ide) initConfig
+    dbMVar <- newEmptyMVar
+
 
     let handleServerException (Left e) = do
             logWith recorder Error $ LogReactorThreadException e
@@ -245,6 +236,10 @@ handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId wa
                     ReactorNotification act -> handle exceptionInHandler act
                     ReactorRequest _id act k -> void $ async $ checkCancelled _id act k
         logWith recorder Info LogReactorThreadStopped
+
+    (WithHieDbShield withHieDb,hieChan) <- takeMVar dbMVar
+    ide <- getIdeState env root withHieDb hieChan
+    registerIdeConfiguration (shakeExtras ide) initConfig
     pure $ Right (env,ide)
 
 

haskell-language-server.cabal

@@ -1705,6 +1705,101 @@ test-suite hls-refactor-plugin-tests
     , tasty-expected-failure
     , tasty
 
+-----------------------------
+-- core plugin
+-----------------------------
+
+-- flag semanticTokens
+--   description: Enable semantic tokens plugin
+--   default:     True
+--   manual:      True
+
+common core
+  build-depends: haskell-language-server:hls-core-plugin
+
+library hls-core-plugin
+  import: defaults, pedantic, warnings
+  buildable: True
+  exposed-modules:
+    Ide.Plugin.Core
+    Ide.Plugin.Core.Actions
+    Ide.Plugin.Core.HoverDefinition
+    Ide.Plugin.Core.Outline
+
+  hs-source-dirs:     plugins/hls-core-plugin/src
+  build-depends:
+    , base                  >=4.12 && <5
+    , containers
+    , unordered-containers
+    , extra
+    , ghc
+    , text-rope
+    , mtl                   >= 2.2
+    , ghcide                == 2.7.0.0
+    , hls-plugin-api        == 2.7.0.0
+    , lens
+    , lsp                    >=2.4
+    , hiedb                 ^>= 0.6.0.0
+    , text
+    , transformers
+    , bytestring
+    , syb
+    , array
+    , deepseq
+    , dlist
+    , hls-graph == 2.7.0.0
+    , template-haskell
+    , data-default
+    , stm
+    , stm-containers
+
+  default-extensions: DataKinds
+
+test-suite hls-core-plugin-tests
+  import:           defaults, pedantic, test-defaults, warnings
+  type:             exitcode-stdio-1.0
+  hs-source-dirs:   plugins/hls-core-plugin/test
+                    ,  plugins/hls-core-plugin/test/exe
+  main-is:          CoreTest.hs
+  other-modules:
+    Util
+    FindDefinitionAndHoverTests
+    InitializeResponseTests
+    OutlineTests
+    CompletionTests
+    HighlightTests
+    ReferenceTests
+    CradleTests
+
+
+  build-depends:
+    , aeson
+    , base
+    , async
+    , containers
+    , filepath
+    , haskell-language-server:hls-core-plugin
+    , hls-test-utils              == 2.7.0.0
+    , hls-plugin-api
+    , lens
+    , lsp
+    , text-rope
+    , lsp-test
+    , text
+    , tasty
+    , tasty-hunit
+    , data-default
+    , ghcide                == 2.7.0.0
+    , hls-plugin-api        == 2.7.0.0
+    , data-default
+    , row-types
+    , extra
+    , hls-test-utils
+    , regex-tdfa
+    , directory
+    , tasty-expected-failure
+
+
 -----------------------------
 -- semantic tokens plugin
 -----------------------------
@@ -1886,6 +1981,7 @@ library
                   , overloadedRecordDot
                   , semanticTokens
                   , notes
+                  , core
 
   exposed-modules:
     Ide.Arguments

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