a dirty PoC (GHC 8.10.2)

Author: DunetsNM

ghcide.cabal

@@ -50,7 +50,8 @@ library
         filepath,
         fingertree,
         Glob,
-        haddock-library >= 1.8,
+        haddock-library >= 1.9,
+        haddock-api >= 2.24.0,
         hashable,
         haskell-lsp-types == 0.22.*,
         haskell-lsp == 0.22.*,

hie.yaml

@@ -7,13 +7,13 @@ cradle:
     - path: "./"
       config:
         cradle:
-          cabal:
+          stack:
             - path: "./src"
-              component: "ghcide:lib:ghcide"
+              component: "ghcide:lib"
             - path: "./exe"
               component: "ghcide:exe:ghcide"
             - path: "./session-loader"
-              component: "ghcide:lib:ghcide"
+              component: "ghcide:lib"
             - path: "./test"
               component: "ghcide:test:ghcide-tests"
             - path: "./bench"

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

@@ -290,12 +290,12 @@ cacheDataProducer packageState tm deps = do
       varToCompl var = do
         let typ = Just $ varType var
             name = Var.varName var
-        docs <- evalGhcEnv packageState $ getDocumentationTryGhc curMod (tm_parsed_module tm : deps) name
+        docs <- evalGhcEnv packageState $ getDocumentationTryGhc Map.empty curMod (tm_parsed_module tm : deps) name
         return $ mkNameCompItem name curModName typ Nothing docs
 
       toCompItem :: Module -> ModuleName -> Name -> IO CompItem
       toCompItem m mn n = do
-        docs <- evalGhcEnv packageState $ getDocumentationTryGhc curMod (tm_parsed_module tm : deps) n
+        docs <- evalGhcEnv packageState $ getDocumentationTryGhc Map.empty curMod (tm_parsed_module tm : deps) n
         ty <- evalGhcEnv packageState $ catchSrcErrors "completion" $ do
                 name' <- lookupName m n
                 return $ name' >>= safeTyThingType

src/Development/IDE/Spans/Documentation.hs

@@ -28,14 +28,15 @@ import           Development.IDE.Spans.Common
 import           Development.IDE.Core.RuleTypes
 import           System.Directory
 import           System.FilePath
-
+import qualified Documentation.Haddock as H
 import           FastString
 import           SrcLoc (RealLocated)
 import           GhcMonad
 import           Packages
 import           Name
 import           Language.Haskell.LSP.Types (getUri, filePathToUri)
 import Data.Either
+import Control.Arrow (Arrow((&&&)))
 
 mkDocMap
   :: GhcMonad m
@@ -47,12 +48,15 @@ mkDocMap
 mkDocMap sources rm hmi deps =
   do mapM_ (`loadDepModule` Nothing) (reverse deps)
      loadDepModule hmi Nothing
-     d <- foldrM getDocs M.empty names
+     df <- getSessionDynFlags
+     nml <- findNameToHaddockModuleLinks df names
+      
+     d <- foldrM (getDocs nml) M.empty names
      k <- foldrM getType M.empty names
      pure $ DKMap d k
   where
-    getDocs n map = do
-      doc <- getDocumentationTryGhc mod sources n
+    getDocs nml n map = do
+      doc <- getDocumentationTryGhc nml mod sources n
       pure $ M.insert n doc map
     getType n map
       | isTcOcc $ occName n = do
@@ -67,13 +71,13 @@ lookupKind :: GhcMonad m => Module -> Name -> m (Maybe Type)
 lookupKind mod =
     fmap (either (const Nothing) (safeTyThingType =<<)) . catchSrcErrors "span" . lookupName mod
 
-getDocumentationTryGhc :: GhcMonad m => Module -> [ParsedModule] -> Name -> m SpanDoc
-getDocumentationTryGhc mod deps n = head <$> getDocumentationsTryGhc mod deps [n]
+getDocumentationTryGhc :: GhcMonad m => M.Map Name (FilePath, ModuleName) -> Module -> [ParsedModule] -> Name -> m SpanDoc
+getDocumentationTryGhc nml mod deps n = head <$> getDocumentationsTryGhc nml mod deps [n]
 
-getDocumentationsTryGhc :: GhcMonad m => Module -> [ParsedModule] -> [Name] -> m [SpanDoc]
+getDocumentationsTryGhc :: GhcMonad m => M.Map Name (FilePath, ModuleName) -> Module -> [ParsedModule] -> [Name] -> m [SpanDoc]
 -- Interfaces are only generated for GHC >= 8.6.
 -- In older versions, interface files do not embed Haddocks anyway
-getDocumentationsTryGhc mod sources names = do
+getDocumentationsTryGhc nml mod sources names = do
   res <- catchSrcErrors "docs" $ getDocsBatch mod names
   case res of
       Left _ -> mapM mkSpanDocText names
@@ -91,7 +95,8 @@ getDocumentationsTryGhc mod sources names = do
       (docFu, srcFu) <-
         case nameModule_maybe name of
           Just mod -> liftIO $ do
-            doc <- toFileUriText $ lookupDocHtmlForModule df mod
+            -- doc <- toFileUriText $ lookupDocHtmlForModule df mod
+            doc <- toFileUriText $ lookupHtmlDocForName (\pkgDocDir modDocName -> pkgDocDir </> modDocName <.> "html") nml name
             src <- toFileUriText $ lookupSrcHtmlForModule df mod
             return (doc, src)
           Nothing -> pure (Nothing, Nothing)
@@ -215,6 +220,51 @@ lookupHtmlForModule mkDocPath df m = do
       -- The file might use "." or "-" as separator
       map (`intercalate` chunks) [".", "-"]
 
+
+lookupHtmlDocForName :: (FilePath -> FilePath -> FilePath) -> M.Map Name (FilePath, ModuleName) -> Name -> IO (Maybe FilePath)
+lookupHtmlDocForName mkDocPath nml n = do
+  let mfs = concatMap go dirs
+  html <- findM doesFileExist 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
+    x = M.lookup n nml
+    dirs = fromMaybe [] $ (:[]) . fst <$> x
+    chunks = splitOn "." $ fromMaybe "" $ (moduleNameString . snd <$> x)
+    mns = map (`intercalate` chunks) [".", "-"]
+
+
+findNameToHaddockModuleLinks :: GhcMonad m => DynFlags -> [Name] -> m (M.Map Name (FilePath, ModuleName))
+findNameToHaddockModuleLinks df names = M.fromList . concat <$> mapM findNameUris fins
+  where
+    findNameUris (fi, ns) = do
+      -- TODO: resolve mangled html file name and anchor using Haddock api? is it possible?
+      -- TODO: fall back to old guesswork solution if haddock doesn't work ? 
+      -- TODO : clean up / ugly
+        
+      let dir = takeDirectory fi
+      exists <- liftIO $ doesFileExist fi
+      if exists
+        then do
+          ioe <- H.readInterfaceFile H.nameCacheFromGhc fi False
+          case ioe of
+            Left _ -> return []
+            Right (i :: H.InterfaceFile) ->
+              let le = H.ifLinkEnv i
+              in return $ catMaybes $ map (\n -> (n,) . (dir,) . moduleName <$> (M.lookup n le)) ns
+        else
+          return []
+
+    nameHaddockInterface_maybe n = do
+      m <- nameModule_maybe n
+      p <- lookupPackage df $ moduleUnitId m
+      i <- listToMaybe $ haddockInterfaces p
+      return (i, n)
+    fins = map (fst . head &&& map snd) $ groupOn fst $ catMaybes $ map nameHaddockInterface_maybe names
+
+
 lookupHtmls :: DynFlags -> UnitId -> Maybe [FilePath]
 lookupHtmls df ui =
   -- use haddockInterfaces instead of haddockHTMLs: GHC treats haddockHTMLs as URL not path 

stack-ghc-lib.yaml

@@ -13,7 +13,7 @@ extra-deps:
 - shake-0.18.5
 - regex-base-0.94.0.0
 - regex-tdfa-1.3.1.0
-- haddock-library-1.8.0
+- haddock-library-1.9.0
 - ghc-check-0.5.0.1
 - parser-combinators-1.2.1
 nix:

stack.yaml

@@ -1,24 +1,32 @@
-resolver: nightly-2019-09-21
+resolver: nightly-2020-06-19
+allow-newer: true
 packages:
 - .
 extra-deps:
-- aeson-1.4.6.0
 - haskell-lsp-0.22.0.0
 - haskell-lsp-types-0.22.0.0
 - lsp-test-0.11.0.6
-- hie-bios-0.7.1@rev:2
+- ghc-check-0.5.0.1
+- hie-bios-0.7.1
+
+# not yet in stackage
+- Chart-diagrams-1.9.3
+- SVGFonts-1.7.0.1
+- diagrams-1.4
+- diagrams-svg-1.4.3
+- diagrams-contrib-1.4.4
+- diagrams-core-1.4.2
+- diagrams-lib-1.4.3
+- diagrams-postscript-1.5
+- monoid-extras-0.5.1
+- svg-builder-0.1.1
+- active-0.2.0.14
+- dual-tree-0.2.2.1
+- force-layout-0.4.0.6
+- statestack-0.3
 - implicit-hie-0.1.1.0
 - implicit-hie-cradle-0.2.0.1
-- fuzzy-0.1.0.0
-- regex-pcre-builtin-0.95.1.1.8.43
-- regex-base-0.94.0.0
-- regex-tdfa-1.3.1.0
-- shake-0.18.5
-- parser-combinators-1.2.1
-- haddock-library-1.8.0
-- tasty-rerun-1.1.17
-- ghc-check-0.5.0.1
-- extra-1.7.2
+- haddock-api-2.24.0
 
 nix:
   packages: [zlib]