Streamline code for getDocumentationTryGhc

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

@@ -28,6 +28,7 @@ module Development.IDE.Core.Compile
   , loadInterface
   , loadModulesHome
   , setupFinderCache
+  , getDocsNonInteractive
   , getDocsBatch
   , lookupName
   ,mergeEnvs) where
@@ -39,7 +40,6 @@ import           Development.IDE.GHC.Error
 import           Development.IDE.GHC.Orphans       ()
 import           Development.IDE.GHC.Util
 import           Development.IDE.GHC.Warnings
-import           Development.IDE.Spans.Common
 import           Development.IDE.Types.Diagnostics
 import           Development.IDE.Types.Location
 import           Development.IDE.Types.Options
@@ -75,7 +75,7 @@ import           Control.Lens                      hiding (List)
 import           Control.Monad.Except
 import           Control.Monad.Extra
 import           Control.Monad.Trans.Except
-import           Data.Bifunctor                    (first, second)
+import           Data.Bifunctor                    (second)
 import qualified Data.ByteString                   as BS
 import qualified Data.DList                        as DL
 import           Data.IORef
@@ -89,7 +89,6 @@ import           System.Directory
 import           System.FilePath
 import           System.IO.Extra                   (fixIO, newTempFileWithin)
 
--- GHC API imports
 -- GHC API imports
 import           GHC                               (GetDocsFailure (..),
                                                     mgModSummaries,
@@ -104,6 +103,7 @@ import           Data.Functor
 import qualified Data.HashMap.Strict               as HashMap
 import           Data.Map                          (Map)
 import           Data.Tuple.Extra                  (dupe)
+import           Data.Either.Extra                 (maybeToEither)
 import           Data.Unique                       as Unique
 import           Development.IDE.Core.Tracing      (withTrace)
 import           Development.IDE.GHC.Compat.Util   (emptyUDFM, plusUDFM_C)
@@ -213,9 +213,7 @@ tcRnModule hsc_env keep_lbls pmod = do
                           HsParsedModule { hpm_module = parsedSource pmod,
                                            hpm_src_files = pm_extra_src_files pmod,
                                            hpm_annotations = pm_annotations pmod }
-  let rn_info = case mrn_info of
-        Just x  -> x
-        Nothing -> error "no renamed info tcRnModule"
+  let rn_info = fromMaybe (error "no renamed info tcRnModule") mrn_info
   pure (TcModuleResult pmod rn_info tc_gbl_env splices False)
 
 mkHiFileResultNoCompile :: HscEnv -> TcModuleResult -> IO HiFileResult
@@ -658,7 +656,7 @@ setupFinderCache mss session = do
     -- Make modules available for others that import them,
     -- by putting them in the finder cache.
     let ims  = map (installedModule (homeUnitId_ $ hsc_dflags session) . moduleName . ms_mod) mss
-        ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) mss ims
+        ifrs = zipWith (InstalledFound . ms_location) mss ims
     -- set the target and module graph in the session
         graph = mkModuleGraph mss
 
@@ -696,7 +694,7 @@ mergeEnvs :: HscEnv -> [ModSummary] -> [HomeModInfo] -> [HscEnv] -> IO HscEnv
 mergeEnvs env extraModSummaries extraMods envs = do
     prevFinderCache <- concatFC <$> mapM (readIORef . hsc_FC) envs
     let ims  = map (Compat.installedModule (homeUnitId_ $ hsc_dflags env) . moduleName . ms_mod) extraModSummaries
-        ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) extraModSummaries ims
+        ifrs = zipWith (InstalledFound . ms_location) extraModSummaries ims
     newFinderCache <- newIORef $
             foldl'
                 (\fc (im, ifr) -> Compat.extendInstalledModuleEnv fc im ifr) prevFinderCache
@@ -809,6 +807,8 @@ getModSummaryFromImports env fp modTime contents = do
                     , fingerPrintImports
                     ] ++ map Util.fingerprintString opts
 
+diagMsgs :: DynFlags -> Util.Bag (MsgEnvelope DecoratedSDoc) -> [FileDiagnostic]
+diagMsgs = diagFromErrMsgs "parser"
 
 -- | Parse only the module header
 parseHeader
@@ -826,7 +826,7 @@ parseHeader dflags filename contents = do
    case unP Compat.parseHeader (initParserState (initParserOpts dflags) contents loc) of
 #if MIN_VERSION_ghc(8,10,0)
      PFailed pst ->
-        throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags
+        throwE $ diagMsgs dflags $ getErrorMessages pst dflags
 #else
      PFailed _ locErr msgErr ->
         throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr
@@ -843,9 +843,9 @@ parseHeader dflags filename contents = do
         -- errors are those from which a parse tree just can't
         -- be produced.
         unless (null errs) $
-            throwE $ diagFromErrMsgs "parser" dflags (fmap pprError errs)
+            throwE $ diagMsgs dflags (fmap pprError errs)
 
-        let warnings = diagFromErrMsgs "parser" dflags (fmap pprWarning warns)
+        let warnings = diagMsgs dflags (fmap pprWarning warns)
         return (warnings, rdr_module)
 
 -- | Given a buffer, flags, and file path, produce a
@@ -863,7 +863,7 @@ parseFileContents env customPreprocessor filename ms = do
        contents = fromJust $ ms_hspp_buf ms
    case unP Compat.parseModule (initParserState (initParserOpts dflags) contents loc) of
 #if MIN_VERSION_ghc(8,10,0)
-     PFailed pst -> throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags
+     PFailed pst -> throwE $ diagMsgs dflags $ getErrorMessages pst dflags
 #else
      PFailed _ locErr msgErr ->
       throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr
@@ -884,7 +884,7 @@ parseFileContents env customPreprocessor filename ms = do
                -- errors are those from which a parse tree just can't
                -- be produced.
                unless (null errs) $
-                 throwE $ diagFromErrMsgs "parser" dflags errs
+                 throwE $ diagMsgs dflags errs
 
                -- Ok, we got here. It's safe to continue.
                let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module
@@ -922,7 +922,7 @@ parseFileContents env customPreprocessor filename ms = do
                srcs2 <- liftIO $ filterM doesFileExist srcs1
 
                let pm = mkParsedModule ms parsed' srcs2 hpm_annotations
-                   warnings = diagFromErrMsgs "parser" dflags warns
+                   warnings = diagMsgs dflags warns
                pure (warnings ++ preproc_warnings, pm)
 
 loadHieFile :: Compat.NameCacheUpdater -> FilePath -> IO GHC.HieFile
@@ -991,40 +991,62 @@ mkDetailsFromIface session iface linkable = do
     initIfaceLoad hsc' (typecheckIface iface)
   return (HomeModInfo iface details linkable)
 
--- | Non-interactive, batch version of 'InteractiveEval.getDocs'.
+initTypecheckEnv :: HscEnv -> Module -> TcRn r -> IO (Messages, Maybe r)
+initTypecheckEnv hsc_env mod = initTc hsc_env HsSrcFile False mod fakeSpan
+  where
+    fakeSpan :: RealSrcSpan
+    fakeSpan = realSrcLocSpan $ mkRealSrcLoc (Util.fsLit "<ghcide>") 1 1
+
+-- | Non-interactive handling of the module interface.
+--   A non-interactive modification of code from the 'GHC.Runtime.Eval.getDocs'.
 --   The interactive paths create problems in ghc-lib builds
---- and leads to fun errors like "Cannot continue after interface file error".
+---  and lead to fun errors like "Cannot continue after interface file error".
+getDocsNonInteractive'
+    :: Name
+    -> IOEnv
+        (Env TcGblEnv TcLclEnv)
+        (Name,
+        Either
+            GetDocsFailure (Maybe HsDocString, Maybe (Map.Map Int HsDocString)))
+getDocsNonInteractive' name =
+    case nameModule_maybe name of
+        Nothing -> return (name, Left $ NameHasNoModule name)
+        Just mod -> do -- in GHC here was an interactive check & handling.
+            ModIface
+                { mi_doc_hdr = mb_doc_hdr
+                , mi_decl_docs = DeclDocMap dmap
+                , mi_arg_docs = ArgDocMap amap
+                }
+                <- loadModuleInterface "getModuleInterface" mod
+            let
+                isNameCompiled =
+                    -- comment from GHC: Find a more direct indicator.
+                    case nameSrcLoc name of
+                        RealSrcLoc {}   -> False
+                        UnhelpfulLoc {} -> True
+            pure . (name,) $
+                if isNothing mb_doc_hdr && Map.null dmap && Map.null amap
+                    then Left $ NoDocsInIface mod isNameCompiled
+                    else Right (Map.lookup name dmap, Map.lookup name amap)
+
+-- | Non-interactive modification of 'GHC.Runtime.Eval.getDocs'.
+getDocsNonInteractive :: HscEnv -> Module -> Name -> IO (Either GHC.ErrorMessages (Name, Either GetDocsFailure (Maybe HsDocString, Maybe (Map.Map Int HsDocString))))
+getDocsNonInteractive hsc_env mod name = do
+    ((_warns,errs), res) <- initTypecheckEnv hsc_env mod $ getDocsNonInteractive' name
+    pure $ maybeToEither errs res
+
+
+-- | Non-interactive, batch version of 'GHC.Runtime.Eval.getDocs'.
 getDocsBatch
   :: HscEnv
   -> Module  -- ^ a moudle where the names are in scope
   -> [Name]
-  -> IO [Either String (Maybe HsDocString, Map.Map Int HsDocString)]
-getDocsBatch hsc_env _mod _names = do
-    ((_warns,errs), res) <- initTc hsc_env HsSrcFile False _mod fakeSpan $ forM _names $ \name ->
-        case nameModule_maybe name of
-            Nothing -> return (Left $ NameHasNoModule name)
-            Just mod -> do
-             ModIface { mi_doc_hdr = mb_doc_hdr
-                      , mi_decl_docs = DeclDocMap dmap
-                      , mi_arg_docs = ArgDocMap amap
-                      } <- loadModuleInterface "getModuleInterface" mod
-             if isNothing mb_doc_hdr && Map.null dmap && Map.null amap
-               then pure (Left (NoDocsInIface mod $ compiled name))
-               else pure (Right ( Map.lookup name dmap
-                                , Map.findWithDefault Map.empty name amap))
-    case res of
-        Just x  -> return $ map (first $ T.unpack . showGhc) x
-        Nothing -> throwErrors errs
-  where
-    throwErrors = liftIO . throwIO . mkSrcErr
-    compiled n =
-      -- TODO: Find a more direct indicator.
-      case nameSrcLoc n of
-        RealSrcLoc {}   -> False
-        UnhelpfulLoc {} -> True
-
-fakeSpan :: RealSrcSpan
-fakeSpan = realSrcLocSpan $ mkRealSrcLoc (Util.fsLit "<ghcide>") 1 1
+  --  2021-11-18: NOTE: Map Int would become IntMap if next GHCs.
+  -> IO (Either GHC.ErrorMessages (Map.Map Name (Either GetDocsFailure (Maybe HsDocString, Maybe (Map.Map Int HsDocString)))))
+  -- ^ Return a 'Map' of 'Name's to 'Either' (no docs messages) (general doc body & arg docs)
+getDocsBatch hsc_env mod names = do
+    ((_warns,errs), res) <- initTypecheckEnv hsc_env mod $ Map.fromList <$> traverse getDocsNonInteractive' names
+    pure $ maybeToEither errs res
 
 -- | Non-interactive, batch version of 'InteractiveEval.lookupNames'.
 --   The interactive paths create problems in ghc-lib builds
@@ -1034,11 +1056,11 @@ lookupName :: HscEnv
            -> Name
            -> IO (Maybe TyThing)
 lookupName hsc_env mod name = do
-    (_messages, res) <- initTc hsc_env HsSrcFile False mod fakeSpan $ do
+    (_messages, res) <- initTypecheckEnv hsc_env mod $ do
         tcthing <- tcLookup name
         case tcthing of
             AGlobal thing    -> return thing
-            ATcId{tct_id=id} -> return (AnId id)
+            ATcId{tct_id=id} -> return $ AnId id
             _                -> panic "tcRnLookupName'"
     return res
 

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

@@ -574,9 +574,9 @@ getBindingsRule :: Rules ()
 getBindingsRule =
   define $ \GetBindings f -> do
     HAR{hieKind=kind, refMap=rm} <- use_ GetHieAst f
-    case kind of
-      HieFresh      -> pure ([], Just $ bindings rm)
-      HieFromDisk _ -> pure ([], Nothing)
+    pure . (mempty,) $ case kind of
+      HieFresh      -> Just $ bindings rm
+      HieFromDisk _ -> Nothing
 
 getDocMapRule :: Rules ()
 getDocMapRule =
@@ -688,8 +688,7 @@ loadGhcSession ghcSessionDepsConfig = do
                 afp <- liftIO $ makeAbsolute fp
                 let nfp = toNormalizedFilePath' afp
                 itExists <- getFileExists nfp
-                when itExists $ void $ do
-                  use_ GetModificationTime nfp
+                when itExists $ void $ use_ GetModificationTime nfp
         mapM_ addDependency deps
 
         opts <- getIdeOptions
@@ -722,7 +721,7 @@ ghcSessionDepsDefinition
 ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} env file = do
     let hsc = hscEnv env
 
-    mbdeps <- mapM(fmap artifactFilePath . snd) <$> use_ GetLocatedImports file
+    mbdeps <- traverse (fmap artifactFilePath . snd) <$> use_ GetLocatedImports file
     case mbdeps of
         Nothing -> return Nothing
         Just deps -> do

ghcide/src/Development/IDE/GHC/Compat/Outputable.hs

@@ -27,6 +27,8 @@ module Development.IDE.GHC.Compat.Outputable (
     mkWarnMsg,
     mkSrcErr,
     srcErrorMessages,
+    Messages,
+    ErrorMessages
     ) where
 
 
@@ -49,7 +51,7 @@ import           GHC.Driver.Session
 import           GHC.Driver.Types                as HscTypes
 import           GHC.Types.Name.Reader           (GlobalRdrEnv)
 import           GHC.Types.SrcLoc
-import           GHC.Utils.Error                 as Err hiding (mkWarnMsg)
+import           GHC.Utils.Error                 hiding (mkWarnMsg)
 import qualified GHC.Utils.Error                 as Err
 import           GHC.Utils.Outputable            as Out
 #else

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

@@ -24,14 +24,14 @@ import           Language.LSP.Types
 
 import qualified Data.Text                      as T
 
-gotoDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (ResponseResult TextDocumentDefinition))
-hover          :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (Maybe Hover))
+gotoDefinition     :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (ResponseResult TextDocumentDefinition))
+hover              :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (Maybe Hover))
 gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (ResponseResult TextDocumentTypeDefinition))
-documentHighlight :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (List DocumentHighlight))
-gotoDefinition = request "Definition" getDefinition (InR $ InL $ List []) (InR . InL . List)
-gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InL $ List []) (InR . InL . List)
-hover          = request "Hover"      getAtPoint     Nothing      foundHover
-documentHighlight = request "DocumentHighlight" highlightAtPoint (List []) List
+documentHighlight  :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (List DocumentHighlight))
+gotoDefinition     = request "Definition"        getDefinition     (InR $ InL $ List []) (InR . InL . List)
+gotoTypeDefinition = request "TypeDefinition"    getTypeDefinition (InR $ InL $ List []) (InR . InL . List)
+hover              = request "Hover"             getAtPoint        Nothing                     foundHover
+documentHighlight  = request "DocumentHighlight" highlightAtPoint  (List [])             List
 
 references :: IdeState -> ReferenceParams -> LSP.LspM c (Either ResponseError (List Location))
 references ide (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = liftIO $