Locate Documentation html page using Haddock interface file

ghcide.cabal

@@ -50,7 +50,8 @@ library
         filepath,
         fingertree,
         Glob,
-        haddock-library >= 1.8,
+        haddock-library >= 1.7,
+        haddock-api >= 2.22.0,
         hashable,
         haskell-lsp-types == 0.22.*,
         haskell-lsp == 0.22.*,
@@ -316,6 +317,7 @@ test-suite ghcide-tests
         ghcide,
         ghc-typelits-knownnat,
         haddock-library,
+        haddock-api,
         haskell-lsp,
         haskell-lsp-types,
         network-uri,

src/Development/IDE/Core/Rules.hs

@@ -567,8 +567,8 @@ getDocMapRule =
       let tdeps = transitiveModuleDeps deps
       parsedDeps <- uses_ GetParsedModule tdeps
 #endif
-
-      dkMap <- liftIO $ mkDocMap hsc parsedDeps rf tc
+      ShakeExtras{haddockLinkEnvs} <- getShakeExtras
+      dkMap <- liftIO $ mkDocMap hsc parsedDeps rf tc haddockLinkEnvs
       return ([],Just dkMap)
 
 -- Typechecks a module.

src/Development/IDE/Core/Shake.hs

@@ -62,8 +62,9 @@ module Development.IDE.Core.Shake(
     DelayedAction, mkDelayedAction,
     IdeAction(..), runIdeAction,
     mkUpdater,
+    LinkEnvsCache,
     -- Exposed for testing.
-    Q(..),
+    Q(..),    
     ) where
 
 import           Development.Shake hiding (ShakeValue, doesFileExist, Info)
@@ -126,6 +127,7 @@ import UniqSupply
 import PrelInfo
 import Data.Int (Int64)
 import qualified Data.HashSet as HSet
+import qualified Documentation.Haddock as H
 
 -- information we stash inside the shakeExtra field
 data ShakeExtras = ShakeExtras
@@ -164,8 +166,13 @@ data ShakeExtras = ShakeExtras
     ,exportsMap :: Var ExportsMap
     -- | A work queue for actions added via 'runInShakeSession'
     ,actionQueue :: ActionQueue
+    -- | A mapping of haddock interface files' link environments
+    ,haddockLinkEnvs :: LinkEnvsCache
     }
 
+-- | Global cache of parsed haddock link envs (link env is a mapping of name to haddock module/file)
+type LinkEnvsCache = Var (HashMap FilePath (Maybe H.LinkEnv))
+
 -- | A mapping of module name to known files
 type KnownTargets = HashMap Target [NormalizedFilePath]
 
@@ -433,6 +440,7 @@ shakeOpen getLspId eventer withProgress withIndefiniteProgress logger debouncer
         exportsMap <- newVar mempty
 
         actionQueue <- newQueue
+        haddockLinkEnvs <- newVar HMap.empty
 
         pure (ShakeExtras{..}, cancel progressAsync)
     (shakeDbM, shakeClose) <-

src/Development/IDE/Plugin/Completions.hs

@@ -74,7 +74,8 @@ produceCompletions = do
               res <- liftIO $ tcRnImportDecls env imps
               case res of
                   (_, Just rdrEnv) -> do
-                      cdata <- liftIO $ cacheDataProducer env (ms_mod ms) rdrEnv imps parsedDeps
+                      ShakeExtras{haddockLinkEnvs} <- getShakeExtras
+                      cdata <- liftIO $ cacheDataProducer env (ms_mod ms) rdrEnv imps parsedDeps haddockLinkEnvs
                       return ([], Just cdata)
                   (_diag, _) ->
                       return ([], Nothing)

src/Development/IDE/Plugin/Completions/Logic.hs

@@ -230,8 +230,14 @@ mkPragmaCompl label insertText =
     Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)
     Nothing Nothing Nothing Nothing Nothing
 
-cacheDataProducer :: HscEnv -> Module -> GlobalRdrEnv -> [LImportDecl GhcPs] -> [ParsedModule] -> IO CachedCompletions
-cacheDataProducer packageState curMod rdrEnv limports deps = do
+cacheDataProducer :: HscEnv 
+  -> Module
+  -> GlobalRdrEnv
+  -> [LImportDecl GhcPs]
+  -> [ParsedModule]
+  -> LinkEnvsCache
+  -> IO CachedCompletions
+cacheDataProducer packageState curMod rdrEnv limports deps le = do
   let dflags = hsc_dflags packageState
       curModName = moduleName curMod
 
@@ -276,7 +282,7 @@ cacheDataProducer packageState curMod rdrEnv limports deps = do
 
       toCompItem :: Module -> ModuleName -> Name -> IO CompItem
       toCompItem m mn n = do
-        docs <- getDocumentationTryGhc packageState curMod deps n
+        docs <- getDocumentationTryGhc packageState curMod deps n le
         ty <- catchSrcErrors (hsc_dflags packageState) "completion" $ do
                 name' <- lookupName packageState m n
                 return $ name' >>= safeTyThingType

src/Development/IDE/Spans/Common.hs

@@ -139,7 +139,13 @@ haddockToMarkdown (H.DocExamples es)
 haddockToMarkdown (H.DocHyperlink (H.Hyperlink url Nothing))
   = "<" ++ url ++ ">"
 haddockToMarkdown (H.DocHyperlink (H.Hyperlink url (Just label)))
-  = "[" ++ haddockToMarkdown label ++ "](" ++ url ++ ")"
+  = "[" ++ f label ++ "](" ++ url ++ ")"
+  where
+#if MIN_GHC_API_VERSION(8,8,0)
+    f = haddockToMarkdown
+#else
+    f = id
+#endif
 haddockToMarkdown (H.DocPic (H.Picture url Nothing))
   = "![](" ++ url ++ ")"
 haddockToMarkdown (H.DocPic (H.Picture url (Just label)))

src/Development/IDE/Spans/Documentation.hs

@@ -10,13 +10,19 @@ module Development.IDE.Spans.Documentation (
   , getDocumentationTryGhc
   , getDocumentationsTryGhc
   , DocMap
+  , LinkEnvsCache
   , mkDocMap
   ) where
 
+import           Control.Concurrent.Extra
 import           Control.Monad
 import           Control.Monad.Extra (findM)
+import           Control.Monad.Trans.Maybe
+import           Data.Char (isAlpha, isAlphaNum, isAscii, ord)
 import           Data.Either
 import           Data.Foldable
+import qualified Data.HashMap.Strict as HMap
+import           Data.IORef
 import           Data.List.Extra
 import qualified Data.Map as M
 import qualified Data.Set as S
@@ -27,27 +33,31 @@ import           Development.IDE.GHC.Compat
 import           Development.IDE.GHC.Error
 import           Development.IDE.Spans.Common
 import           Development.IDE.Core.RuleTypes
-import           System.Directory
-import           System.FilePath
-
+import           Development.IDE.Core.Shake (LinkEnvsCache)
+import qualified Documentation.Haddock as H
+import           ExtractDocs
 import           FastString
-import           SrcLoc (RealLocated)
 import           GhcMonad
-import           Packages
-import           Name
+import           GhcPlugins (HscEnv(hsc_NC))
+import           HscTypes (HscEnv(hsc_dflags))
 import           Language.Haskell.LSP.Types (getUri, filePathToUri)
-import           TcRnTypes
-import           ExtractDocs
+import           Name
+import           NameCache
 import           NameEnv
-import HscTypes (HscEnv(hsc_dflags))
+import           Packages
+import           SrcLoc (RealLocated)
+import           System.Directory
+import           System.FilePath
+import           TcRnTypes
 
 mkDocMap
   :: HscEnv
   -> [ParsedModule]
   -> RefMap
   -> TcGblEnv
+  -> LinkEnvsCache
   -> IO DocAndKindMap
-mkDocMap env sources rm this_mod =
+mkDocMap env sources rm this_mod le =
   do let (_ , DeclDocMap this_docs, _) = extractDocs this_mod
      d <- foldrM getDocs (mkNameEnv $ M.toList $ fmap (`SpanDocString` SpanDocUris Nothing Nothing) this_docs) names
      k <- foldrM getType (tcg_type_env this_mod) names
@@ -56,7 +66,7 @@ mkDocMap env sources rm this_mod =
     getDocs n map
       | maybe True (mod ==) $ nameModule_maybe n = pure map -- we already have the docs in this_docs, or they do not exist
       | otherwise = do
-      doc <- getDocumentationTryGhc env mod sources n
+      doc <- getDocumentationTryGhc env mod sources n le
       pure $ extendNameEnv map n doc
     getType n map
       | isTcOcc $ occName n = do
@@ -71,13 +81,24 @@ lookupKind :: HscEnv -> Module -> Name -> IO (Maybe TyThing)
 lookupKind env mod =
     fmap (either (const Nothing) id) . catchSrcErrors (hsc_dflags env) "span" . lookupName env mod
 
-getDocumentationTryGhc :: HscEnv -> Module -> [ParsedModule] -> Name -> IO SpanDoc
-getDocumentationTryGhc env mod deps n = head <$> getDocumentationsTryGhc env mod deps [n]
+getDocumentationTryGhc :: HscEnv
+  -> Module
+  -> [ParsedModule]
+  -> Name
+  -> LinkEnvsCache
+  -> IO SpanDoc
+getDocumentationTryGhc env mod deps n le =
+  head <$> getDocumentationsTryGhc env mod deps [n] le
 
-getDocumentationsTryGhc :: HscEnv -> Module -> [ParsedModule] -> [Name] -> IO [SpanDoc]
+getDocumentationsTryGhc :: HscEnv
+  -> Module
+  -> [ParsedModule]
+  -> [Name]
+  -> LinkEnvsCache
+  -> IO [SpanDoc]
 -- Interfaces are only generated for GHC >= 8.6.
 -- In older versions, interface files do not embed Haddocks anyway
-getDocumentationsTryGhc env mod sources names = do
+getDocumentationsTryGhc env mod sources names le = do
   res <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env mod names
   case res of
       Left _ -> mapM mkSpanDocText names
@@ -88,24 +109,26 @@ getDocumentationsTryGhc env mod sources names = do
 
     mkSpanDocText name =
       pure (SpanDocText (getDocumentation sources name)) <*> getUris name
+
+    ideNc = hsc_NC env
 
     -- Get the uris to the documentation and source html pages if they exist
     getUris name = do
       let df = hsc_dflags env
       (docFu, srcFu) <-
         case nameModule_maybe name of
-          Just mod -> liftIO $ do
-            doc <- toFileUriText $ lookupDocHtmlForModule df mod
+          Just mod -> do
+            doc <- toFileUriText $ lookupHtmlDocForName df name le ideNc
             src <- toFileUriText $ lookupSrcHtmlForModule df mod
             return (doc, src)
           Nothing -> pure (Nothing, Nothing)
-      let docUri = (<> "#" <> selector <> showName name) <$> docFu
-          srcUri = (<> "#" <> showName name) <$> srcFu
-          selector
-            | isValName name = "v:"
-            | otherwise = "t:"
+
+      let docUri = (<> "#" <> anchorId name) <$> docFu
+          srcUri = (<> "#" <> anchorId name) <$> srcFu
+
       return $ SpanDocUris docUri srcUri
 
+    anchorId name = (T.pack . nameAnchorId . occName) name
     toFileUriText = (fmap . fmap) (getUri . filePathToUri)
 
 getDocumentation
@@ -186,30 +209,19 @@ docHeaders = mapMaybe (\(L _ x) -> wrk x)
 
 -- These are taken from haskell-ide-engine's Haddock plugin
 
--- | Given a module finds the local @doc/html/Foo-Bar-Baz.html@ page.
--- An example for a cabal installed module:
--- @~/.cabal/store/ghc-8.10.1/vctr-0.12.1.2-98e2e861/share/doc/html/Data-Vector-Primitive.html@
-lookupDocHtmlForModule :: DynFlags -> Module -> IO (Maybe FilePath)
-lookupDocHtmlForModule =
-  lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir </> modDocName <.> "html")
-
 -- | Given a module finds the hyperlinked source @doc/html/src/Foo.Bar.Baz.html@ page.
 -- An example for a cabal installed module:
 -- @~/.cabal/store/ghc-8.10.1/vctr-0.12.1.2-98e2e861/share/doc/html/src/Data.Vector.Primitive.html@
 lookupSrcHtmlForModule :: DynFlags -> Module -> IO (Maybe FilePath)
-lookupSrcHtmlForModule =
-  lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir </> "src" </> modDocName <.> "html")
-
-lookupHtmlForModule :: (FilePath -> FilePath -> FilePath) -> DynFlags -> Module -> IO (Maybe FilePath)
-lookupHtmlForModule mkDocPath df m = do
+lookupSrcHtmlForModule df m = do
   -- try all directories
-  let mfs = fmap (concatMap go) (lookupHtmls df ui)
+  let mfs = fmap (concatMap go) (lookupHtmlDir df ui)
   html <- findM doesFileExist (concat . maybeToList $ mfs)
   -- canonicalize located html to remove /../ indirection which can break some clients
   -- (vscode on Windows at least)
   traverse canonicalizePath html
   where
-    go pkgDocDir = map (mkDocPath pkgDocDir) mns
+    go pkgDocDir = map (\modDocName -> pkgDocDir </> "src" </> modDocName <.> "html") mns
     ui = moduleUnitId m
     -- try to locate html file from most to least specific name e.g.
     --  first Language.Haskell.LSP.Types.Uri.html and Language-Haskell-LSP-Types-Uri.html
@@ -219,8 +231,103 @@ lookupHtmlForModule mkDocPath df m = do
       -- The file might use "." or "-" as separator
       map (`intercalate` chunks) [".", "-"]
 
-lookupHtmls :: DynFlags -> UnitId -> Maybe [FilePath]
-lookupHtmls df ui =
+lookupHtmlDir :: DynFlags -> UnitId -> Maybe [FilePath]
+lookupHtmlDir df ui =
   -- use haddockInterfaces instead of haddockHTMLs: GHC treats haddockHTMLs as URL not path 
   -- and therefore doesn't expand $topdir on Windows
   map takeDirectory . haddockInterfaces <$> lookupPackage df ui
+
+lookupHtmlDocForName :: DynFlags
+  -> Name 
+  -> LinkEnvsCache
+  -> IORef NameCache
+  -> IO (Maybe FilePath)
+lookupHtmlDocForName df n le ideNc = runMaybeT $ do
+  (dir, mod) <- findNameHaddockDirAndModule df n le ideNc
+  html <- MaybeT $ findM doesFileExist [dir </> moduleHtmlFile mod]
+  -- canonicalize located html to remove /../ indirection which can break some clients
+  -- (vscode on Windows at least)
+  liftIO $ canonicalizePath html
+
+findNameHaddockDirAndModule :: DynFlags
+  -> Name
+  -> LinkEnvsCache
+  -> IORef NameCache
+  -> MaybeT IO (FilePath, Module)
+findNameHaddockDirAndModule df name linkEnvs ideNc = do
+    (f, name) <- (MaybeT . return) $ nameHaddockInterface_maybe name
+    MaybeT $ findNameUri f name
+  where
+    nameHaddockInterface_maybe n = do
+      m <- nameModule_maybe n
+      p <- lookupPackage df $ moduleUnitId m
+      i <- listToMaybe $ haddockInterfaces p
+      return (i, n)
+
+    readInterfaceFile fi =
+      H.readInterfaceFile
+        (readIORef ideNc, writeIORef ideNc)
+        fi
+#if MIN_GHC_API_VERSION(8,8,0)
+        False -- don't bypass checks (default behavior before 8.8)
+#endif
+    readLinkEnvironment fi = do
+      envs <- readVar linkEnvs
+      case HMap.lookup fi envs of
+        -- load and cache link environment
+        Nothing -> 
+          do
+            ioe <- readInterfaceFile fi
+            let mle =
+                  case ioe of
+                    Left _ -> Nothing
+                    Right i -> Just $ H.ifLinkEnv i
+            modifyVar_ linkEnvs (return . HMap.insert fi mle)
+            return mle
+        -- get cached
+        Just mle ->
+          return mle
+
+    findNameUri f name = do
+      let dir = takeDirectory f
+      exists <- doesFileExist f
+      if exists
+        then do
+          mle <- readLinkEnvironment f
+          case mle of
+            Nothing -> return Nothing
+            Just le ->
+              return $ (dir,) <$> M.lookup name le
+        else
+          return Nothing
+
+
+-- unfortunately haddock-api doesn't export Haddock.Utils,
+-- Below is some blunt copy and paste file and anchor rendering logic (it's consistent from 8.6 to 8.10 so should just work)
+-- TODO: export it upstream and reuse here
+
+baseName :: ModuleName -> FilePath
+baseName = map (\c -> if c == '.' then '-' else c) . moduleNameString
+
+
+moduleHtmlFile :: Module -> FilePath
+moduleHtmlFile mdl = baseName (moduleName mdl) ++ ".html" 
+
+nameAnchorId :: OccName -> String
+nameAnchorId name = makeAnchorId (prefix : ':' : occNameString name)
+ where prefix | isValOcc name = 'v'
+              | otherwise     = 't'
+
+-- | Takes an arbitrary string and makes it a valid anchor ID. The mapping is
+-- identity preserving.
+makeAnchorId :: String -> String
+makeAnchorId [] = []
+makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r
+  where
+    escape p c | p c = [c]
+               | otherwise = '-' : show (ord c) ++ "-"
+    isLegal ':' = True
+    isLegal '_' = True
+    isLegal '.' = True
+    isLegal c = isAscii c && isAlphaNum c
+       -- NB: '-' is legal in IDs, but we use it as the escape char