Merge pull request #1316 from haskell/upgrade-lsp-0.15

Upgrade to haskell-lsp 0.15

Author: lorenzo

haskell-ide-engine.cabal

@@ -70,8 +70,8 @@ library
                      , gitrev >= 1.1
                      , haddock-api
                      , haddock-library
-                     , haskell-lsp == 0.14.*
-                     , haskell-lsp-types == 0.14.*
+                     , haskell-lsp == 0.15.*
+                     , haskell-lsp-types == 0.15.*
                      , haskell-src-exts
                      , hie-plugin-api
                      , hlint (>= 2.0.11 && < 2.1.18) || >= 2.1.22
@@ -192,7 +192,7 @@ test-suite unit-test
                      , filepath
                      , free
                      , haskell-ide-engine
-                     , haskell-lsp-types
+                     , haskell-lsp-types >= 0.15.0.0
                      , hie-test-utils
                      , hie-plugin-api
                      , hoogle > 5.0.11
@@ -278,10 +278,10 @@ test-suite func-test
                      , data-default
                      , directory
                      , filepath
-                     , lsp-test >= 0.5.2
+                     , lsp-test >= 0.6.0.0
                      , haskell-ide-engine
-                     , haskell-lsp-types == 0.14.*
-                     , haskell-lsp == 0.14.*
+                     , haskell-lsp-types == 0.15.*
+                     , haskell-lsp == 0.15.*
                      , hie-test-utils
                      , hie-plugin-api
                      , hspec

hie-plugin-api/Haskell/Ide/Engine/Config.hs

@@ -8,14 +8,23 @@ import           Language.Haskell.LSP.Types
 
 -- ---------------------------------------------------------------------
 
--- | Callback from haskell-lsp core to convert the generic message to the
--- specific one for hie
+-- | Given a DidChangeConfigurationNotification message, this function returns the parsed
+-- Config object if possible.
 getConfigFromNotification :: DidChangeConfigurationNotification -> Either T.Text Config
 getConfigFromNotification (NotificationMessage _ _ (DidChangeConfigurationParams p)) =
   case fromJSON p of
     Success c -> Right c
     Error err -> Left $ T.pack err
 
+-- | Given an InitializeRequest message, this function returns the parsed
+-- Config object if possible. Otherwise, it returns the default configuration
+getInitialConfig :: InitializeRequest -> Either T.Text Config
+getInitialConfig (RequestMessage _ _ _ InitializeParams{_initializationOptions = Nothing }) = Right def
+getInitialConfig (RequestMessage _ _ _ InitializeParams{_initializationOptions = Just opts}) =
+  case fromJSON opts of
+    Success c -> Right c
+    Error err -> Left $ T.pack err
+
 -- ---------------------------------------------------------------------
 
 data Config =

hie-plugin-api/Haskell/Ide/Engine/Ghc.hs

@@ -11,7 +11,7 @@
 module Haskell.Ide.Engine.Ghc
   (
     setTypecheckedModule
-  , Diagnostics
+  , Diagnostics(..)
   , AdditionalErrs
   , cabalModuleGraphs
   , makeRevRedirMapFunc
@@ -21,9 +21,11 @@ import           Bag
 import           Control.Monad.IO.Class
 import           Data.IORef
 import qualified Data.Map.Strict                   as Map
-import           Data.Monoid ((<>))
+import           Data.Semigroup ((<>), Semigroup)
 import qualified Data.Set                          as Set
 import qualified Data.Text                         as T
+import qualified Data.Aeson
+import           Data.Coerce
 import           ErrUtils
 
 import qualified GhcModCore                   as GM ( withDynFlags
@@ -45,10 +47,24 @@ import           GHC
 import           IOEnv                             as G
 import           HscTypes
 import           Outputable                        (renderWithStyle)
+import           Language.Haskell.LSP.Types        ( NormalizedUri(..), toNormalizedUri )
 
 -- ---------------------------------------------------------------------
 
-type Diagnostics = Map.Map Uri (Set.Set Diagnostic)
+newtype Diagnostics = Diagnostics (Map.Map NormalizedUri (Set.Set Diagnostic))
+  deriving (Show, Eq)
+
+instance Semigroup Diagnostics where
+  Diagnostics d1 <> Diagnostics d2 = Diagnostics (d1 <> d2)
+
+instance Monoid Diagnostics where
+  mappend = (<>)
+  mempty = Diagnostics mempty
+
+instance Data.Aeson.ToJSON Diagnostics where
+  toJSON (Diagnostics d) = Data.Aeson.toJSON
+    (Map.mapKeys coerce d :: Map.Map T.Text (Set.Set Diagnostic))
+
 type AdditionalErrs = [T.Text]
 
 -- ---------------------------------------------------------------------
@@ -68,10 +84,9 @@ logDiag rfm eref dref df _reason sev spn style msg = do
   let msgTxt = T.pack $ renderWithStyle df msg style
   case eloc of
     Right (Location uri range) -> do
-      let update = Map.insertWith Set.union uri l
-            where l = Set.singleton diag
+      let update = Map.insertWith Set.union (toNormalizedUri uri) (Set.singleton diag)
           diag = Diagnostic range (Just $ lspSev sev) Nothing (Just "ghcmod") msgTxt Nothing
-      modifyIORef' dref update
+      modifyIORef' dref (\(Diagnostics d) -> Diagnostics $ update d)
     Left _ -> do
       modifyIORef' eref (msgTxt:)
       return ()
@@ -109,9 +124,11 @@ srcErrToDiag df rfm se = do
         (m,es) <- processMsgs xs
         case res of
           Right (uri, diag) ->
-            return (Map.insertWith Set.union uri (Set.singleton diag) m, es)
+            return (Map.insertWith Set.union (toNormalizedUri uri) (Set.singleton diag) m, es)
           Left e -> return (m, e:es)
-  processMsgs errMsgs
+
+  (diags, errs) <- processMsgs errMsgs
+  return (Diagnostics diags, errs)
 
 -- ---------------------------------------------------------------------
 
@@ -121,11 +138,14 @@ myWrapper :: GM.IOish m
   -> GM.GmlT m (Diagnostics, AdditionalErrs)
 myWrapper rfm action = do
   env <- getSession
-  diagRef <- liftIO $ newIORef Map.empty
+  diagRef <- liftIO $ newIORef mempty
   errRef <- liftIO $ newIORef []
   let setLogger df = df { log_action = logDiag rfm errRef diagRef }
       setDeferTypedHoles = setGeneralFlag' Opt_DeferTypedHoles
-      ghcErrRes msg = (Map.empty, [T.pack msg])
+
+      ghcErrRes :: String -> (Diagnostics, AdditionalErrs)
+      ghcErrRes msg = (mempty, [T.pack msg])
+
       handlers = errorHandlers ghcErrRes (srcErrToDiag (hsc_dflags env) rfm )
       action' = do
         GM.withDynFlags (setLogger . setDeferTypedHoles) action
@@ -167,20 +187,20 @@ setTypecheckedModule uri =
     debugm $ "setTypecheckedModule: file mapping state is: " ++ show fileMap
     rfm <- GM.mkRevRedirMapFunc
     let
-      ghcErrRes msg = ((Map.empty, [T.pack msg]),Nothing,Nothing)
+      ghcErrRes msg = ((Diagnostics Map.empty, [T.pack msg]),Nothing,Nothing)
       progTitle = "Typechecking " <> T.pack (takeFileName fp)
     debugm "setTypecheckedModule: before ghc-mod"
     -- TODO:AZ: loading this one module may/should trigger loads of any
     -- other modules which currently have a VFS entry.  Need to make
     -- sure that their diagnostics are reported, and their module
     -- cache entries are updated.
     -- TODO: Are there any hooks we can use to report back on the progress?
-    ((diags', errs), mtm, mpm) <- withIndefiniteProgress progTitle NotCancellable $ GM.gcatches
+    ((Diagnostics diags', errs), mtm, mpm) <- withIndefiniteProgress progTitle NotCancellable $ GM.gcatches
       (GM.getModulesGhc' (myWrapper rfm) fp)
       (errorHandlers ghcErrRes (return . ghcErrRes . show))
     debugm "setTypecheckedModule: after ghc-mod"
 
-    canonUri <- canonicalizeUri uri
+    canonUri <- toNormalizedUri <$> canonicalizeUri uri
     let diags = Map.insertWith Set.union canonUri Set.empty diags'
     diags2 <- case (mpm,mtm) of
       (Just pm, Nothing) -> do
@@ -212,7 +232,7 @@ setTypecheckedModule uri =
         let d = Diagnostic range sev Nothing (Just "ghcmod") msgTxt Nothing
         return $ Map.insertWith Set.union canonUri (Set.singleton d) diags
 
-    return $ IdeResultOk (diags2,errs)
+    return $ IdeResultOk (Diagnostics diags2,errs)
 
 -- ---------------------------------------------------------------------
 

hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs

@@ -155,6 +155,7 @@ import           Language.Haskell.LSP.Types     ( Command(..)
                                                 , WorkspaceEdit(..)
                                                 , filePathToUri
                                                 , uriToFilePath
+                                                , toNormalizedUri
                                                 )
 
 import           Language.Haskell.LSP.VFS       ( VirtualFile(..) )
@@ -410,7 +411,7 @@ getVirtualFile :: (MonadIde m, MonadIO m) => Uri -> m (Maybe VirtualFile)
 getVirtualFile uri = do
   mlf <- ideEnvLspFuncs <$> getIdeEnv
   case mlf of
-    Just lf -> liftIO $ Core.getVirtualFileFunc lf uri
+    Just lf -> liftIO $ Core.getVirtualFileFunc lf (toNormalizedUri uri)
     Nothing -> return Nothing
 
 getConfig :: (MonadIde m, MonadIO m) => m Config

hie-plugin-api/hie-plugin-api.cabal

@@ -45,7 +45,7 @@ library
                      , ghc
                      , ghc-mod-core >= 5.9.0.0
                      , ghc-project-types >= 5.9.0.0
-                     , haskell-lsp == 0.14.*
+                     , haskell-lsp == 0.15.*
                      , hslogger
                      , monad-control
                      , mtl

src/Haskell/Ide/Engine/LSP/CodeActions.hs

@@ -32,7 +32,7 @@ handleCodeActionReq :: TrackingNumber -> J.CodeActionRequest -> R ()
 handleCodeActionReq tn req = do
 
   vfsFunc <- asksLspFuncs Core.getVirtualFileFunc
-  docVersion <- fmap _version <$> liftIO (vfsFunc docUri)
+  docVersion <- fmap _version <$> liftIO (vfsFunc (J.toNormalizedUri docUri))
   let docId = J.VersionedTextDocumentIdentifier docUri docVersion
 
   let getProvider p = pluginCodeActionProvider p <*> return (pluginId p)

src/Haskell/Ide/Engine/Transport/LspStdio.hs

@@ -93,7 +93,7 @@ data DiagnosticsRequest = DiagnosticsRequest
   , trackingNumber  :: TrackingNumber
     -- ^ The tracking identifier for this request
 
-  , file         :: J.Uri
+  , file         :: Uri
     -- ^ The file that was change and needs to be checked
 
   , documentVersion :: J.TextDocumentVersion
@@ -118,7 +118,7 @@ run scheduler _origDir plugins captureFp = flip E.catches handlers $ do
   rin        <- atomically newTChan :: IO (TChan ReactorInput)
   commandIds <- allLspCmdIds plugins
 
-  let dp lf = do
+  let onStartup lf = do
         diagIn      <- atomically newTChan
         let react = runReactor lf scheduler diagnosticProviders hps sps fps plugins
             reactorFunc = react $ reactor rin diagIn
@@ -175,8 +175,11 @@ run scheduler _origDir plugins captureFp = flip E.catches handlers $ do
       fps :: Map.Map PluginId FormattingProvider
       fps = Map.mapMaybe pluginFormattingProvider $ ipMap plugins
 
+      initCallbacks :: Core.InitializeCallbacks Config
+      initCallbacks = Core.InitializeCallbacks getInitialConfig getConfigFromNotification onStartup
+
   flip E.finally finalProc $ do
-    CTRL.run (getConfigFromNotification, dp) (hieHandlers rin) (hieOptions commandIds) captureFp
+    CTRL.run initCallbacks (hieHandlers rin) (hieOptions commandIds) captureFp
  where
   handlers  = [E.Handler ioExcept, E.Handler someExcept]
   finalProc = L.removeAllHandlers
@@ -199,7 +202,7 @@ configVal field = field <$> getClientConfig
 getPrefixAtPos :: (MonadIO m, MonadReader REnv m)
   => Uri -> Position -> m (Maybe Hie.PosPrefixInfo)
 getPrefixAtPos uri pos = do
-  mvf <- liftIO =<< asksLspFuncs Core.getVirtualFileFunc <*> pure uri
+  mvf <- liftIO =<< asksLspFuncs Core.getVirtualFileFunc <*> pure (J.toNormalizedUri uri)
   case mvf of
     Just vf -> VFS.getCompletionPrefix pos vf
     Nothing -> return Nothing
@@ -214,7 +217,7 @@ mapFileFromVfs tn vtdi = do
   let uri = vtdi ^. J.uri
       ver = fromMaybe 0 (vtdi ^. J.version)
   vfsFunc <- asksLspFuncs Core.getVirtualFileFunc
-  mvf <- liftIO $ vfsFunc uri
+  mvf <- liftIO $ vfsFunc (J.toNormalizedUri uri)
   case (mvf, uriToFilePath uri) of
     (Just (VFS.VirtualFile _ yitext _), Just fp) -> do
       let text' = Rope.toString yitext
@@ -308,7 +311,7 @@ updatePositionMap uri changes = pluginGetFile "updatePositionMap: " uri $ \file
 -- ---------------------------------------------------------------------
 
 publishDiagnostics :: (MonadIO m, MonadReader REnv m)
-  => Int -> J.Uri -> J.TextDocumentVersion -> DiagnosticsBySource -> m ()
+  => Int -> J.NormalizedUri -> J.TextDocumentVersion -> DiagnosticsBySource -> m ()
 publishDiagnostics maxToSend uri' mv diags = do
   lf <- asks lspFuncs
   liftIO $ Core.publishDiagnosticsFunc lf maxToSend uri' mv diags
@@ -797,7 +800,7 @@ reactor inp diagIn = do
 withDocumentContents :: J.LspId -> J.Uri -> (T.Text -> R ()) -> R ()
 withDocumentContents reqId uri f = do
   vfsFunc <- asksLspFuncs Core.getVirtualFileFunc
-  mvf <- liftIO $ vfsFunc uri
+  mvf <- liftIO $ vfsFunc (J.toNormalizedUri uri)
   lf <- asks lspFuncs
   case mvf of
     Nothing -> liftIO $
@@ -838,7 +841,7 @@ queueDiagnosticsRequest
   :: TChan DiagnosticsRequest -- ^ The channel to publish the diagnostics requests to
   -> DiagnosticTrigger
   -> TrackingNumber
-  -> J.Uri
+  -> Uri
   -> J.TextDocumentVersion
   -> R ()
 queueDiagnosticsRequest diagIn dt tn uri mVer =
@@ -869,11 +872,11 @@ requestDiagnostics DiagnosticsRequest{trigger, file, trackingNumber, documentVer
           maxToSend = maxNumberOfProblems clientConfig
           sendOne (fileUri,ds') = do
             debugm $ "LspStdio.sendone:(fileUri,ds')=" ++ show(fileUri,ds')
-            publishDiagnosticsIO maxToSend fileUri Nothing (Map.fromList [(Just pid,SL.toSortedList ds')])
+            publishDiagnosticsIO maxToSend (J.toNormalizedUri fileUri) Nothing (Map.fromList [(Just pid,SL.toSortedList ds')])
 
           sendEmpty = do
             debugm "LspStdio.sendempty"
-            publishDiagnosticsIO maxToSend file Nothing (Map.fromList [(Just pid,SL.toSortedList [])])
+            publishDiagnosticsIO maxToSend (J.toNormalizedUri file) Nothing (Map.fromList [(Just pid,SL.toSortedList [])])
 
           -- fv = case documentVersion of
           --   Nothing -> Nothing
@@ -901,26 +904,28 @@ requestDiagnostics DiagnosticsRequest{trigger, file, trackingNumber, documentVer
         when enabled $ makeRequest reql
 
 -- | get hlint and GHC diagnostics and loads the typechecked module into the cache
-requestDiagnosticsNormal :: TrackingNumber -> J.Uri -> J.TextDocumentVersion -> R ()
+requestDiagnosticsNormal :: TrackingNumber -> Uri -> J.TextDocumentVersion -> R ()
 requestDiagnosticsNormal tn file mVer = do
   clientConfig <- getClientConfig
   let
     ver = fromMaybe 0 mVer
 
     -- | If there is a GHC error, flush the hlint diagnostics
     -- TODO: Just flush the parse error diagnostics
-    sendOneGhc :: J.DiagnosticSource -> (Uri, [Diagnostic]) -> R ()
+    sendOneGhc :: J.DiagnosticSource -> (J.NormalizedUri, [Diagnostic]) -> R ()
     sendOneGhc pid (fileUri,ds) = do
       if any (hasSeverity J.DsError) ds
         then publishDiagnostics maxToSend fileUri Nothing
                (Map.fromList [(Just "hlint",SL.toSortedList []),(Just pid,SL.toSortedList ds)])
         else sendOne pid (fileUri,ds)
+
     sendOne pid (fileUri,ds) = do
       publishDiagnostics maxToSend fileUri Nothing (Map.fromList [(Just pid,SL.toSortedList ds)])
+
     hasSeverity :: J.DiagnosticSeverity -> J.Diagnostic -> Bool
     hasSeverity sev (J.Diagnostic _ (Just s) _ _ _ _) = s == sev
     hasSeverity _ _ = False
-    sendEmpty = publishDiagnostics maxToSend file Nothing (Map.fromList [(Just "ghcmod",SL.toSortedList [])])
+    sendEmpty = publishDiagnostics maxToSend (J.toNormalizedUri file) Nothing (Map.fromList [(Just "ghcmod",SL.toSortedList [])])
     maxToSend = maxNumberOfProblems clientConfig
 
   let sendHlint = hlintOn clientConfig
@@ -929,13 +934,13 @@ requestDiagnosticsNormal tn file mVer = do
     let reql = GReq tn (Just file) (Just (file,ver)) Nothing callbackl
                  $ ApplyRefact.lintCmd' file
         callbackl (PublishDiagnosticsParams fp (List ds))
-             = sendOne "hlint" (fp, ds)
+             = sendOne "hlint" (J.toNormalizedUri fp, ds)
     makeRequest reql
 
   -- get GHC diagnostics and loads the typechecked module into the cache
   let reqg = GReq tn (Just file) (Just (file,ver)) Nothing callbackg
                $ HIE.setTypecheckedModule file
-      callbackg (pd, errs) = do
+      callbackg (HIE.Diagnostics pd, errs) = do
         forM_ errs $ \e -> do
           reactorSend $ NotShowMessage $
             fmServerShowMessageNotification J.MtError

stack-8.2.2.yaml

@@ -20,14 +20,14 @@ extra-deps:
 - ghc-exactprint-0.5.8.2
 - haddock-api-2.18.1
 - haddock-library-1.4.4
-- haskell-lsp-0.14.0.0
-- haskell-lsp-types-0.14.0.1
+- haskell-lsp-0.15.0.0
+- haskell-lsp-types-0.15.0.0
 - haskell-src-exts-1.21.0
 - haskell-src-exts-util-0.2.5
 - hlint-2.1.17 # last hlint supporting GHC 8.2
 - hoogle-5.0.17.9
 - hsimport-0.8.8
-- lsp-test-0.5.4.0
+- lsp-test-0.6.0.0
 - monad-dijkstra-0.1.1.2
 - pretty-show-1.8.2
 - rope-utf16-splay-0.3.1.0

stack-8.4.2.yaml

@@ -19,14 +19,14 @@ extra-deps:
 - ghc-lib-parser-8.8.0.20190424
 - haddock-api-2.20.0
 - haddock-library-1.6.0
-- haskell-lsp-0.14.0.0
-- haskell-lsp-types-0.14.0.1
+- haskell-lsp-0.15.0.0
+- haskell-lsp-types-0.15.0.0
 - haskell-src-exts-1.21.0
 - haskell-src-exts-util-0.2.5
 - hlint-2.1.24
 - hoogle-5.0.17.9
 - hsimport-0.10.0
-- lsp-test-0.5.4.0
+- lsp-test-0.6.0.0
 - monad-dijkstra-0.1.1.2
 - pretty-show-1.8.2
 - rope-utf16-splay-0.3.1.0