Show documentation on hover for symbols defined in the same module (#691

)

* Show documentation on hover for symbols defined in the same module

When parsing a module, if parsing haddocks succeeds, then use them
Previously, even though we were parsing modules twice, with and without
haddocks, we were just returning the result of parsing without haddocks.

The reason for this was that Opt_KeepRawTokenStream and Opt_Haddock do
not interact nicely. We decided that for now it was better to fix an
actual issue and then solve the problem when hlint requires a module
with Opt_KeepRawTokenStream.

* Add option to decide which ParsedModule to return

src/Development/IDE/Core/RuleTypes.hs

@@ -61,6 +61,9 @@ type instance RuleResult GetKnownFiles = HS.HashSet NormalizedFilePath
 -- that module.
 data TcModuleResult = TcModuleResult
     { tmrModule     :: TypecheckedModule
+    -- ^ warning, the ModIface in the tm_checked_module_info of the
+    -- TypecheckedModule will always be Nothing, use the ModIface in the
+    -- HomeModInfo instead
     , tmrModInfo    :: HomeModInfo
     , tmrDeferedError :: !Bool -- ^ Did we defer any type errors for this module?
     }

src/Development/IDE/Core/Rules.hs

@@ -233,6 +233,12 @@ priorityGenerateCore = Priority (-1)
 priorityFilesOfInterest :: Priority
 priorityFilesOfInterest = Priority (-2)
 
+-- | IMPORTANT FOR HLINT INTEGRATION:
+-- We currently parse the module both with and without Opt_Haddock, and
+-- return the one with Haddocks if it -- succeeds. However, this may not work
+-- for hlint, and we might need to save the one without haddocks too.
+-- See https://github.com/digital-asset/ghcide/pull/350#discussion_r370878197
+-- and https://github.com/mpickering/ghcide/pull/22#issuecomment-625070490
 getParsedModuleRule :: Rules ()
 getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do
     sess <- use_ GhcSession file
@@ -251,18 +257,28 @@ getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do
         then
             liftIO mainParse
         else do
-            let haddockParse = do
-                    (_, (!diagsHaddock, _)) <-
-                        getParsedModuleDefinition (withOptHaddock hsc) opt comp_pkgs file modTime contents
-                    return diagsHaddock
-
-            ((fingerPrint, (diags, res)), diagsHaddock) <-
-                -- parse twice, with and without Haddocks, concurrently
-                -- we want warnings if parsing with Haddock fails
-                -- but if we parse with Haddock we lose annotations
-                liftIO $ concurrently mainParse haddockParse
-
-            return (fingerPrint, (mergeParseErrorsHaddock diags diagsHaddock, res))
+            let haddockParse = getParsedModuleDefinition (withOptHaddock hsc) opt comp_pkgs file modTime contents
+
+            -- parse twice, with and without Haddocks, concurrently
+            -- we cannot ignore Haddock parse errors because files of
+            -- non-interest are always parsed with Haddocks
+            -- If we can parse Haddocks, might as well use them
+            --
+            -- HLINT INTEGRATION: might need to save the other parsed module too
+            ((fp,(diags,res)),(fph,(diagsh,resh))) <- liftIO $ concurrently mainParse haddockParse
+
+            -- Merge haddock and regular diagnostics so we can always report haddock
+            -- parse errors
+            let diagsM = mergeParseErrorsHaddock diags diagsh
+            case resh of
+              Just _
+                | HaddockParse <- optHaddockParse opt
+                -> pure (fph, (diagsM, resh))
+              -- If we fail to parse haddocks, report the haddock diagnostics as well and
+              -- return the non-haddock parse.
+              -- This seems to be the correct behaviour because the Haddock flag is added
+              -- by us and not the user, so our IDE shouldn't stop working because of it.
+              _ -> pure (fp, (diagsM, res))
 
 
 withOptHaddock :: HscEnv -> HscEnv
@@ -281,7 +297,6 @@ mergeParseErrorsHaddock normal haddock = normal ++
     fixMessage x | "parse error " `T.isPrefixOf` x = "Haddock " <> x
                  | otherwise = "Haddock: " <> x
 
-
 getParsedModuleDefinition :: HscEnv -> IdeOptions -> [PackageName] -> NormalizedFilePath -> UTCTime -> Maybe T.Text -> IO (Maybe ByteString, ([FileDiagnostic], Maybe ParsedModule))
 getParsedModuleDefinition packageState opt comp_pkgs file modTime contents = do
     let fp = fromNormalizedFilePath file

src/Development/IDE/Types/Options.hs

@@ -24,6 +24,7 @@ module Development.IDE.Types.Options
   , defaultLspConfig
   , CheckProject(..)
   , CheckParents(..)
+  , OptHaddockParse(..)
   ) where
 
 import Development.Shake
@@ -88,8 +89,16 @@ data IdeOptions = IdeOptions
     -- ^ Whether to typecheck the entire project on load
   , optCheckParents :: CheckParents
     -- ^ When to typecheck reverse dependencies of a file
+  , optHaddockParse :: OptHaddockParse
+    -- ^ Whether to return result of parsing module with Opt_Haddock.
+    --   Otherwise, return the result of parsing without Opt_Haddock, so
+    --   that the parsed module contains the result of Opt_KeepRawTokenStream,
+    --   which might be necessary for hlint.
   }
 
+data OptHaddockParse = HaddockParse | NoHaddockParse
+  deriving (Eq,Ord,Show,Enum)
+
 newtype CheckProject = CheckProject { shouldCheckProject :: Bool }
   deriving stock (Eq, Ord, Show)
   deriving newtype (FromJSON,ToJSON)
@@ -147,6 +156,7 @@ defaultIdeOptions session = IdeOptions
     ,optTesting = IdeTesting False
     ,optCheckProject = checkProject defaultLspConfig
     ,optCheckParents = checkParents defaultLspConfig
+    ,optHaddockParse = HaddockParse
     }
 
 

test/exe/Main.hs

@@ -2186,7 +2186,7 @@ findDefinitionAndHoverTests = let
   , test  yes    yes    mclL36     mcl           "top-level fn 1st clause"
   , test  yes    yes    mclL37     mcl           "top-level fn 2nd clause         #246"
   , test  yes    yes    spaceL37   space        "top-level fn on space #315"
-  , test  no     broken docL41     doc           "documentation                     #7"
+  , test  no     yes    docL41     doc           "documentation                     #7"
   , test  no     yes    eitL40     kindE         "kind of Either                  #273"
   , test  no     yes    intL40     kindI         "kind of Int                     #273"
   , test  no     broken tvrL40     kindV         "kind of (* -> *) type variable  #273"