WIP integrate haskell-lsp-1.0.0.0

some progress Mostly everything except LanguageServer.hs make it compile make it work fix benchmarks update tweaks fix configuration and tests simplify handlers Update to renamed lsp/lsp-types modules redo plugin api and get library to compile fill in some missing details fix main fix rebase
haskell · Feb 1, 2021 · 8108dbc · 8108dbc
1 parent 9c40dcf
commit 8108dbc
Show file tree

Hide file tree

Showing 48 changed files with 996 additions and 1,424 deletions.
diff --git a/cabal.project b/cabal.project
@@ -12,6 +12,9 @@ packages:
          ./plugins/hls-retrie-plugin
          ./plugins/hls-haddock-comments-plugin
          ./plugins/hls-splice-plugin
+         /home/zubin/hie-lsp/haskell-lsp/
+         /home/zubin/hie-lsp/haskell-lsp/lsp-types
+         /home/zubin/hie-lsp/haskell-lsp/lsp-test
 
 source-repository-package
   type: git

diff --git a/ghcide/bench/lib/Experiments.hs b/ghcide/bench/lib/Experiments.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE ImplicitParams #-}
 {-# LANGUAGE ImpredicativeTypes #-}
@@ -23,16 +24,16 @@ import Control.Applicative.Combinators (skipManyTill)
 import Control.Exception.Safe
 import Control.Monad.Extra
 import Control.Monad.IO.Class
-import Data.Aeson (Value(Null))
+import Data.Aeson (Value(Null), toJSON)
 import Data.List
 import Data.Maybe
 import qualified Data.Text as T
 import Data.Version
 import Development.IDE.Plugin.Test
 import Experiments.Types
-import Language.Haskell.LSP.Test
-import Language.Haskell.LSP.Types
-import Language.Haskell.LSP.Types.Capabilities
+import Language.LSP.Test
+import Language.LSP.Types
+import Language.LSP.Types.Capabilities
 import Numeric.Natural
 import Options.Applicative
 import System.Directory
@@ -78,7 +79,7 @@ experiments =
           isJust <$> getHover doc (fromJust identifierP),
       ---------------------------------------------------------------------------------------
       bench "getDefinition" 10 $ allWithIdentifierPos $ \DocumentPositions{..} ->
-        not . null <$> getDefinitions doc (fromJust identifierP),
+        either (not . null) (not . null) . toEither <$> getDefinitions doc (fromJust identifierP),
       ---------------------------------------------------------------------------------------
       bench "getDefinition after edit" 10 $ \docs -> do
           forM_ docs $ \DocumentPositions{..} ->
@@ -330,7 +331,9 @@ waitForProgressDone :: Session ()
 waitForProgressDone = loop
   where
     loop = do
-      void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
+      void $ skipManyTill anyMessage $ satisfyMaybe $ \case
+        FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just ()
+        _ -> Nothing
       done <- null <$> getIncompleteProgressSessions
       unless done loop
 
@@ -364,8 +367,9 @@ runBench runSess b = handleAny (\e -> print e >> return badRun)
             else do
                 output (showDuration t)
                 -- Wait for the delayed actions to finish
-                waitId <- sendRequest (CustomClientMethod "test") WaitForShakeQueue
-                (td, resp) <- duration $ skipManyTill anyMessage $ responseForId waitId
+                let m = SCustomMethod "ghcide/blocking/queue"
+                waitId <- sendRequest m (toJSON WaitForShakeQueue)
+                (td, resp) <- duration $ skipManyTill anyMessage $ responseForId m waitId
                 case resp of
                     ResponseMessage{_result=Right Null} -> do
                       loop (userWaits+t) (delayedWork+td) (n -1)

diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs
@@ -32,10 +32,9 @@ import Development.IDE.Plugin
 import Development.IDE.Plugin.Test as Test
 import Development.IDE.Session (loadSession, setInitialDynFlags, getHieDbLoc, runWithDb)
 import Development.Shake (ShakeOptions (shakeThreads))
-import qualified Language.Haskell.LSP.Core as LSP
-import Language.Haskell.LSP.Messages
-import Language.Haskell.LSP.Types
-import Language.Haskell.LSP.Types.Lens (params, initializationOptions)
+import qualified Language.LSP.Server as LSP
+import Language.LSP.Types
+import Language.LSP.Types.Lens (params, initializationOptions)
 import Development.IDE.LSP.LanguageServer
 import qualified System.Directory.Extra as IO
 import System.Environment
@@ -117,22 +116,19 @@ runIde Arguments{..} hiedb hiechan = do
 
     let plugins = hlsPlugin
             <> if argsTesting then Test.plugin else mempty
-        onInitialConfiguration :: InitializeRequest -> Either T.Text Config
-        onInitialConfiguration x = case x ^. params . initializationOptions of
-          Nothing -> Right def
-          Just v -> case J.fromJSON v of
-            J.Error err -> Left $ T.pack err
-            J.Success a -> Right a
-        onConfigurationChange = const $ Left "Updating Not supported"
         options = def { LSP.executeCommandCommands = Just hlsCommands
                       , LSP.completionTriggerCharacters = Just "."
                       }
+        onConfigurationChange _ide v = pure $ case J.fromJSON v of
+          J.Error err -> Left $ T.pack err
+          J.Success a -> Right a
+
     case argFilesOrCmd of
       Nothing -> do
         t <- offsetTime
         hPutStrLn stderr "Starting LSP server..."
         hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"
-        runLanguageServer options (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps wProg wIndefProg getConfig rootPath -> do
+        runLanguageServer options onConfigurationChange (pluginHandlers plugins) $ \env vfs rootPath -> do
             t <- t
             hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
 
@@ -144,15 +140,16 @@ runIde Arguments{..} hiedb hiechan = do
                           `catchAny` (\e -> (hPutStrLn stderr $ "setInitialDynFlags: " ++ displayException e) >> pure Nothing)
 
             sessionLoader <- loadSession $ fromMaybe dir rootPath
-            config <- fromMaybe def <$> getConfig
+            let config = maybe def id <$> (LSP.runLspT env LSP.getConfig)
+            caps <- LSP.runLspT env LSP.getClientCapabilities
             let options = defOptions
                     { optReportProgress    = clientSupportsProgress caps
                     , optShakeProfiling    = argsShakeProfiling
                     , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling
                     , optTesting           = IdeTesting argsTesting
                     , optShakeOptions      = (optShakeOptions defOptions){shakeThreads = argsThreads}
-                    , optCheckParents      = checkParents config
-                    , optCheckProject      = checkProject config
+                    , optCheckParents      = checkParents <$> config
+                    , optCheckProject      = checkProject <$> config
                     }
                 defOptions = defaultIdeOptions sessionLoader
                 logLevel = if argsVerbose then minBound else Info
@@ -165,8 +162,7 @@ runIde Arguments{..} hiedb hiechan = do
                   -- Shake database restart, i.e. on every user edit.
                   unless argsDisableKick $
                     action kick
-            initialise caps rules
-                getLspId event wProg wIndefProg (logger logLevel) debouncer options vfs hiedb hiechan
+            initialise rules (Just env) (logger logLevel) debouncer options vfs hiedb hiechan
       Just argFiles -> do
         -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
         hSetEncoding stdout utf8
@@ -197,12 +193,12 @@ runIde Arguments{..} hiedb hiechan = do
                     -- , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling
                     , optTesting           = IdeTesting argsTesting
                     , optShakeOptions      = (optShakeOptions defOptions){shakeThreads = argsThreads}
-                    , optCheckParents      = NeverCheck
-                    , optCheckProject      = False
+                    , optCheckParents      = pure NeverCheck
+                    , optCheckProject      = pure False
                     }
             defOptions = defaultIdeOptions sessionLoader
             logLevel = if argsVerbose then minBound else Info
-        ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger logLevel) debouncer options vfs hiedb hiechan
+        ide <- initialise mainRule Nothing (logger logLevel) debouncer (defaultIdeOptions sessionLoader) vfs hiedb hiechan
 
         putStrLn "\nStep 4/4: Type checking the files"
         setFilesOfInterest ide $ HashMap.fromList $ map ((, OnDisk) . toNormalizedFilePath') files

diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal
@@ -46,6 +46,8 @@ library
         data-default,
         deepseq,
         directory,
+        dependent-map,
+        dependent-sum,
         dlist,
         extra >= 1.7.4,
         fuzzy,
@@ -55,12 +57,12 @@ library
         Glob,
         haddock-library >= 1.8,
         hashable,
-        haskell-lsp-types == 0.23.*,
-        haskell-lsp == 0.23.*,
         hie-compat,
         hls-plugin-api >= 0.6,
         lens,
         hiedb == 0.3.0.1,
+        lsp-types == 1.0.*,
+        lsp == 1.0.*,
         mtl,
         network-uri,
         parallel,
@@ -88,7 +90,8 @@ library
         vector,
         bytestring-encoding,
         opentelemetry >=0.6.1,
-        heapsize ==0.3.*
+        heapsize ==0.3.*,
+        unliftio
     if flag(ghc-lib)
       build-depends:
         ghc-lib >= 8.8,
@@ -205,7 +208,6 @@ library
         Development.IDE.Plugin.CodeAction.Rules
         Development.IDE.Plugin.CodeAction.RuleTypes
         Development.IDE.Plugin.Completions.Logic
-        Development.IDE.Plugin.HLS.Formatter
         Development.IDE.Types.Action
     ghc-options: -Wall -Wno-name-shadowing -Wincomplete-uni-patterns
 
@@ -282,8 +284,8 @@ executable ghcide
         safe-exceptions,
         ghc,
         hashable,
-        haskell-lsp,
-        haskell-lsp-types,
+        lsp,
+        lsp-types,
         heapsize,
         hie-bios,
         hls-plugin-api,
@@ -342,12 +344,12 @@ test-suite ghcide-tests
         ghcide,
         ghc-typelits-knownnat,
         haddock-library,
-        haskell-lsp,
-        haskell-lsp-types,
+        lsp,
+        lsp-types,
         hls-plugin-api,
         network-uri,
         lens,
-        lsp-test >= 0.12.0.0 && < 0.13,
+        lsp-test >= 0.11.0.6 && < 0.13,
         optparse-applicative,
         process,
         QuickCheck,
@@ -404,7 +406,7 @@ executable ghcide-bench
         extra,
         filepath,
         ghcide,
-        lsp-test >= 0.12.0.0 && < 0.13,
+        lsp-test >= 0.11.0.6 && < 0.13,
         optparse-applicative,
         process,
         safe-exceptions,

diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs
@@ -58,9 +58,8 @@ import qualified HIE.Bios as HieBios
 import HIE.Bios.Environment hiding (getCacheDir)
 import HIE.Bios.Types
 import Hie.Implicit.Cradle (loadImplicitHieCradle)
-import Language.Haskell.LSP.Core
-import Language.Haskell.LSP.Messages
-import Language.Haskell.LSP.Types
+import Language.LSP.Server
+import Language.LSP.Types
 import System.Directory
 import qualified System.Directory.Extra as IO
 import System.FilePath
@@ -206,12 +205,11 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
   runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq,[FilePath])))
 
   return $ do
-    extras@ShakeExtras{logger, eventer, restartShakeSession,
-                       withIndefiniteProgress, ideNc, knownTargetsVar
+    extras@ShakeExtras{logger, restartShakeSession, ideNc, knownTargetsVar, lspEnv
                       } <- getShakeExtras
 
     IdeOptions{ optTesting = IdeTesting optTesting
-              , optCheckProject = checkProject
+              , optCheckProject = getCheckProject
               , optCustomDynFlags
               , optExtensions
               } <- getIdeOptions
@@ -356,6 +354,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
           restartShakeSession []
 
           -- Typecheck all files in the project on startup
+          checkProject <- getCheckProject
           unless (null cs || not checkProject) $ do
                 cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations cs)
                 void $ shakeEnqueue extras $ mkDelayedAction "InitialLoad" Debug $ void $ do
@@ -374,17 +373,19 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
            lfp <- flip makeRelative cfp <$> getCurrentDirectory
            logInfo logger $ T.pack ("Consulting the cradle for " <> show lfp)
 
-           when (isNothing hieYaml) $ eventer $ notifyUserImplicitCradle lfp
+           when (isNothing hieYaml) $ mRunLspT lspEnv $
+             sendNotification SWindowShowMessage $ notifyUserImplicitCradle lfp
 
            cradle <- maybe (loadImplicitHieCradle $ addTrailingPathSeparator dir) loadCradle hieYaml
 
-           when optTesting $ eventer $ notifyCradleLoaded lfp
+           when optTesting $ mRunLspT lspEnv $
+            sendNotification (SCustomMethod "ghcide/cradle/loaded") (toJSON cfp)
 
            -- 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 <> ")"
-           eopts <- withIndefiniteProgress progMsg NotCancellable $
-             cradleToOptsAndLibDir cradle cfp
+           eopts <- mRunLspTCallback lspEnv (withIndefiniteProgress progMsg NotCancellable) $
+              cradleToOptsAndLibDir cradle cfp
 
            logDebug logger $ T.pack ("Session loading result: " <> show eopts)
            case eopts of
@@ -794,24 +795,12 @@ getCacheDirsDefault prefix opts = do
 cacheDir :: String
 cacheDir = "ghcide"
 
-notifyUserImplicitCradle:: FilePath -> FromServerMessage
-notifyUserImplicitCradle fp =
-    NotShowMessage $
-    NotificationMessage "2.0" WindowShowMessage $ ShowMessageParams MtInfo $
-      "No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for "
-      <> T.pack fp <>
-      ".\n Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie).\n" <>
-      "You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error."
-
-notifyCradleLoaded :: FilePath -> FromServerMessage
-notifyCradleLoaded fp =
-    NotCustomServer $
-    NotificationMessage "2.0" (CustomServerMethod cradleLoadedMethod) $
-    toJSON fp
-
-cradleLoadedMethod :: T.Text
-cradleLoadedMethod = "ghcide/cradle/loaded"
-
+notifyUserImplicitCradle:: FilePath -> ShowMessageParams
+notifyUserImplicitCradle fp =ShowMessageParams MtWarning $
+  "No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for "
+  <> T.pack fp <>
+  ".\n Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie).\n"<>
+  "You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error."
 ----------------------------------------------------------------------------------------------------
 
 data PackageSetupException