From 93088b1f0a8957d13ed432824d7f732ba205ea97 Mon Sep 17 00:00:00 2001
From: Anton-Latukha <anton.latukha@gmail.com>
Date: Fri, 26 Nov 2021 21:26:20 +0200
Subject: [PATCH] ghcide: Core.Compile: add getDocsNonInteractive{',}

`getDocsBatch` cuurently (& before) used only for single name retrieval
function. Use of it is in `Documentation` module `getDocumentationTryGhc` where
it wraps arg into singleton & gives to `getDocsBatch` & then recieves a Map with
1 entry & unsafely "lookups" doc in it.

This work is to supply the proper single name retrieval-optimized version to
stop that `getDocsBatch` there.

& further ideally `getDocumentationTryGhc` uses single-retrieval &
`getDocumentationsTryGhc` uses a batch mode & batch mode gets optimized along
the lines of: https://github.com/haskell/haskell-language-server/pull/2371
---
 ghcide/src/Development/IDE/Core/Compile.hs | 40 +++++++++++++++-------
 1 file changed, 28 insertions(+), 12 deletions(-)

diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs
index ad5dcd638c9..3ef6807095d 100644
--- a/ghcide/src/Development/IDE/Core/Compile.hs
+++ b/ghcide/src/Development/IDE/Core/Compile.hs
@@ -28,6 +28,8 @@ module Development.IDE.Core.Compile
   , loadInterface
   , loadModulesHome
   , setupFinderCache
+  , getDocsNonInteractive
+  , getDocsNonInteractive'
   , getDocsBatch
   , lookupName
   ,mergeEnvs) where
@@ -990,12 +992,20 @@ mkDetailsFromIface session iface linkable = do
     initIfaceLoad hsc' (typecheckIface iface)
   return (HomeModInfo iface details linkable)
 
+fakeSpan :: RealSrcSpan
+fakeSpan = realSrcLocSpan $ mkRealSrcLoc (Util.fsLit "<ghcide>") 1 1
 
--- | Non-interactive modification of 'GHC.Runtime.Eval.getDocs'.
---   The interactive paths create problems in ghc-lib builds
----  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 = do
+initTypecheckEnv :: HscEnv -> Module -> TcRn r -> IO (Messages, Maybe r)
+initTypecheckEnv hsc_env mod = initTc hsc_env HsSrcFile False mod fakeSpan
+
+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
@@ -1007,7 +1017,7 @@ getDocsNonInteractive name = do
                 <- loadModuleInterface "getModuleInterface" mod
             let
                 isNameCompiled =
-                    -- TODO: Find a more direct indicator.
+                    -- comment from GHC: Find a more direct indicator.
                     case nameSrcLoc name of
                         RealSrcLoc {}   -> False
                         UnhelpfulLoc {} -> True
@@ -1016,6 +1026,15 @@ getDocsNonInteractive name = do
                     then Left $ NoDocsInIface mod isNameCompiled
                     else Right (Map.lookup name dmap, Map.lookup name amap)
 
+-- | Non-interactive modification of 'GHC.Runtime.Eval.getDocs'.
+--   The interactive paths create problems in ghc-lib builds
+---  and lead to fun errors like "Cannot continue after interface file error".
+getDocsNonInteractive :: HscEnv -> Module -> Name -> IO (Either 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
@@ -1024,13 +1043,10 @@ getDocsBatch
   --  2021-11-18: NOTE: Map Int would become IntMap if next GHCs.
   -> IO (Either 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) <- initTc hsc_env HsSrcFile False _mod fakeSpan $ Map.fromList <$> traverse getDocsNonInteractive _names
+getDocsBatch hsc_env mod names = do
+    ((_warns,errs), res) <- initTypecheckEnv hsc_env mod $ Map.fromList <$> traverse getDocsNonInteractive' names
     pure $ maybeToEither errs res
 
-fakeSpan :: RealSrcSpan
-fakeSpan = realSrcLocSpan $ mkRealSrcLoc (Util.fsLit "<ghcide>") 1 1
-
 -- | Non-interactive, batch version of 'InteractiveEval.lookupNames'.
 --   The interactive paths create problems in ghc-lib builds
 --- and leads to fun errors like "Cannot continue after interface file error".
@@ -1039,7 +1055,7 @@ 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