make hls speak websocket

exe/Wrapper.hs

@@ -1,4 +1,4 @@
 {-# LANGUAGE CPP               #-}
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -98,7 +98,7 @@
             Left err -> do
               T.hPutStrLn stderr (prettyError err NoShorten)
               case args of
-                Ghcide (GhcideArguments { argsCommand = Main.LSP }) ->
+                Ghcide (GhcideArguments { argsCommand = Main.LSP Main.StdIO }) ->
                     launchErrorLSP recorder (prettyError err Shorten)
 
                 _ -> exitFailure
@@ -274,10 +274,6 @@
   cwd <- getCurrentDirectory
   let defaultArguments = Main.defaultArguments (cmapWithPrio pretty recorder) cwd (IdePlugins [])
 
-  inH <- Main.argsHandleIn defaultArguments
-
-  outH <- Main.argsHandleOut defaultArguments
-
   let parseConfig cfg _ = Right cfg
       onConfigChange _ = pure ()
 
@@ -302,14 +298,16 @@
         let interpretHandler (env,  _st) = LSP.Iso (LSP.runLspT env . unErrorLSPM) liftIO
         pure (doInitialize, asyncHandlers, interpretHandler)
 
-  runLanguageServer (cmapWithPrio pretty recorder)
-    (Main.argsLspOptions defaultArguments)
-    inH
-    outH
-    (Main.argsDefaultHlsConfig defaultArguments)
-    parseConfig
-    onConfigChange
-    setup
+  let runServerWithCommunication comm =
+          runLanguageServer (cmapWithPrio pretty recorder)
+            (Main.argsLspOptions defaultArguments)
+            comm
+            (Main.argsDefaultHlsConfig defaultArguments)
+            parseConfig
+            onConfigChange
+            setup
+
+  Main.commKindToCommunication (cmapWithPrio pretty recorder) runServerWithCommunication Main.StdIO
 
 exitHandler :: IO () -> LSP.Handlers (ErrorLSPM c)
 exitHandler exit = LSP.notificationHandler SMethod_Exit $ const $ liftIO exit

flake.nix

@@ -66,9 +66,11 @@
           # This removes a rebuild with a different GHC version. The drawback of
           # this approach is that our shell may pull two GHC versions in scope.
           buildInputs = [
+            hpkgs.haskell-language-server
             # Compiler toolchain
             hpkgs.ghc
             hpkgs.haskell-language-server
+            pkgs.stack
             pkgs.haskellPackages.cabal-install
             # Dependencies needed to build some parts of Hackage
             gmp zlib ncurses

ghcide-test/exe/Progress.hs

@@ -4,7 +4,7 @@ module Progress (tests) where
 import           Control.Concurrent.STM
 import           Data.Foldable                          (for_)
 import qualified Data.HashMap.Strict                    as Map
-import           Development.IDE                        (NormalizedFilePath)
+import           Development.IDE
 import           Development.IDE.Core.ProgressReporting
 import qualified "list-t" ListT
 import qualified StmContainers.Map                      as STM
@@ -18,7 +18,7 @@ tests = testGroup "Progress"
 
 data InProgressModel = InProgressModel {
     done, todo :: Int,
-    current    :: Map.HashMap NormalizedFilePath Int
+    current    :: Map.HashMap NormalizedUri Int
 }
 
 reportProgressTests :: TestTree
@@ -30,10 +30,11 @@ reportProgressTests = testGroup "recordProgress"
     ]
     where
         p0 = pure $ InProgressModel 0 0 mempty
-        addNew = recordProgressModel "A" succ p0
-        increase = recordProgressModel "A" succ addNew
-        decrease = recordProgressModel "A" succ increase
-        done = recordProgressModel "A" pred decrease
+        aUri = filePathToUri' "A"
+        addNew = recordProgressModel aUri succ p0
+        increase = recordProgressModel aUri succ addNew
+        decrease = recordProgressModel aUri succ increase
+        done = recordProgressModel aUri pred decrease
         recordProgressModel key change state =
             model state $ \st -> recordProgress st key change
         model stateModelIO k = do

ghcide-test/exe/UnitTests.hs

@@ -51,7 +51,7 @@ tests = do
          let uri = Uri "file://"
          uriToFilePath' uri @?= Just ""
      , testCase "showDiagnostics prints ranges 1-based (like vscode)" $ do
-         let diag = Diagnostics.FileDiagnostic "" Diagnostics.ShowDiag Diagnostic
+         let diag = Diagnostics.FileDiagnostic (filePathToUri' "") Diagnostics.ShowDiag Diagnostic
                {  _codeDescription = Nothing
                 , _data_ = Nothing
                 , _range = Range

ghcide/exe/Arguments.hs

@@ -4,7 +4,8 @@
 module Arguments(Arguments(..), getArguments) where
 
 import           Development.IDE      (IdeState)
-import           Development.IDE.Main (Command (..), commandP)
+import           Development.IDE.Main (Command (..), CommunicationKind (..),
+                                       commandP)
 import           Ide.Types            (IdePlugins)
 import           Options.Applicative
 
@@ -44,4 +45,4 @@ arguments plugins = Arguments
       <*> switch (long "conservative-change-tracking" <> help "disable reactive change tracking (for testing/debugging)")
       where
           checkCommand = Check <$> many (argument str (metavar "FILES/DIRS..."))
-          lspCommand = LSP <$ flag' True (long "lsp" <> help "Start talking to an LSP client")
+          lspCommand = LSP StdIO <$ flag' True (long "lsp" <> help "Start talking to an LSP client")

ghcide/ghcide.cabal

@@ -51,6 +51,7 @@ library
     , bytestring
     , case-insensitive
     , co-log-core
+    , websockets
     , containers
     , cryptohash-sha1              >=0.11.100 && <0.12
     , data-default

ghcide/session-loader/Development/IDE/Session.hs

@@ -138,7 +138,7 @@
   | LogHieDbWriterThreadSQLiteError !SQLError
   | LogHieDbWriterThreadException !SomeException
   | LogInterfaceFilesCacheDir !FilePath
-  | LogKnownFilesUpdated !(HashMap Target (HashSet NormalizedFilePath))
+  | LogKnownFilesUpdated !(HashMap Target (HashSet NormalizedUri))
   | LogMakingNewHscEnv ![UnitId]
   | LogDLLLoadError !String
   | LogCradlePath !FilePath
@@ -199,7 +199,7 @@
       nest 2 $
         vcat
           [ "Known files updated:"
-          , viaShow $ (HM.map . Set.map) fromNormalizedFilePath targetToPathsMap
+          , viaShow $ (HM.map . Set.map) fromNormalizedUri targetToPathsMap
           ]
     LogMakingNewHscEnv inPlaceUnitIds ->
       "Making new HscEnv. In-place unit ids:" <+> pretty (map show inPlaceUnitIds)
@@ -477,13 +477,13 @@
                 -- 'TargetFile Foo.hs' in the 'knownTargetsVar', thus not find 'TargetFile Foo.hs-boot'
                 -- and also not find 'TargetModule Foo'.
                 fs <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations
-                pure $ map (\fp -> (TargetFile fp, Set.singleton fp)) (nubOrd (f:fs))
+                pure $ map (\fp -> (TargetFile fp, Set.singleton $ filePathToUri' fp)) (nubOrd (f:fs))
               TargetModule _ -> do
                 found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations
-                return [(targetTarget, Set.fromList found)]
+                return [(targetTarget, Set.fromList $ map filePathToUri' found)]
           hasUpdate <- atomically $ do
             known <- readTVar knownTargetsVar
-            let known' = flip mapHashed known $ \k -> unionKnownTargets k (mkKnownTargets knownTargets)
+            let known' = flip mapHashed known $ \k -> unionKnownTargets k (mkKnownTargets $ knownTargets)
                 hasUpdate = if known /= known' then Just (unhashed known') else Nothing
             writeTVar knownTargetsVar known'
             pure hasUpdate
@@ -567,7 +567,7 @@
                         this_target_details = TargetDetails (TargetFile _cfp) this_error_env this_dep_info [_cfp]
                         this_flags = (this_error_env, this_dep_info)
                         this_error_env = ([this_error], Nothing)
-                        this_error = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) _cfp
+                        this_error = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) (filePathToUri' _cfp)
                                        (T.unlines
                                          [ "No cradle target found. Is this file listed in the targets of your cradle?"
                                          , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section"
@@ -588,8 +588,8 @@
           unless (null new_deps || not checkProject) $ do
                 cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets)
                 void $ shakeEnqueue extras $ mkDelayedAction "InitialLoad" Debug $ void $ do
-                    mmt <- uses GetModificationTime cfps'
-                    let cs_exist = catMaybes (zipWith (<$) cfps' mmt)
+                    mmt <- uses GetModificationTime $ map filePathToUri' cfps'
+                    let cs_exist = mapMaybe (fmap filePathToUri') (zipWith (<$) cfps' mmt)
                     modIfaces <- uses GetModIface cs_exist
                     -- update exports map
                     shakeExtras <- getShakeExtras
@@ -629,7 +629,7 @@
                  [] -> error $ "GHC version could not be parsed: " <> version
                  ((runTime, _):_)
                    | compileTime == runTime -> do
                      atomicModifyIORef' cradle_files (\xs -> (cfp:xs,()))
                      session (hieYaml, toNormalizedFilePath' cfp, opts, libDir)
                    | otherwise -> return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[])
              -- Failure case, either a cradle error or the none cradle
@@ -888,7 +888,7 @@
     let closure_errs = maybeToList $ checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv')
         closure_err_to_multi_err err =
             ideErrorWithSource
-                (Just "cradle") (Just DiagnosticSeverity_Warning) _cfp
+                (Just "cradle") (Just DiagnosticSeverity_Warning) (filePathToUri' _cfp)
                 (T.pack (Compat.printWithoutUniques (singleMessage err)))
                 (Just (fmap GhcDriverMessage err))
         multi_errs = map closure_err_to_multi_err closure_errs
@@ -896,7 +896,7 @@
             x <- map errMsgDiagnostic closure_errs
             DriverHomePackagesNotClosed us <- pure x
             pure us
         isBad ci = (homeUnitId_ (componentDynFlags ci)) `OS.member` bad_units
     -- Whenever we spin up a session on Linux, dynamically load libm.so.6
     -- in. We need this in case the binary is statically linked, in which
     -- case the interactive session will fail when trying to load
@@ -1255,4 +1255,4 @@
 
 renderPackageSetupException :: FilePath -> PackageSetupException -> FileDiagnostic
 renderPackageSetupException fp e =
-  ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException e) Nothing
+  ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) (filePathToUri' $ toNormalizedFilePath' fp) (T.pack $ showPackageSetupException e) Nothing

ghcide/session-loader/Development/IDE/Session/Diagnostics.hs

@@ -1,4 +1,4 @@
 {-# LANGUAGE DeriveAnyClass #-}
 
 module Development.IDE.Session.Diagnostics where
 import           Control.Applicative
@@ -30,7 +30,7 @@
 renderCradleError :: CradleError -> Cradle a -> NormalizedFilePath -> FileDiagnostic
 renderCradleError cradleError cradle nfp =
   let noDetails =
-        ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp (T.unlines $ map T.pack userFriendlyMessage) Nothing
+        ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) (filePathToUri' nfp) (T.unlines $ map T.pack userFriendlyMessage) Nothing
   in
   if HieBios.isCabalCradle cradle
      then noDetails & fdLspDiagnosticL %~ \diag -> diag{_data_ = Just $ Aeson.toJSON CradleErrorDetails{cabalProjectFiles=absDeps}}
@@ -89,7 +89,7 @@
     surround start s end = do
       guard (listToMaybe s == Just start)
       guard (listToMaybe (reverse s) == Just end)
       pure $ drop 1 $ take (length s - 1) s
 
 multiCradleErrMessage :: MultiCradleErr -> [String]
 multiCradleErrMessage e =

ghcide/src/Development/IDE/Core/Actions.hs

@@ -30,9 +30,7 @@ import           Development.IDE.Types.HscEnvEq       (hscEnv)
 import           Development.IDE.Types.Location
 import qualified HieDb
 import           Language.LSP.Protocol.Types          (DocumentHighlight (..),
-                                                       SymbolInformation (..),
-                                                       normalizedFilePathToUri,
-                                                       uriToNormalizedFilePath)
+                                                       SymbolInformation (..))
 
 
 -- | Eventually this will lookup/generate URIs for files in dependencies, but not in the
@@ -55,14 +53,14 @@ lookupMod _dbchan _hie_f _mod _uid _boot = MaybeT $ pure Nothing
 -- block waiting for the rule to be properly computed.
 
 -- | Try to get hover text for the name under point.
-getAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe (Maybe Range, [T.Text]))
-getAtPoint file pos = runMaybeT $ do
+getAtPoint :: NormalizedUri -> Position -> IdeAction (Maybe (Maybe Range, [T.Text]))
+getAtPoint uri pos = runMaybeT $ do
   ide <- ask
   opts <- liftIO $ getIdeOptionsIO ide
 
-  (hf, mapping) <- useWithStaleFastMT GetHieAst file
-  env <- hscEnv . fst <$> useWithStaleFastMT GhcSession file
-  dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> runMaybeT (useWithStaleFastMT GetDocMap file)
+  (hf, mapping) <- useWithStaleFastMT GetHieAst uri
+  env <- hscEnv . fst <$> useWithStaleFastMT GhcSession uri
+  dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> runMaybeT (useWithStaleFastMT GetDocMap uri)
 
   !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
   MaybeT $ liftIO $ fmap (first (toCurrentRange mapping =<<)) <$> AtPoint.atPoint opts hf dkMap env pos'
@@ -71,79 +69,78 @@ getAtPoint file pos = runMaybeT $ do
 -- taking into account changes that may have occurred due to edits.
 toCurrentLocation
   :: PositionMapping
-  -> NormalizedFilePath
+  -> NormalizedUri
   -> Location
   -> IdeAction (Maybe Location)
-toCurrentLocation mapping file (Location uri range) =
+toCurrentLocation mapping uri (Location locUri locRange) =
   -- The Location we are going to might be in a different
   -- file than the one we are calling gotoDefinition from.
   -- So we check that the location file matches the file
   -- we are in.
-  if nUri == normalizedFilePathToUri file
+  if nUri == uri
   -- The Location matches the file, so use the PositionMapping
   -- we have.
-  then pure $ Location uri <$> toCurrentRange mapping range
+  then pure $ Location locUri <$> toCurrentRange mapping locRange
   -- The Location does not match the file, so get the correct
   -- PositionMapping and use that instead.
   else do
     otherLocationMapping <- fmap (fmap snd) $ runMaybeT $ do
-      otherLocationFile <- MaybeT $ pure $ uriToNormalizedFilePath nUri
-      useWithStaleFastMT GetHieAst otherLocationFile
-    pure $ Location uri <$> (flip toCurrentRange range =<< otherLocationMapping)
+      useWithStaleFastMT GetHieAst nUri
+    pure $ Location locUri <$> (flip toCurrentRange locRange =<< otherLocationMapping)
   where
     nUri :: NormalizedUri
-    nUri = toNormalizedUri uri
+    nUri = toNormalizedUri locUri
 
 -- | Goto Definition.
-getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [(Location, Identifier)])
-getDefinition file pos = runMaybeT $ do
+getDefinition :: NormalizedUri -> Position -> IdeAction (Maybe [(Location, Identifier)])
+getDefinition uri pos = runMaybeT $ do
     ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask
     opts <- liftIO $ getIdeOptionsIO ide
-    (hf, mapping) <- useWithStaleFastMT GetHieAst file
-    (ImportMap imports, _) <- useWithStaleFastMT GetImportMap file
+    (hf, mapping) <- useWithStaleFastMT GetHieAst uri
+    (ImportMap imports, _) <- useWithStaleFastMT GetImportMap uri
     !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos)
     locationsWithIdentifier <- AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos'
     mapMaybeM (\(location, identifier) -> do
-      fixedLocation <- MaybeT $ toCurrentLocation mapping file location
+      fixedLocation <- MaybeT $ toCurrentLocation mapping uri location
       pure $ Just (fixedLocation, identifier)
       ) locationsWithIdentifier
 
 
-getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [(Location, Identifier)])
-getTypeDefinition file pos = runMaybeT $ do
+getTypeDefinition :: NormalizedUri -> Position -> IdeAction (Maybe [(Location, Identifier)])
+getTypeDefinition uri pos = runMaybeT $ do
     ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask
     opts <- liftIO $ getIdeOptionsIO ide
-    (hf, mapping) <- useWithStaleFastMT GetHieAst file
+    (hf, mapping) <- useWithStaleFastMT GetHieAst uri
     !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
     locationsWithIdentifier <- AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos'
     mapMaybeM (\(location, identifier) -> do
-      fixedLocation <- MaybeT $ toCurrentLocation mapping file location
+      fixedLocation <- MaybeT $ toCurrentLocation mapping uri location
       pure $ Just (fixedLocation, identifier)
       ) locationsWithIdentifier
 
-getImplementationDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location])
-getImplementationDefinition file pos = runMaybeT $ do
+getImplementationDefinition :: NormalizedUri -> Position -> IdeAction (Maybe [Location])
+getImplementationDefinition uri pos = runMaybeT $ do
     ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask
     opts <- liftIO $ getIdeOptionsIO ide
-    (hf, mapping) <- useWithStaleFastMT GetHieAst file
+    (hf, mapping) <- useWithStaleFastMT GetHieAst uri
     !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos)
     locs <- AtPoint.gotoImplementation withHieDb (lookupMod hiedbWriter) opts hf pos'
-    traverse (MaybeT . toCurrentLocation mapping file) locs
+    traverse (MaybeT . toCurrentLocation mapping uri) locs
 
-highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight])
-highlightAtPoint file pos = runMaybeT $ do
-    (HAR _ hf rf _ _,mapping) <- useWithStaleFastMT GetHieAst file
+highlightAtPoint :: NormalizedUri -> Position -> IdeAction (Maybe [DocumentHighlight])
+highlightAtPoint uri pos = runMaybeT $ do
+    (HAR _ hf rf _ _,mapping) <- useWithStaleFastMT GetHieAst uri
     !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
     let toCurrentHighlight (DocumentHighlight range t) = flip DocumentHighlight t <$> toCurrentRange mapping range
     mapMaybe toCurrentHighlight <$>AtPoint.documentHighlight hf rf pos'
 
 -- Refs are not an IDE action, so it is OK to be slow and (more) accurate
-refsAtPoint :: NormalizedFilePath -> Position -> Action [Location]
-refsAtPoint file pos = do
+refsAtPoint :: NormalizedUri -> Position -> Action [Location]
+refsAtPoint uri pos = do
     ShakeExtras{withHieDb} <- getShakeExtras
     fs <- HM.keys <$> getFilesOfInterestUntracked
     asts <- HM.fromList . mapMaybe sequence . zip fs <$> usesWithStale GetHieAst fs
-    AtPoint.referencesAtPoint withHieDb file pos (AtPoint.FOIReferences asts)
+    AtPoint.referencesAtPoint withHieDb uri pos (AtPoint.BOIReferences asts)
 
 workspaceSymbols :: T.Text -> IdeAction (Maybe [SymbolInformation])
 workspaceSymbols query = runMaybeT $ do