Skip to content

Commit 2a2bc3d

Browse files
committed
Return structured warnings in TcModuleResult by copying from Driver
1 parent e4ca141 commit 2a2bc3d

File tree

4 files changed

+145
-16
lines changed

4 files changed

+145
-16
lines changed

ghcide/ghcide.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -150,6 +150,7 @@ library
150150
Development.IDE.GHC.Compat
151151
Development.IDE.GHC.Compat.Core
152152
Development.IDE.GHC.Compat.CmdLine
153+
Development.IDE.GHC.Compat.Driver
153154
Development.IDE.GHC.Compat.Env
154155
Development.IDE.GHC.Compat.Iface
155156
Development.IDE.GHC.Compat.Logger

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

Lines changed: 17 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -105,6 +105,7 @@ import System.IO.Extra (fixIO, newTempFileWithin)
105105

106106
import qualified GHC as G
107107
import GHC.Tc.Gen.Splice
108+
import GHC.Types.Error
108109
import GHC.Types.ForeignStubs
109110
import GHC.Types.HpcInfo
110111
import GHC.Types.TypeEnv
@@ -133,6 +134,8 @@ import GHC.Unit.Module.Warnings
133134
import Development.IDE.Core.FileStore (shareFilePath)
134135
#endif
135136

137+
import Development.IDE.GHC.Compat.Driver (hscTypecheckRenameWithDiagnostics)
138+
136139
--Simple constants to make sure the source is consistently named
137140
sourceTypecheck :: T.Text
138141
sourceTypecheck = "typecheck"
@@ -187,20 +190,18 @@ typecheckModule (IdeDefer defer) hsc tc_helpers pm = do
187190
case initialized of
188191
Left errs -> return (errs, Nothing)
189192
Right (modSummary', hscEnv) -> do
190-
(warnings, etcm) <- withWarnings sourceTypecheck $ \tweak ->
191-
let
192-
session = tweak (hscSetFlags dflags hscEnv)
193-
-- TODO: maybe settings ms_hspp_opts is unnecessary?
194-
mod_summary'' = modSummary' { ms_hspp_opts = hsc_dflags session}
195-
in
196-
catchSrcErrors (hsc_dflags hscEnv) sourceTypecheck $ do
197-
tcRnModule session tc_helpers $ demoteIfDefer pm{pm_mod_summary = mod_summary''}
198-
let errorPipeline = unDefer . hideDiag dflags . tagDiag
199-
diags = map errorPipeline warnings
200-
deferredError = any fst diags
193+
etcm <-
194+
catchSrcErrors (hsc_dflags hscEnv) sourceTypecheck $ do
195+
tcRnModule hscEnv tc_helpers $ demoteIfDefer pm{pm_mod_summary = modSummary'}
201196
case etcm of
202-
Left errs -> return (map snd diags ++ errs, Nothing)
203-
Right tcm -> return (map snd diags, Just $ tcm{tmrDeferredError = deferredError})
197+
Left errs -> return (errs, Nothing)
198+
Right tcm ->
199+
let addReason diag = map (Just (diagnosticReason (errMsgDiagnostic diag)),) $ diagFromErrMsg sourceTypecheck (hsc_dflags hscEnv) diag
200+
errorPipeline = map (unDefer . hideDiag dflags . tagDiag) . addReason
201+
diags = concatMap errorPipeline $ Compat.getMessages $ tmrWarnings tcm
202+
deferredError = any fst diags
203+
in
204+
return (map snd diags, Just $ tcm{tmrDeferredError = deferredError})
204205
where
205206
demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id
206207

@@ -413,9 +414,9 @@ tcRnModule hsc_env tc_helpers pmod = do
413414
let ms = pm_mod_summary pmod
414415
hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) hsc_env
415416

416-
((tc_gbl_env', mrn_info), splices, mod_env)
417+
(((tc_gbl_env', mrn_info), warning_messages), splices, mod_env)
417418
<- captureSplicesAndDeps tc_helpers hsc_env_tmp $ \hscEnvTmp ->
418-
do hscTypecheckRename hscEnvTmp ms $
419+
do hscTypecheckRenameWithDiagnostics hscEnvTmp ms $
419420
HsParsedModule { hpm_module = parsedSource pmod,
420421
hpm_src_files = pm_extra_src_files pmod,
421422
hpm_annotations = pm_annotations pmod }
@@ -427,7 +428,7 @@ tcRnModule hsc_env tc_helpers pmod = do
427428
mod_env_anns = map (\(mod, hash) -> Annotation (ModuleTarget mod) $ toSerialized BS.unpack hash)
428429
(moduleEnvToList mod_env)
429430
tc_gbl_env = tc_gbl_env' { tcg_ann_env = extendAnnEnvList (tcg_ann_env tc_gbl_env') mod_env_anns }
430-
pure (TcModuleResult pmod rn_info tc_gbl_env splices False mod_env)
431+
pure (TcModuleResult pmod rn_info tc_gbl_env splices False mod_env warning_messages)
431432

432433

433434
-- Note [Clearing mi_globals after generating an iface]

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

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -45,6 +45,7 @@ import Ide.Logger (Pretty (..),
4545
viaShow)
4646
import Language.LSP.Protocol.Types (Int32,
4747
NormalizedFilePath)
48+
import GHC.Driver.Errors.Types (WarningMessages)
4849

4950
data LinkableType = ObjectLinkable | BCOLinkable
5051
deriving (Eq,Ord,Show, Generic)
@@ -157,6 +158,7 @@ data TcModuleResult = TcModuleResult
157158
-- ^ Which modules did we need at runtime while compiling this file?
158159
-- Used for recompilation checking in the presence of TH
159160
-- Stores the hash of their core file
161+
, tmrWarnings :: WarningMessages
160162
}
161163
instance Show TcModuleResult where
162164
show = show . pm_mod_summary . tmrParsed
Lines changed: 125 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,125 @@
1+
-- This module copies parts of the driver code in GHC.Main.Driver to provide
2+
-- `hscTypecheckRenameWithDiagnostics`.
3+
module Development.IDE.GHC.Compat.Driver
4+
( hscTypecheckRenameWithDiagnostics
5+
) where
6+
7+
import GHC.Driver.Main
8+
import GHC.Driver.Session
9+
import GHC.Driver.Env
10+
import GHC.Driver.Errors.Types
11+
import GHC.Hs
12+
import GHC.Hs.Dump
13+
import GHC.Iface.Ext.Ast ( mkHieFile )
14+
import GHC.Iface.Ext.Types ( getAsts, hie_asts, hie_module )
15+
import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result)
16+
import GHC.Iface.Ext.Debug ( diffFile, validateScopes )
17+
import GHC.Core
18+
import GHC.Tc.Module
19+
import GHC.Tc.Utils.Monad
20+
import GHC.Unit
21+
import GHC.Unit.Module.ModDetails
22+
import GHC.Unit.Module.ModIface
23+
import GHC.Unit.Module.ModSummary
24+
import GHC.Types.SourceFile
25+
import GHC.Types.SrcLoc
26+
import GHC.Utils.Panic.Plain
27+
import GHC.Utils.Error
28+
import GHC.Utils.Outputable
29+
import GHC.Utils.Logger
30+
import GHC.Data.FastString
31+
import GHC.Data.Maybe
32+
import Control.Monad
33+
34+
-- -----------------------------------------------------------------------------
35+
-- | Rename and typecheck a module the same way that GHC does, additionally returning the renamed syntax and the diagnostics produced.
36+
hscTypecheckRenameWithDiagnostics :: HscEnv -> ModSummary -> HsParsedModule
37+
-> IO ((TcGblEnv, RenamedStuff), Messages GhcMessage)
38+
hscTypecheckRenameWithDiagnostics hsc_env mod_summary rdr_module = runHsc' hsc_env $
39+
hsc_typecheck True mod_summary (Just rdr_module)
40+
41+
-- | A bunch of logic piled around @tcRnModule'@, concerning a) backpack
42+
-- b) concerning dumping rename info and hie files. It would be nice to further
43+
-- separate this stuff out, probably in conjunction better separating renaming
44+
-- and type checking (#17781).
45+
hsc_typecheck :: Bool -- ^ Keep renamed source?
46+
-> ModSummary -> Maybe HsParsedModule
47+
-> Hsc (TcGblEnv, RenamedStuff)
48+
hsc_typecheck keep_rn mod_summary mb_rdr_module = do
49+
hsc_env <- getHscEnv
50+
let hsc_src = ms_hsc_src mod_summary
51+
dflags = hsc_dflags hsc_env
52+
home_unit = hsc_home_unit hsc_env
53+
outer_mod = ms_mod mod_summary
54+
mod_name = moduleName outer_mod
55+
outer_mod' = mkHomeModule home_unit mod_name
56+
inner_mod = homeModuleNameInstantiation home_unit mod_name
57+
src_filename = ms_hspp_file mod_summary
58+
real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1
59+
keep_rn' = gopt Opt_WriteHie dflags || keep_rn
60+
massert (isHomeModule home_unit outer_mod)
61+
tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod)
62+
then ioMsgMaybe $ hoistTcRnMessage $ tcRnInstantiateSignature hsc_env outer_mod' real_loc
63+
else
64+
do hpm <- case mb_rdr_module of
65+
Just hpm -> return hpm
66+
Nothing -> hscParse' mod_summary
67+
tc_result0 <- tcRnModule' mod_summary keep_rn' hpm
68+
if hsc_src == HsigFile
69+
then do (iface, _) <- liftIO $ hscSimpleIface hsc_env Nothing tc_result0 mod_summary
70+
ioMsgMaybe $ hoistTcRnMessage $
71+
tcRnMergeSignatures hsc_env hpm tc_result0 iface
72+
else return tc_result0
73+
-- TODO are we extracting anything when we merely instantiate a signature?
74+
-- If not, try to move this into the "else" case above.
75+
rn_info <- extract_renamed_stuff mod_summary tc_result
76+
return (tc_result, rn_info)
77+
78+
extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff
79+
extract_renamed_stuff mod_summary tc_result = do
80+
let rn_info = getRenamedStuff tc_result
81+
82+
dflags <- getDynFlags
83+
logger <- getLogger
84+
liftIO $ putDumpFileMaybe logger Opt_D_dump_rn_ast "Renamer"
85+
FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations rn_info)
86+
87+
-- Create HIE files
88+
when (gopt Opt_WriteHie dflags) $ do
89+
-- I assume this fromJust is safe because `-fwrite-hie-file`
90+
-- enables the option which keeps the renamed source.
91+
hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info)
92+
let out_file = ml_hie_file $ ms_location mod_summary
93+
liftIO $ writeHieFile out_file hieFile
94+
liftIO $ putDumpFileMaybe logger Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile)
95+
96+
-- Validate HIE files
97+
when (gopt Opt_ValidateHie dflags) $ do
98+
hs_env <- Hsc $ \e w -> return (e, w)
99+
liftIO $ do
100+
-- Validate Scopes
101+
case validateScopes (hie_module hieFile) $ getAsts $ hie_asts hieFile of
102+
[] -> putMsg logger $ text "Got valid scopes"
103+
xs -> do
104+
putMsg logger $ text "Got invalid scopes"
105+
mapM_ (putMsg logger) xs
106+
-- Roundtrip testing
107+
file' <- readHieFile (hsc_NC hs_env) out_file
108+
case diffFile hieFile (hie_file_result file') of
109+
[] ->
110+
putMsg logger $ text "Got no roundtrip errors"
111+
xs -> do
112+
putMsg logger $ text "Got roundtrip errors"
113+
let logger' = updateLogFlags logger (log_set_dopt Opt_D_ppr_debug)
114+
mapM_ (putMsg logger') xs
115+
return rn_info
116+
117+
-- | Generate a stripped down interface file, e.g. for boot files or when ghci
118+
-- generates interface files. See Note [simpleTidyPgm - mkBootModDetailsTc]
119+
hscSimpleIface :: HscEnv
120+
-> Maybe CoreProgram
121+
-> TcGblEnv
122+
-> ModSummary
123+
-> IO (ModIface, ModDetails)
124+
hscSimpleIface hsc_env mb_core_program tc_result summary
125+
= runHsc hsc_env $ hscSimpleIface' mb_core_program tc_result summary

0 commit comments

Comments
 (0)