Use NormalizedFilePath and adapt types of haskell-lsp-0.21 (#479)

* Use custom version of h-l-t

* Use normalized path functions from h-l-t

* Restore empty path corner case

* Create a wrapper over NFP to override IsString

* Use maybe instead fromMaybe

* Use patched version of lsp-types in all yaml files

* Remove unused import

* Rename specific NormalizeFilePath to NormalizeFilePath'

* Remove specific newtype and IsString instance

* Use released haskell-lsp-0.21

* Adapt to type changes of haskell-lsp-0.21

* Add tags field to CompletionItem

* Fix test case about empty file path

* Correct stack.yaml used in azure ci cache

* Build ghcide including tests in windows azure ci

* Qualify haskell-lsp modules to avoid name clashes

Author: jneira

.azure/linux-stack.yml

@@ -17,7 +17,7 @@ jobs:
   - checkout: self
   - task: Cache@2
     inputs:
-      key: stack-cache-v2 | $(Agent.OS) | $(Build.SourcesDirectory)/stack.yaml | $(Build.SourcesDirectory)/ghcide.cabal
+      key: stack-cache-v2 | $(Agent.OS) | $(Build.SourcesDirectory)/$(STACK_YAML) | $(Build.SourcesDirectory)/ghcide.cabal
       path: .azure-cache
       cacheHitVar: CACHE_RESTORED
     displayName: "Cache stack artifacts"

.azure/windows-stack.yml

@@ -46,11 +46,9 @@ jobs:
       stack install alex --stack-yaml $STACK_YAML
       stack build --only-dependencies --stack-yaml $STACK_YAML
     displayName: 'stack build --only-dependencies'
-  - bash: stack test --ghc-options=-Werror --stack-yaml $STACK_YAML || stack test --ghc-options=-Werror --stack-yaml $STACK_YAML || stack test --ghc-options=-Werror --stack-yaml $STACK_YAML
-    # ghcide stack tests are flaky, see https://github.com/digital-asset/daml/issues/2606.
+  - bash: stack test --no-run-tests --ghc-options=-Werror --stack-yaml $STACK_YAML
     displayName: 'stack test --ghc-options=-Werror'
-    # TODO: Enable when failing tests are fixed or marked as broken. See https://github.com/digital-asset/ghcide/issues/474
-    condition: False
+    # TODO: run test suite when failing tests are fixed or marked as broken. See https://github.com/digital-asset/ghcide/issues/474
   - bash: |
       mkdir -p .azure-cache
       tar -vczf .azure-cache/stack-root.tar.gz $(cygpath $STACK_ROOT)

exe/Main.hs

@@ -146,8 +146,8 @@ main = do
         ide <- initialise def (cradleRules >> mainRule) (pure $ IdInt 0) (showEvent lock) (logger Info) noopDebouncer options vfs
 
         putStrLn "\nStep 6/6: Type checking the files"
-        setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath files
-        results <- runActionSync ide $ uses TypeCheck $ map toNormalizedFilePath files
+        setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath' files
+        results <- runActionSync ide $ uses TypeCheck $ map toNormalizedFilePath' files
         let (worked, failed) = partition fst $ zip (map isJust results) files
         when (failed /= []) $
             putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed
@@ -183,7 +183,7 @@ kick = do
 -- | Print an LSP event.
 showEvent :: Lock -> FromServerMessage -> IO ()
 showEvent _ (EventFileDiagnostics _ []) = return ()
-showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) =
+showEvent lock (EventFileDiagnostics (toNormalizedFilePath' -> file) diags) =
     withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags
 showEvent lock e = withLock lock $ print e
 
@@ -199,7 +199,7 @@ loadSession dir = liftIO $ do
     let session :: Maybe FilePath -> Action HscEnvEq
         session file = do
           -- In the absence of a cradle file, just pass the directory from where to calculate an implicit cradle
-          let cradle = toNormalizedFilePath $ fromMaybe dir file
+          let cradle = toNormalizedFilePath' $ fromMaybe dir file
           use_ LoadCradle cradle
     return $ \file -> session =<< liftIO (cradleLoc file)
 

exe/Rules.hs

@@ -36,8 +36,8 @@ import qualified System.Directory.Extra         as IO
 import           System.Environment             (lookupEnv)
 import           System.FilePath.Posix          (addTrailingPathSeparator,
                                                  (</>))
-import Language.Haskell.LSP.Messages as LSP
-import Language.Haskell.LSP.Types as LSP
+import qualified Language.Haskell.LSP.Messages  as LSP
+import qualified Language.Haskell.LSP.Types     as LSP
 import Data.Aeson (ToJSON(toJSON))
 import Development.IDE.Types.Logger (logDebug)
 

ghcide.cabal

@@ -43,8 +43,8 @@ library
         filepath,
         haddock-library >= 1.8,
         hashable,
-        haskell-lsp-types == 0.20.*,
-        haskell-lsp == 0.20.*,
+        haskell-lsp-types == 0.21.*,
+        haskell-lsp == 0.21.*,
         mtl,
         network-uri,
         prettyprinter-ansi-terminal,

src/Development/IDE/Core/Compile.hs

@@ -93,7 +93,7 @@ computePackageDeps
 computePackageDeps env pkg = do
     let dflags = hsc_dflags env
     case lookupInstalledPackage dflags pkg of
-        Nothing -> return $ Left [ideErrorText (toNormalizedFilePath noFilePath) $
+        Nothing -> return $ Left [ideErrorText (toNormalizedFilePath' noFilePath) $
             T.pack $ "unknown package: " ++ show pkg]
         Just pkgInfo -> return $ Right $ depends pkgInfo
 

src/Development/IDE/Core/FileExists.hs

@@ -146,9 +146,10 @@ fileExistsFast getLspId vfs file = do
                                   WorkspaceDidChangeWatchedFiles
                                   (Just (A.toJSON regOptions))
       regOptions =
-        DidChangeWatchedFilesRegistrationOptions { watchers = List [watcher] }
-      watcher = FileSystemWatcher { globPattern = fromNormalizedFilePath fp
-                                  , kind        = Just 5 -- Create and Delete events only
+        DidChangeWatchedFilesRegistrationOptions { _watchers = List [watcher] }
+      watchKind = WatchKind { _watchCreate = True, _watchChange = False, _watchDelete = True}
+      watcher = FileSystemWatcher { _globPattern = fromNormalizedFilePath fp
+                                  , _kind        = Just watchKind
                                   }
 
     eventer $ ReqRegisterCapability req
@@ -174,29 +175,3 @@ getFileExistsVFS vfs file = do
     handle (\(_ :: IOException) -> return False) $
         (isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^
         Dir.doesFileExist (fromNormalizedFilePath file)
-
---------------------------------------------------------------------------------------------------
--- The message definitions below probably belong in haskell-lsp-types
-
-data DidChangeWatchedFilesRegistrationOptions = DidChangeWatchedFilesRegistrationOptions
-    { watchers :: List FileSystemWatcher
-    }
-
-instance A.ToJSON DidChangeWatchedFilesRegistrationOptions where
-  toJSON DidChangeWatchedFilesRegistrationOptions {..} =
-    A.object ["watchers" A..= watchers]
-
-data FileSystemWatcher = FileSystemWatcher
-    { -- | The glob pattern to watch.
-      --   For details on glob pattern syntax, check the spec: https://microsoft.github.io/language-server-protocol/specifications/specification-3-14/#workspace_didChangeWatchedFiles
-      globPattern :: String
-        -- | The kind of event to subscribe to. Defaults to all.
-        --   Defined as a bitmap of Create(1), Change(2), and Delete(4)
-    , kind        :: Maybe Int
-    }
-
-instance A.ToJSON FileSystemWatcher where
-  toJSON FileSystemWatcher {..} =
-    A.object
-      $  ["globPattern" A..= globPattern]
-      ++ [ "kind" A..= x | Just x <- [kind] ]

src/Development/IDE/Core/Preprocessor.hs

@@ -96,7 +96,7 @@ data CPPDiag
 
 diagsFromCPPLogs :: FilePath -> [CPPLog] -> [FileDiagnostic]
 diagsFromCPPLogs filename logs =
-  map (\d -> (toNormalizedFilePath filename, ShowDiag, cppDiagToDiagnostic d)) $
+  map (\d -> (toNormalizedFilePath' filename, ShowDiag, cppDiagToDiagnostic d)) $
     go [] logs
   where
     -- On errors, CPP calls logAction with a real span for the initial log and
@@ -118,7 +118,8 @@ diagsFromCPPLogs filename logs =
           _code = Nothing,
           _source = Just "CPP",
           _message = T.unlines $ cdMessage d,
-          _relatedInformation = Nothing
+          _relatedInformation = Nothing,
+          _tags = Nothing
         }
 
 

src/Development/IDE/Core/Rules.hs

@@ -80,14 +80,14 @@ useE :: IdeRule k v => k -> NormalizedFilePath -> MaybeT Action v
 useE k = MaybeT . use k
 
 useNoFileE :: IdeRule k v => k -> MaybeT Action v
-useNoFileE k = useE k ""
+useNoFileE k = useE k emptyFilePath
 
 usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT Action [v]
 usesE k = MaybeT . fmap sequence . uses k
 
 defineNoFile :: IdeRule k v => (k -> Action v) -> Rules ()
 defineNoFile f = define $ \k file -> do
-    if file == "" then do res <- f k; return ([], Just res) else
+    if file == emptyFilePath then do res <- f k; return ([], Just res) else
         fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file"
 
 
@@ -130,7 +130,7 @@ getHieFile file mod = do
 getHomeHieFile :: NormalizedFilePath -> Action ([a], Maybe HieFile)
 getHomeHieFile f = do
   pm <- use_ GetParsedModule f
-  let normal_hie_f = toNormalizedFilePath hie_f
+  let normal_hie_f = toNormalizedFilePath' hie_f
       hie_f = ml_hie_file $ ms_location $ pm_mod_summary pm
   mbHieTimestamp <- use GetModificationTime normal_hie_f
   srcTimestamp   <- use_ GetModificationTime f
@@ -292,9 +292,10 @@ reportImportCyclesRule =
             , _message = "Cyclic module dependency between " <> showCycle mods
             , _code = Nothing
             , _relatedInformation = Nothing
+            , _tags = Nothing
             }
             where loc = srcSpanToLocation (getLoc imp)
-                  fp = toNormalizedFilePath $ srcSpanToFilename (getLoc imp)
+                  fp = toNormalizedFilePath' $ srcSpanToFilename (getLoc imp)
           getModuleName file = do
            pm <- use_ GetParsedModule file
            pure (moduleNameString . moduleName . ms_mod $ pm_mod_summary pm)

src/Development/IDE/Core/Shake.hs

@@ -414,7 +414,7 @@ shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts =
                             Right _ -> "completed"
                        profile = case res of
                             Right (_, Just fp) ->
-                                let link = case filePathToUri' $ toNormalizedFilePath fp of
+                                let link = case filePathToUri' $ toNormalizedFilePath' fp of
                                                 NormalizedUri _ x -> x
                                 in ", profile saved at " <> T.unpack link
                             _ -> ""
@@ -473,13 +473,13 @@ useWithStale :: IdeRule k v
 useWithStale key file = head <$> usesWithStale key [file]
 
 useNoFile :: IdeRule k v => k -> Action (Maybe v)
-useNoFile key = use key ""
+useNoFile key = use key emptyFilePath
 
 use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v
 use_ key file = head <$> uses_ key [file]
 
 useNoFile_ :: IdeRule k v => k -> Action v
-useNoFile_ key = use_ key ""
+useNoFile_ key = use_ key emptyFilePath
 
 uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v]
 uses_ key files = do
@@ -819,7 +819,7 @@ filterDiagnostics ::
     DiagnosticStore ->
     DiagnosticStore
 filterDiagnostics keep =
-    HMap.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath) $ uriToFilePath' $ fromNormalizedUri uri)
+    HMap.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath') $ uriToFilePath' $ fromNormalizedUri uri)
 
 filterVersionMap
     :: HMap.HashMap NormalizedUri (Set.Set TextDocumentVersion)

src/Development/IDE/GHC/Error.hs

@@ -40,14 +40,15 @@ import qualified Outputable                 as Out
 
 
 diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic
-diagFromText diagSource sev loc msg = (toNormalizedFilePath $ srcSpanToFilename loc,ShowDiag,)
+diagFromText diagSource sev loc msg = (toNormalizedFilePath' $ srcSpanToFilename loc,ShowDiag,)
     Diagnostic
     { _range    = srcSpanToRange loc
     , _severity = Just sev
     , _source   = Just diagSource -- not shown in the IDE, but useful for ghcide developers
     , _message  = msg
     , _code     = Nothing
     , _relatedInformation = Nothing
+    , _tags     = Nothing
     }
 
 -- | Produce a GHC-style error from a source span and a message.
@@ -80,7 +81,7 @@ srcSpanToFilename (RealSrcSpan real) = FS.unpackFS $ srcSpanFile real
 srcSpanToLocation :: SrcSpan -> Location
 srcSpanToLocation src =
   -- important that the URI's we produce have been properly normalized, otherwise they point at weird places in VS Code
-  Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath $ srcSpanToFilename src) (srcSpanToRange src)
+  Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' $ srcSpanToFilename src) (srcSpanToRange src)
 
 isInsideSrcSpan :: Position -> SrcSpan -> Bool
 p `isInsideSrcSpan` r = sp <= p && p <= ep

src/Development/IDE/GHC/Util.hs

@@ -139,7 +139,7 @@ moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) pm
     -- A for module A.B
     modDir =
         takeDirectory $
-        fromNormalizedFilePath $ toNormalizedFilePath $
+        fromNormalizedFilePath $ toNormalizedFilePath' $
         moduleNameSlashes $ GHC.moduleName mod'
 
 -- | An 'HscEnv' with equality. Two values are considered equal

src/Development/IDE/Import/FindImports.hs

@@ -58,7 +58,7 @@ locateModuleFile :: MonadIO m
              -> m (Maybe NormalizedFilePath)
 locateModuleFile dflags exts doesExist isSource modName = do
   let candidates =
-        [ toNormalizedFilePath (prefix </> M.moduleNameSlashes modName <.> maybeBoot ext)
+        [ toNormalizedFilePath' (prefix </> M.moduleNameSlashes modName <.> maybeBoot ext)
            | prefix <- importPaths dflags, ext <- exts]
   findM doesExist candidates
   where

src/Development/IDE/LSP/HoverDefinition.hs

@@ -55,7 +55,7 @@ request label getResults notFound found ide (TextDocumentPositionParams (TextDoc
 
 logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> Action b) -> IdeState -> Position -> String -> IO b
 logAndRunRequest label getResults ide pos path = do
-  let filePath = toNormalizedFilePath path
+  let filePath = toNormalizedFilePath' path
   logInfo (ideLogger ide) $
     label <> " request at position " <> T.pack (showPosition pos) <>
     " in file: " <> T.pack path

src/Development/IDE/LSP/Notifications.hs

@@ -30,7 +30,7 @@ import           Development.IDE.Core.OfInterest
 
 
 whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()
-whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath
+whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath'
 
 setHandlersNotifications :: PartialHandlers c
 setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x
@@ -62,7 +62,7 @@ setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x
             let events =
                     mapMaybe
                         (\(FileEvent uri ev) ->
-                            (, ev /= FcDeleted) . toNormalizedFilePath
+                            (, ev /= FcDeleted) . toNormalizedFilePath'
                             <$> LSP.uriToFilePath uri
                         )
                         ( F.toList fileEvents )

src/Development/IDE/LSP/Outline.hs

@@ -37,7 +37,7 @@ moduleOutline
   :: LSP.LspFuncs c -> IdeState -> DocumentSymbolParams -> IO (Either ResponseError DSResult)
 moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentIdentifier uri }
   = case uriToFilePath uri of
-    Just (toNormalizedFilePath -> fp) -> do
+    Just (toNormalizedFilePath' -> fp) -> do
       mb_decls <- runAction ideState $ use GetParsedModule fp
       pure $ Right $ case mb_decls of
         Nothing -> DSDocumentSymbols (List [])

src/Development/IDE/Plugin/CodeAction.hs

@@ -64,7 +64,7 @@ codeAction lsp state (TextDocumentIdentifier uri) _range CodeActionContext{_diag
     -- logInfo (ideLogger ide) $ T.pack $ "Code action req: " ++ show arg
     contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
     let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents
-        mbFile = toNormalizedFilePath <$> uriToFilePath uri
+        mbFile = toNormalizedFilePath' <$> uriToFilePath uri
     (ideOptions, parsedModule, join -> env) <- runAction state $
       (,,) <$> getIdeOptions
             <*> getParsedModule `traverse` mbFile
@@ -85,7 +85,7 @@ codeLens
     -> IO (Either ResponseError (List CodeLens))
 codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do
     fmap (Right . List) $ case uriToFilePath' uri of
-      Just (toNormalizedFilePath -> filePath) -> do
+      Just (toNormalizedFilePath' -> filePath) -> do
         _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath
         diag <- getDiagnostics ideState
         hDiag <- getHiddenDiagnostics ideState

src/Development/IDE/Plugin/Completions.hs

@@ -66,7 +66,7 @@ getCompletionsLSP lsp ide
     contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
     fmap Right $ case (contents, uriToFilePath' uri) of
       (Just cnts, Just path) -> do
-        let npath = toNormalizedFilePath path
+        let npath = toNormalizedFilePath' path
         (ideOpts, compls) <- runAction ide $ do
             opts <- getIdeOptions
             compls <- useWithStale ProduceCompletions npath

src/Development/IDE/Plugin/Completions/Logic.hs

@@ -132,7 +132,7 @@ occNameToComKind ty oc
 
 mkCompl :: IdeOptions -> CompItem -> CompletionItem
 mkCompl IdeOptions{..} CI{origName,importedFrom,thingType,label,isInfix,docs} =
-  CompletionItem label kind ((colon <>) <$> typeText)
+  CompletionItem label kind (List []) ((colon <>) <$> typeText)
     (Just $ CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator docs')
     Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)
     Nothing Nothing Nothing Nothing Nothing
@@ -186,27 +186,27 @@ getArgText typ = argText
 
 mkModCompl :: T.Text -> CompletionItem
 mkModCompl label =
-  CompletionItem label (Just CiModule) Nothing
+  CompletionItem label (Just CiModule) (List []) Nothing
     Nothing Nothing Nothing Nothing Nothing Nothing Nothing
     Nothing Nothing Nothing Nothing Nothing
 
 mkImportCompl :: T.Text -> T.Text -> CompletionItem
 mkImportCompl enteredQual label =
-  CompletionItem m (Just CiModule) (Just label)
+  CompletionItem m (Just CiModule) (List []) (Just label)
     Nothing Nothing Nothing Nothing Nothing Nothing Nothing
     Nothing Nothing Nothing Nothing Nothing
   where
     m = fromMaybe "" (T.stripPrefix enteredQual label)
 
 mkExtCompl :: T.Text -> CompletionItem
 mkExtCompl label =
-  CompletionItem label (Just CiKeyword) Nothing
+  CompletionItem label (Just CiKeyword) (List []) Nothing
     Nothing Nothing Nothing Nothing Nothing Nothing Nothing
     Nothing Nothing Nothing Nothing Nothing
 
 mkPragmaCompl :: T.Text -> T.Text -> CompletionItem
 mkPragmaCompl label insertText =
-  CompletionItem label (Just CiKeyword) Nothing
+  CompletionItem label (Just CiKeyword) (List []) Nothing
     Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)
     Nothing Nothing Nothing Nothing Nothing
 

src/Development/IDE/Types/Diagnostics.hs

@@ -38,7 +38,8 @@ ideErrorText fp msg = (fp, ShowDiag, LSP.Diagnostic {
     _code = Nothing,
     _source = Just "compiler",
     _message = msg,
-    _relatedInformation = Nothing
+    _relatedInformation = Nothing,
+    _tags = Nothing
     })
 
 -- | Defines whether a particular diagnostic should be reported