[chore] some more fixes to URI handling and bug fix for dropping MVar

Author: MangoIV

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

@@ -1125,43 +1125,44 @@ getModSummaryFromImports env uri _modTime mContents = do
     liftIO $ evaluate $ rnf textualImports
 
 
-    case uriToFilePath' uri of
-      Nothing -> do
-        let nuri = toNormalizedUri uri
-        throwError [ideErrorText nuri $ "Uri is not a file uri: " <> getUri uri]
-      Just file -> do
-        modLoc <- liftIO $ if mod == mAIN_NAME
-            -- specially in tests it's common to have lots of nameless modules
-            -- mkHomeModLocation will map them to the same hi/hie locations
-            then mkHomeModLocation dflags (pathToModuleName uri) file
-            else mkHomeModLocation dflags mod file
-
-        let modl = mkHomeModule (hscHomeUnit ppEnv) mod
-            sourceType = if "-boot" `isSuffixOf` takeExtension file then HsBootFile else HsSrcFile
-            msrModSummary =
-                ModSummary
-                    { ms_mod          = modl
-                    , ms_hie_date     = Nothing
-                    , ms_dyn_obj_date    = Nothing
-                    , ms_ghc_prim_import = ghc_prim_import
-                    , ms_hs_hash      = _src_hash
-
-                    , ms_hsc_src      = sourceType
-                    -- The contents are used by the GetModSummary rule
-                    , ms_hspp_buf     = Just contents
-                    , ms_hspp_file    = file
-                    , ms_hspp_opts    = dflags
-                    , ms_iface_date   = Nothing
-                    , ms_location     = withBootSuffix sourceType modLoc
-                    , ms_obj_date     = Nothing
-                    , ms_parsed_mod   = Nothing
-                    , ms_srcimps      = srcImports
-                    , ms_textual_imps = textualImports
-                    }
-
-        msrFingerprint <- liftIO $ computeFingerprint file opts msrModSummary
-        msrHscEnv <- liftIO $ Loader.initializePlugins (hscSetFlags (ms_hspp_opts msrModSummary) ppEnv)
-        return ModSummaryResult{..}
+    -- NOTE: thisis pretty bad as it relies on the prepropcessors not actually reading from a file when it's not needed
+    when (isNothing (uriToFilePath' uri) && isNothing mContents) $ do
+      throwError [ideErrorText (toNormalizedUri uri) $ "Uri is not a file uri: " <> getUri uri]
+
+    let file = T.unpack $ getUri uri
+
+    modLoc <- liftIO $ if mod == mAIN_NAME
+        -- specially in tests it's common to have lots of nameless modules
+        -- mkHomeModLocation will map them to the same hi/hie locations
+        then mkHomeModLocation dflags (pathToModuleName uri) file
+        else mkHomeModLocation dflags mod file
+
+    let modl = mkHomeModule (hscHomeUnit ppEnv) mod
+        sourceType = if "-boot" `isSuffixOf` takeExtension file then HsBootFile else HsSrcFile
+        msrModSummary =
+            ModSummary
+                { ms_mod          = modl
+                , ms_hie_date     = Nothing
+                , ms_dyn_obj_date    = Nothing
+                , ms_ghc_prim_import = ghc_prim_import
+                , ms_hs_hash      = _src_hash
+
+                , ms_hsc_src      = sourceType
+                -- The contents are used by the GetModSummary rule
+                , ms_hspp_buf     = Just contents
+                , ms_hspp_file    = file
+                , ms_hspp_opts    = dflags
+                , ms_iface_date   = Nothing
+                , ms_location     = withBootSuffix sourceType modLoc
+                , ms_obj_date     = Nothing
+                , ms_parsed_mod   = Nothing
+                , ms_srcimps      = srcImports
+                , ms_textual_imps = textualImports
+                }
+
+    msrFingerprint <- liftIO $ computeFingerprint file opts msrModSummary
+    msrHscEnv <- liftIO $ Loader.initializePlugins (hscSetFlags (ms_hspp_opts msrModSummary) ppEnv)
+    return ModSummaryResult{..}
     where
         -- Compute a fingerprint from the contents of `ModSummary`,
         -- eliding the timestamps, the preprocessed source and other non relevant fields

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

@@ -16,6 +16,7 @@ import           Language.LSP.Protocol.Types       (uriToFilePath)
 import           Control.DeepSeq                   (NFData (rnf))
 import           Control.Exception                 (evaluate)
 import           Control.Exception.Safe            (catch, throw)
+import           Control.Monad                     (when)
 import           Control.Monad.Except              (throwError)
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Except
@@ -38,11 +39,11 @@ import           System.IO.Extra
 -- | Given a file and some contents, apply any necessary preprocessors,
 --   e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies.
 preprocessor :: HscEnv -> Uri -> Maybe Util.StringBuffer -> ExceptT [FileDiagnostic] IO (Util.StringBuffer, [String], HscEnv, Util.Fingerprint)
-preprocessor env uri mbContents = case uriToFilePath uri of
-  Nothing -> do
-    let nuri = toNormalizedUri uri
-    throwError [ideErrorText nuri $ "Uri is not a file uri: " <> getUri uri]
-  Just filename -> do
+preprocessor env uri mbContents = do
+    -- NOTE: thisis pretty bad as it relies on the prepropcessors not actually reading from a file when it's not needed
+    when (isNothing (uriToFilePath uri) && isNothing mbContents) $ do
+        throwError [ideErrorText (toNormalizedUri uri) $ "Uri is not a file uri and contents are not available: " <> getUri uri]
+    let filename = T.unpack $ getUri uri
     -- Perform unlit
     (isOnDisk, contents) <-
         if isLiterate uri then do

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

@@ -173,6 +173,7 @@ import           System.Info.Extra                            (isWindows)
 
 import qualified Data.IntMap                                  as IM
 import           GHC.Fingerprint
+import System.Process.Extra (proc, readCreateProcess)
 
 data Log
   = LogShake Shake.Log
@@ -710,11 +711,31 @@ loadGhcSession recorder ghcSessionDepsConfig = do
         return (fingerprint, res)
 
     defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GhcSession uri -> do
+      -- let mk k = case uriToNormalizedFilePath nuri of
+      --       -- FIXME: awful hack to get cradles to work
+      --       Nothing -> withSystemTempDirectory "tmp_cradle" $ \dir -> do
+      --         writeFile (dir </> "hie.yaml") "cradle:\n  direct:\n    arguments: []"
+      --         k dir
+      --       Just file -> k $ fromNormalizedFilePath file
         IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO
         -- loading is always returning a absolute path now
         (val,deps) <- case uriToNormalizedFilePath uri of
-          Just file -> liftIO $ loadSessionFun $ fromNormalizedFilePath file
-          Nothing -> pure (([], Nothing), [])
+          Just fp -> liftIO $ loadSessionFun (fromNormalizedFilePath fp)
+          Nothing -> do
+            hscEnv :: HscEnv <- do
+              ShakeExtras{ideNc} <- getShakeExtras
+
+              liftIO $ do
+                -- TODO: clean up
+                -- e.g. the hack to drop the line break but also other stuff
+                libdir <- init <$> readCreateProcess (proc "ghc" ["--print-libdir"]) ""
+                env <- runGhc {- get lib dir from somewhere -} (Just libdir) $
+                  getSessionDynFlags >>= setSessionDynFlags >> getSession
+                pure $ (hscSetFlags ((hsc_dflags env){useUnicode = True }) env) {hsc_NC = ideNc}
+
+            hscEnvEq <- liftIO $ newHscEnvEq hscEnv
+            pure (([], Just hscEnvEq), [])
+
 
 
         -- add the deps to the Shake graph

ghcide/src/Development/IDE/LSP/LanguageServer.hs

@@ -34,6 +34,7 @@ import           UnliftIO.Directory
 import           UnliftIO.Exception
 
 import qualified Colog.Core                            as Colog
+import           Control.Exception                     (BlockedIndefinitelyOnMVar (..))
 import           Control.Monad.IO.Unlift               (MonadUnliftIO)
 import           Control.Monad.Trans.Cont              (evalContT)
 import           Development.IDE.Core.IdeConfiguration
@@ -265,11 +266,13 @@ runWithWorkerThreads recorder dbLoc f = evalContT $ do
             (WithHieDbShield hiedb, threadQueue) <- runWithDb recorder dbLoc
             liftIO $ f hiedb (ThreadQueue threadQueue sessionRestartTQueue sessionLoaderTQueue)
 
--- | Runs the action until it ends or until the given MVar is put.
+-- | Runs the action until it ends or until the given MVar is put or the thread to fill the mvar is dropped, in which case the MVar will never be filled.
+--   This happens when the thread that handles the shutdown notification dies. Ideally, this should not rely on the RTS detecting the blocked MVar
+--   and instead *also* run the shutdown inf a finally block enclosing the handlers. In which case the BlockedIndefinitelyOnMVar Exception also wouldn't
+--   be thrown.
 --   Rethrows any exceptions.
 untilMVar :: MonadUnliftIO m => MVar () -> m () -> m ()
-untilMVar mvar io = void $
-    waitAnyCancel =<< traverse async [ io , readMVar mvar ]
+untilMVar mvar io = race_ (readMVar mvar `catch` \BlockedIndefinitelyOnMVar -> pure ()) io
 
 cancelHandler :: (SomeLspId -> IO ()) -> LSP.Handlers (ServerM c)
 cancelHandler cancelRequest = LSP.notificationHandler SMethod_CancelRequest $ \TNotificationMessage{_params=CancelParams{_id}} ->

hls-plugin-api/src/Ide/Plugin/Config.hs

@@ -27,6 +27,7 @@ import           Ide.Types
 -- | Given a DidChangeConfigurationNotification message, this function returns the parsed
 -- Config object if possible.
 getConfigFromNotification :: IdePlugins s -> Config -> A.Value -> Either T.Text Config
+getConfigFromNotification _plugins defaultValue Null = pure defaultValue
 getConfigFromNotification plugins defaultValue p =
   case A.parse (parseConfig plugins defaultValue) p of
     A.Success c -> Right c

plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs

@@ -167,12 +167,12 @@ type instance RuleResult GetCodeRange = CodeRange
 
 codeRangeRule :: Recorder (WithPriority Log) -> Rules ()
 codeRangeRule recorder =
-    define (cmapWithPrio LogShake recorder) $ \GetCodeRange file -> handleError recorder $ do
+    define (cmapWithPrio LogShake recorder) $ \GetCodeRange nuri -> handleError recorder $ do
         -- We need both 'HieAST' (for basic AST) and api annotations (for comments and some keywords).
         -- See https://gitlab.haskell.org/ghc/ghc/-/wikis/api-annotations
-        HAR{hieAst, refMap} <- lift $ use_ GetHieAst file
+        HAR{hieAst, refMap} <- lift $ use_ GetHieAst nuri
         ast <- maybeToExceptT LogNoAST . MaybeT . pure $
-            getAsts hieAst Map.!? (coerce . mkFastString . T.unpack . getUri . fromNormalizedUri) file
+            getAsts hieAst Map.!? (coerce . mkFastString . T.unpack . getUri . fromNormalizedUri) nuri
         let (codeRange, warnings) = runWriter (buildCodeRange ast refMap)
         traverse_ (logWith recorder Warning) warnings
 

plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Handlers.hs

@@ -152,7 +152,7 @@ mkRangeCommands recorder st plId textDocument =
      in perf "evalMkRangeCommands" $
             do
                 let TextDocumentIdentifier uri = textDocument
-                fp <- uriToFilePathE uri
+                let fp = T.unpack $ getUri uri
                 let nuri = toNormalizedUri uri
                     isLHS = isLiterate fp
                 dbg $ LogCodeLensFp fp
@@ -207,7 +207,6 @@ runEvalCmd recorder plId st mtoken EvalParams{..} =
             let tests = map (\(a,_,b) -> (a,b)) $ testsBySection sections
 
             let TextDocumentIdentifier{_uri} = module_
-            fp <- uriToFilePathE _uri
             let nuri = toNormalizedUri _uri
             mdlText <- moduleText st _uri
 
@@ -230,7 +229,7 @@ runEvalCmd recorder plId st mtoken EvalParams{..} =
                 perf "edits" $
                     liftIO $
                         evalGhcEnv final_hscEnv $ do
-                            runTests recorder evalCfg fp tests
+                            runTests recorder evalCfg (T.unpack $ getUri _uri) tests
 
             let workspaceEditsMap = Map.singleton _uri (addFinalReturn mdlText edits)
             let workspaceEdits = WorkspaceEdit (Just workspaceEditsMap) Nothing Nothing

plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs

@@ -107,13 +107,11 @@ data Action = Replace
 -- | Required action (that can be converted to either CodeLenses or CodeActions)
 action :: Recorder (WithPriority Log) -> IdeState -> Uri -> ExceptT PluginError (HandlerM c) [Action]
 action recorder state uri = do
-    fp <- uriToFilePathE uri
     let nuri = toNormalizedUri uri
-
     contents <- liftIO $ runAction "ModuleName.getFileContents" state $ getFileContents nuri
     let emptyModule = maybe True (T.null . T.strip . Rope.toText) contents
 
-    correctNames <- mapExceptT liftIO $ pathModuleNames recorder state nuri fp
+    correctNames <- mapExceptT liftIO $ pathModuleNames recorder state nuri
     logWith recorder Debug (CorrectNames correctNames)
     let bestName = minimumBy (comparing T.length) <$> NE.nonEmpty correctNames
     logWith recorder Debug (BestName bestName)
@@ -133,10 +131,10 @@ action recorder state uri = do
 -- | Possible module names, as derived by the position of the module in the
 -- source directories.  There may be more than one possible name, if the source
 -- directories are nested inside each other.
-pathModuleNames :: Recorder (WithPriority Log) -> IdeState -> NormalizedUri -> FilePath -> ExceptT PluginError IO [T.Text]
-pathModuleNames recorder state nuri filePath
-  | firstLetter isLower $ takeFileName filePath = return ["Main"]
-  | otherwise = do
+pathModuleNames :: Recorder (WithPriority Log) -> IdeState -> NormalizedUri -> ExceptT PluginError IO [T.Text]
+pathModuleNames recorder state nuri
+  | Just filePath <- uriToFilePath $ fromNormalizedUri nuri
+  , firstLetter isUpper $ takeFileName filePath = do
       (session, _) <- runActionE "ModuleName.ghcSession" state $ useWithStaleE GhcSession nuri
       srcPaths <- liftIO $ evalGhcEnv (hscEnv session) $ importPaths <$> getSessionDynFlags
       logWith recorder Debug (SrcPaths srcPaths)
@@ -155,6 +153,7 @@ pathModuleNames recorder state nuri filePath
 
       let suffixes = mapMaybe (`stripPrefix` mdlPath) paths
       pure (map moduleNameFrom suffixes)
+  | otherwise = pure [T.pack "Main"]
   where
     firstLetter :: (Char -> Bool) -> FilePath -> Bool
     firstLetter _ []       = False

plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs

@@ -108,7 +108,7 @@ rules recorder plId = do
   define (cmapWithPrio LogShake recorder) $
     \GetStanDiagnostics nuri -> do
       case LSP.uriToNormalizedFilePath nuri of
-        Nothing -> pure ([ideErrorText nuri $ "Uri is no a file Uri: " <> getUri (fromNormalizedUri nuri)], Nothing)
+        Nothing -> pure ([], Nothing)
         Just nfp -> do
           config <- getPluginConfigAction plId
           if plcGlobalOn config && plcDiagnosticsOn config then do