Change getDocumentation to work with parsed modules (#413)

* Refactor getDocumentation to work with parsed modules

* Fix names to express semantic rather than type information

Author: pepeiborra

src/Development/IDE/Core/Rules.hs

@@ -266,10 +266,10 @@ getSpanInfoRule =
     define $ \GetSpanInfo file -> do
         tc <- use_ TypeCheck file
         deps <- maybe (TransitiveDependencies [] []) fst <$> useWithStale GetDependencies file
-        tms <- mapMaybe (fmap fst) <$> usesWithStale TypeCheck (transitiveModuleDeps deps)
+        parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule (transitiveModuleDeps deps)
         (fileImports, _) <- use_ GetLocatedImports file
         packageState <- hscEnv <$> use_ GhcSession file
-        x <- liftIO $ getSrcSpanInfos packageState fileImports tc tms
+        x <- liftIO $ getSrcSpanInfos packageState fileImports tc parsedDeps
         return ([], Just x)
 
 -- Typechecks a module.

src/Development/IDE/Plugin/Completions.hs

@@ -32,13 +32,13 @@ produceCompletions :: Rules ()
 produceCompletions =
     define $ \ProduceCompletions file -> do
         deps <- maybe (TransitiveDependencies [] []) fst <$> useWithStale GetDependencies file
-        tms <- mapMaybe (fmap fst) <$> usesWithStale TypeCheck (transitiveModuleDeps deps)
+        parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule (transitiveModuleDeps deps)
         tm <- fmap fst <$> useWithStale TypeCheck file
         packageState <- fmap (hscEnv . fst) <$> useWithStale GhcSession file
         case (tm, packageState) of
             (Just tm', Just packageState') -> do
                 cdata <- liftIO $ cacheDataProducer packageState' (hsc_dflags packageState')
-                                                    (tmrModule tm') (map tmrModule tms)
+                                                    (tmrModule tm') parsedDeps
                 return ([], Just (cdata, tm'))
             _ -> return ([], Nothing)
 

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

@@ -210,8 +210,8 @@ mkPragmaCompl label insertText =
     Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)
     Nothing Nothing Nothing Nothing Nothing
 
-cacheDataProducer :: HscEnv -> DynFlags -> TypecheckedModule -> [TypecheckedModule] -> IO CachedCompletions
-cacheDataProducer packageState dflags tm tcs = do
+cacheDataProducer :: HscEnv -> DynFlags -> TypecheckedModule -> [ParsedModule] -> IO CachedCompletions
+cacheDataProducer packageState dflags tm deps = do
   let parsedMod = tm_parsed_module tm
       curMod = moduleName $ ms_mod $ pm_mod_summary parsedMod
       Just (_,limports,_,_) = tm_renamed_source tm
@@ -269,12 +269,12 @@ cacheDataProducer packageState dflags tm tcs = do
         let typ = Just $ varType var
             name = Var.varName var
             label = T.pack $ showGhc name
-        docs <- runGhcEnv packageState $ getDocumentationTryGhc (tm:tcs) name
+        docs <- runGhcEnv packageState $ getDocumentationTryGhc (tm_parsed_module tm : deps) name
         return $ CI name (showModName curMod) typ label Nothing docs
 
       toCompItem :: ModuleName -> Name -> IO CompItem
       toCompItem mn n = do
-        docs <- runGhcEnv packageState $ getDocumentationTryGhc (tm:tcs) n
+        docs <- runGhcEnv packageState $ getDocumentationTryGhc (tm_parsed_module tm : deps) n
 -- lookupName uses runInteractiveHsc, i.e., GHCi stuff which does not work with GHCi
 -- and leads to fun errors like "Cannot continue after interface file error".
 #ifdef GHC_LIB

src/Development/IDE/Spans/Calculate.hs

@@ -51,25 +51,25 @@ getSrcSpanInfos
     :: HscEnv
     -> [(Located ModuleName, Maybe NormalizedFilePath)]
     -> TcModuleResult
-    -> [TcModuleResult]
+    -> [ParsedModule]
     -> IO SpansInfo
-getSrcSpanInfos env imports tc tms =
+getSrcSpanInfos env imports tc deps =
     runGhcEnv env $
-        getSpanInfo imports (tmrModule tc) (map tmrModule tms)
+        getSpanInfo imports (tmrModule tc) deps
 
 -- | Get ALL source spans in the module.
 getSpanInfo :: GhcMonad m
             => [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ imports
             -> TypecheckedModule
-            -> [TypecheckedModule]
+            -> [ParsedModule]
             -> m SpansInfo
-getSpanInfo mods tcm tcms =
+getSpanInfo mods tcm deps =
   do let tcs = tm_typechecked_source tcm
          bs  = listifyAllSpans  tcs :: [LHsBind GhcTc]
          es  = listifyAllSpans  tcs :: [LHsExpr GhcTc]
          ps  = listifyAllSpans' tcs :: [Pat GhcTc]
          ts  = listifyAllSpans $ tm_renamed_source tcm :: [LHsType GhcRn]
-         allModules = tcm:tcms
+         allModules = tm_parsed_module tcm : deps
          funBinds = funBindMap $ tm_parsed_module tcm
      bts <- mapM (getTypeLHsBind allModules funBinds) bs   -- binds
      ets <- mapM (getTypeLHsExpr allModules) es -- expressions
@@ -117,19 +117,19 @@ ieLNames _ = []
 
 -- | Get the name and type of a binding.
 getTypeLHsBind :: (GhcMonad m)
-               => [TypecheckedModule]
+               => [ParsedModule]
                -> OccEnv (HsBind GhcPs)
                -> LHsBind GhcTc
                -> m [(SpanSource, SrcSpan, Maybe Type, SpanDoc)]
-getTypeLHsBind tms funBinds (L _spn FunBind{fun_id = pid})
+getTypeLHsBind deps funBinds (L _spn FunBind{fun_id = pid})
   | Just FunBind {fun_matches = MG{mg_alts=L _ matches}} <- lookupOccEnv funBinds (occName $ unLoc pid) = do
   let name = getName (unLoc pid)
-  docs <- getDocumentationTryGhc tms name
+  docs <- getDocumentationTryGhc deps name
   return [(Named name, getLoc mc_fun, Just (varType (unLoc pid)), docs) | match <- matches, FunRhs{mc_fun = mc_fun} <- [m_ctxt $ unLoc match] ]
 -- In theory this shouldn’t ever fail but if it does, we can at least show the first clause.
-getTypeLHsBind tms _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) = do
+getTypeLHsBind deps _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) = do
   let name = getName (unLoc pid)
-  docs <- getDocumentationTryGhc tms name
+  docs <- getDocumentationTryGhc deps name
   return [(Named name, getLoc pid, Just (varType (unLoc pid)), docs)]
 getTypeLHsBind _ _ _ = return []
 
@@ -142,17 +142,17 @@ getConstraintsLHsBind _ = []
 
 -- | Get the name and type of an expression.
 getTypeLHsExpr :: (GhcMonad m)
-               => [TypecheckedModule]
+               => [ParsedModule]
                -> LHsExpr GhcTc
                -> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc))
-getTypeLHsExpr tms e = do
+getTypeLHsExpr deps e = do
   hs_env <- getSession
   (_, mbe) <- liftIO (deSugarExpr hs_env e)
   case mbe of
     Just expr -> do
       let ss = getSpanSource (unLoc e)
       docs <- case ss of
-                Named n -> getDocumentationTryGhc tms n
+                Named n -> getDocumentationTryGhc deps n
                 _       -> return emptySpanDoc
       return $ Just (ss, getLoc e, Just (CoreUtils.exprType expr), docs)
     Nothing -> return Nothing
@@ -198,13 +198,13 @@ getTypeLHsExpr tms e = do
 
 -- | Get the name and type of a pattern.
 getTypeLPat :: (GhcMonad m)
-            => [TypecheckedModule]
+            => [ParsedModule]
             -> Pat GhcTc
             -> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc))
-getTypeLPat tms pat = do
+getTypeLPat deps pat = do
   let (src, spn) = getSpanSource pat
   docs <- case src of
-            Named n -> getDocumentationTryGhc tms n
+            Named n -> getDocumentationTryGhc deps n
             _       -> return emptySpanDoc
   return $ Just (src, spn, Just (hsPatType pat), docs)
   where
@@ -216,12 +216,12 @@ getTypeLPat tms pat = do
 
 getLHsType
     :: GhcMonad m
-    => [TypecheckedModule]
+    => [ParsedModule]
     -> LHsType GhcRn
     -> m [(SpanSource, SrcSpan, Maybe Type, SpanDoc)]
-getLHsType tms (L spn (HsTyVar U _ v)) = do
+getLHsType deps (L spn (HsTyVar U _ v)) = do
   let n = unLoc v
-  docs <- getDocumentationTryGhc tms n
+  docs <- getDocumentationTryGhc deps n
 #ifdef GHC_LIB
   let ty = Right Nothing
 #else

src/Development/IDE/Spans/Documentation.hs

@@ -14,33 +14,33 @@ import           Data.List.Extra
 import qualified Data.Map as M
 import           Data.Maybe
 import qualified Data.Text as T
+import           Development.IDE.GHC.Compat
 import           Development.IDE.GHC.Error
 import           Development.IDE.Spans.Common
 import           FastString
-import           GHC
 import SrcLoc
 
 
 getDocumentationTryGhc
   :: GhcMonad m
-  => [TypecheckedModule]
+  => [ParsedModule]
   -> Name
   -> m SpanDoc
 -- getDocs goes through the GHCi codepaths which cause problems on ghc-lib.
 -- See https://github.com/digital-asset/daml/issues/4152 for more details.
 #if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)
-getDocumentationTryGhc tcs name = do
+getDocumentationTryGhc sources name = do
   res <- catchSrcErrors "docs" $ getDocs name
   case res of
     Right (Right (Just docs, _)) -> return $ SpanDocString docs
-    _ -> return $ SpanDocText $ getDocumentation tcs name
+    _ -> return $ SpanDocText $ getDocumentation sources name
 #else
-getDocumentationTryGhc tcs name = do
-  return $ SpanDocText $ getDocumentation tcs name
+getDocumentationTryGhc sources name = do
+  return $ SpanDocText $ getDocumentation sources name
 #endif
 
 getDocumentation
- :: [TypecheckedModule] -- ^ All of the possible modules it could be defined in.
+ :: [ParsedModule] -- ^ All of the possible modules it could be defined in.
  ->  Name -- ^ The name you want documentation for.
  -> [T.Text]
 -- This finds any documentation between the name you want
@@ -50,16 +50,18 @@ getDocumentation
 -- may be edge cases where it is very wrong).
 -- TODO : Build a version of GHC exactprint to extract this information
 -- more accurately.
-getDocumentation tcs targetName = fromMaybe [] $ do
+getDocumentation sources targetName = fromMaybe [] $ do
   -- Find the module the target is defined in.
   targetNameSpan <- realSpan $ nameSrcSpan targetName
   tc <-
     find ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName)
-      $ reverse tcs -- TODO : Is reversing the list here really neccessary?
-  -- Names bound by the module (we want to exclude non-"top-level"
-  -- bindings but unfortunately we get all here).
-  let bs = mapMaybe name_of_bind
-               (listifyAllSpans (tm_typechecked_source tc) :: [LHsBind GhcTc])
+      $ reverse sources -- TODO : Is reversing the list here really neccessary?
+
+  -- Top level names bound by the module
+  let bs = [ n | let L _ HsModule{hsmodDecls} = pm_parsed_source tc
+           , L _ (ValD hsbind) <- hsmodDecls
+           , Just n <- [name_of_bind hsbind]
+           ]
   -- Sort the names' source spans.
   let sortedSpans = sortedNameSpans bs
   -- Now go ahead and extract the docs.
@@ -81,16 +83,16 @@ getDocumentation tcs targetName = fromMaybe [] $ do
   where
     -- Get the name bound by a binding. We only concern ourselves with
     -- @FunBind@ (which covers functions and variables).
-    name_of_bind :: LHsBind GhcTc -> Maybe Name
-    name_of_bind (L _ FunBind {fun_id}) = Just (getName (unLoc fun_id))
+    name_of_bind :: HsBind GhcPs -> Maybe (Located RdrName)
+    name_of_bind FunBind {fun_id} = Just fun_id
     name_of_bind _ = Nothing
     -- Get source spans from names, discard unhelpful spans, remove
     -- duplicates and sort.
-    sortedNameSpans :: [Name] -> [RealSrcSpan]
-    sortedNameSpans ls = nubSort (mapMaybe (realSpan . nameSrcSpan) ls)
+    sortedNameSpans :: [Located RdrName] -> [RealSrcSpan]
+    sortedNameSpans ls = nubSort (mapMaybe (realSpan . getLoc) ls)
     isBetween target before after = before <= target && target <= after
-    ann = snd . pm_annotations . tm_parsed_module
-    annotationFileName :: TypecheckedModule -> Maybe FastString
+    ann = snd . pm_annotations
+    annotationFileName :: ParsedModule -> Maybe FastString
     annotationFileName = fmap srcSpanFile . listToMaybe . realSpans . ann
     realSpans :: M.Map SrcSpan [Located a] -> [RealSrcSpan]
     realSpans =