WIP

Author: Anton-Latukha

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

@@ -28,6 +28,7 @@ module Development.IDE.Core.Compile
   , loadInterface
   , loadModulesHome
   , setupFinderCache
+  , getDocsNonInteractive
   , getDocsBatch
   , lookupName
   ,mergeEnvs) where
@@ -989,8 +990,8 @@ mkDetailsFromIface session iface linkable = do
 -- | 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
+getDocsNonInteractive :: Name -> IO (Name, Either GetDocsFailure (Maybe HsDocString, Maybe (Map.Map Int HsDocString)))
+getDocsNonInteractive name = undefined $ do
     case nameModule_maybe name of
         Nothing -> return (name, Left $ NameHasNoModule name)
         Just mod -> do

ghcide/src/Development/IDE/Spans/Documentation.hs

@@ -63,9 +63,84 @@ lookupKind :: HscEnv -> Module -> Name -> IO (Maybe TyThing)
 lookupKind env mod =
     fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env mod
 
+newGetDocumentationTryGhc :: HscEnv -> Name -> IO SpanDoc
+--  2021-11-17: FIXME: Code uses batch search for singleton & assumes that search always succeeds.
+newGetDocumentationTryGhc env n = fun n
+ where
+  fun :: Name -> IO SpanDoc
+  fun name = do
+    res <- getDocsNonInteractive name
+    uncurry unwrap res
+      where
+        unwrap :: Name -> Either a (Maybe HsDocString, b) -> IO SpanDoc
+        unwrap name a = extractDocString a <$> getSpanDocUris name
+          where
+            extractDocString :: Either b1 (Maybe HsDocString, b2) -> SpanDocUris -> SpanDoc
+            --  2021-11-17: FIXME: ArgDocs get dropped here - instead propagate them.
+            extractDocString (Right (Just docs, _)) = SpanDocString docs
+            extractDocString _ = SpanDocText mempty
+
+            -- | Get the uris to the documentation and source html pages if they exist
+            getSpanDocUris :: Name -> IO SpanDocUris
+            getSpanDocUris name = do
+                (docFu, srcFu) <-
+                    case nameModule_maybe name of
+                    Just mod -> liftIO $ do
+                        let
+                            toUriFileText :: (HscEnv -> Module -> IO (Maybe FilePath)) -> IO (Maybe T.Text)
+                            toUriFileText f = (fmap . fmap) (getUri . filePathToUri) $ f env mod
+                        doc <- toUriFileText lookupDocHtmlForModule
+                        src <- toUriFileText lookupSrcHtmlForModule
+                        return (doc, src)
+                    Nothing -> pure mempty
+                let
+                    embelishUri :: Functor f => T.Text -> f T.Text -> f T.Text
+                    embelishUri f = fmap (<> "#" <> f <> showNameWithoutUniques name)
+
+                    docUri = embelishUri (bool "t:" "v:" $ isValName name) docFu
+                    srcUri = embelishUri mempty srcFu
+
+                return $ SpanDocUris docUri srcUri
 getDocumentationTryGhc :: HscEnv -> Module -> Name -> IO SpanDoc
 --  2021-11-17: FIXME: Code uses batch search for singleton & assumes that search always succeeds.
-getDocumentationTryGhc env mod n = fromJust . M.lookup n <$> getDocumentationsTryGhc env mod [n]
+getDocumentationTryGhc env mod n = fromJust . M.lookup n <$> fun [n]
+ where
+  fun :: [Name] -> IO (M.Map Name SpanDoc)
+  fun name = do
+    res <- getDocsBatch env mod name
+    case res of
+        Left _    -> return mempty -- catchSrcErrors (hsc_dflags env) "docs"
+        Right res -> sequenceA $ M.mapWithKey unwrap res
+      where
+        unwrap :: Name -> Either a (Maybe HsDocString, b) -> IO SpanDoc
+        unwrap name a = extractDocString a <$> getSpanDocUris name
+          where
+            extractDocString :: Either b1 (Maybe HsDocString, b2) -> SpanDocUris -> SpanDoc
+            --  2021-11-17: FIXME: ArgDocs get dropped here - instead propagate them.
+            extractDocString (Right (Just docs, _)) = SpanDocString docs
+            extractDocString _ = SpanDocText mempty
+
+            -- | Get the uris to the documentation and source html pages if they exist
+            getSpanDocUris :: Name -> IO SpanDocUris
+            getSpanDocUris name = do
+                (docFu, srcFu) <-
+                    case nameModule_maybe name of
+                    Just mod -> liftIO $ do
+                        let
+                            toUriFileText :: (HscEnv -> Module -> IO (Maybe FilePath)) -> IO (Maybe T.Text)
+                            toUriFileText f = (fmap . fmap) (getUri . filePathToUri) $ f env mod
+                        doc <- toUriFileText lookupDocHtmlForModule
+                        src <- toUriFileText lookupSrcHtmlForModule
+                        return (doc, src)
+                    Nothing -> pure mempty
+                let
+                    embelishUri :: Functor f => T.Text -> f T.Text -> f T.Text
+                    embelishUri f = fmap (<> "#" <> f <> showNameWithoutUniques name)
+
+                    docUri = embelishUri (bool "t:" "v:" $ isValName name) docFu
+                    srcUri = embelishUri mempty srcFu
+
+                return $ SpanDocUris docUri srcUri
 
 getDocumentationsTryGhc :: HscEnv -> Module -> [Name] -> IO (M.Map Name SpanDoc)
 getDocumentationsTryGhc env mod names = do