Escape colons in URIs to be consistent with VSCode (#1504)

The details are described in a comment but the short story is
that a roundtrip Uri -> FilePath -> Uri necessarily loses information
on which characters were escaped. The long-term solution here is to
avoid this roundtrip altogether but this at least fixes the issue for
now.

BUILD.bazel

@@ -19,6 +19,7 @@ depends = [
     "haskell-lsp",
     "haskell-lsp-types",
     "mtl",
+    "network-uri",
     "pretty",
     "rope-utf16-splay",
     "safe-exceptions",

src/Development/IDE/Functions/GHCError.hs

@@ -38,7 +38,6 @@ import Data.Maybe
 import           ErrUtils
 import           SrcLoc
 import qualified Outputable                 as Out
-import qualified Language.Haskell.LSP.Types as LSP
 
 
 
@@ -79,7 +78,7 @@ srcSpanToFilename (RealSrcSpan real) = FS.unpackFS $ srcSpanFile real
 
 srcSpanToLocation :: SrcSpan -> Location
 srcSpanToLocation src =
-  Location (LSP.filePathToUri $ srcSpanToFilename src) (srcSpanToRange src)
+  Location (D.filePathToUri' $ srcSpanToFilename src) (srcSpanToRange src)
 
 -- | Convert a GHC severity to a DAML compiler Severity. Severities below
 -- "Warning" level are dropped (returning Nothing).

src/Development/IDE/State/FileStore.hs

@@ -96,7 +96,7 @@ getFileExistsRule vfs =
     defineEarlyCutoff $ \GetFileExists file -> do
         alwaysRerun
         res <- liftIO $ handle (\(_ :: IOException) -> return False) $
-            (isJust <$> getVirtualFile vfs (filePathToUri file)) ||^
+            (isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^
             Dir.doesFileExist file
         return (Just $ if res then BS.singleton '1' else BS.empty, ([], Just res))
 
@@ -109,7 +109,7 @@ getModificationTimeRule vfs =
     defineEarlyCutoff $ \GetModificationTime file -> do
         let wrap time = (Just $ BS.pack $ showTimePrecise time, ([], Just $ ModificationTime time))
         alwaysRerun
-        mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri file
+        mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file
         case mbVirtual of
             Just (VirtualFile ver _ _) -> pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))
             Nothing -> liftIO $ fmap wrap (Dir.getModificationTime file) `catch` \(e :: IOException) -> do
@@ -124,7 +124,7 @@ getFileContentsRule vfs =
         -- need to depend on modification time to introduce a dependency with Cutoff
         time <- use_ GetModificationTime file
         res <- liftIO $ ideTryIOException file $ do
-            mbVirtual <- getVirtualFile vfs $ filePathToUri file
+            mbVirtual <- getVirtualFile vfs $ filePathToUri' file
             case mbVirtual of
                 Just (VirtualFile _ rope _) -> return $ textToStringBuffer $ Rope.toText rope
                 Nothing -> hGetStringBuffer file
@@ -157,8 +157,8 @@ setBufferModified :: IdeState -> FilePath -> Maybe T.Text -> IO ()
 setBufferModified state absFile mbContents = do
     VFSHandle{..} <- getIdeGlobalState state
     case mbContents of
-        Nothing -> removeVirtualFile (filePathToUri absFile)
-        Just contents -> setVirtualFileContents (filePathToUri absFile) contents
+        Nothing -> removeVirtualFile (filePathToUri' absFile)
+        Just contents -> setVirtualFileContents (filePathToUri' absFile) contents
     void $ shakeRun state []
 
 

src/Development/IDE/Types/Diagnostics.hs

@@ -28,7 +28,7 @@ module Development.IDE.Types.Diagnostics (
   showDiagnostics,
   showDiagnosticsColored,
   defDiagnostic,
-  filePathToUri,
+  filePathToUri',
   uriToFilePath',
   ProjectDiagnostics,
   emptyDiagnostics,
@@ -47,6 +47,7 @@ import qualified Data.Map as Map
 import qualified Data.Text as T
 import Data.Text.Prettyprint.Doc.Syntax
 import qualified Data.SortedList as SL
+import Network.URI (escapeURIString)
 import qualified Text.PrettyPrint.Annotated.HughesPJClass as Pretty
 import qualified Language.Haskell.LSP.Types as LSP
 import Language.Haskell.LSP.Types as LSP (
@@ -67,9 +68,21 @@ import Development.IDE.Types.Location
 -- So we have our own wrapper here that supports empty filepaths.
 uriToFilePath' :: Uri -> Maybe FilePath
 uriToFilePath' uri
-    | uri == filePathToUri "" = Just ""
+    | uri == filePathToUri' "" = Just ""
     | otherwise = LSP.uriToFilePath uri
 
+-- TODO This is a temporary hack: VSCode escapes ':' in URIs while haskell-lsp’s filePathToUri doesn't.
+-- This causes issues since haskell-lsp stores the original URI in the VFS while we roundtrip once via
+-- uriToFilePath' and filePathToUri before we look it up again. At that point : will be unescaped in the URI
+-- so the lookup fails. The long-term solution here is to avoid roundtripping URIs but that is a larger task
+-- so for now we have our own version of filePathToUri that does escape colons.
+filePathToUri' :: FilePath -> Uri
+filePathToUri' fp =
+    case T.stripPrefix "file:" (getUri uri) of
+        Just suffix -> Uri $ T.pack $ "file:" <> escapeURIString (/= ':') (T.unpack suffix)
+        Nothing -> uri
+    where uri = filePathToUri fp
+
 ideErrorText :: FilePath -> T.Text -> FileDiagnostic
 ideErrorText fp = errorDiag fp "Ide Error"