diff --git a/src/Development/IDE/Core/Compile.hs b/src/Development/IDE/Core/Compile.hs index 8a314eae..9b4d170d 100644 --- a/src/Development/IDE/Core/Compile.hs +++ b/src/Development/IDE/Core/Compile.hs @@ -82,19 +82,22 @@ computePackageDeps env pkg = do -- | Typecheck a single module using the supplied dependencies and packages. typecheckModule - :: HscEnv + :: IdeDefer + -> HscEnv -> [TcModuleResult] -> ParsedModule -> IO ([FileDiagnostic], Maybe TcModuleResult) -typecheckModule packageState deps pm = +typecheckModule (IdeDefer defer) packageState deps pm = + let demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id + in fmap (either (, Nothing) (second Just)) $ runGhcEnv packageState $ catchSrcErrors "typecheck" $ do setupEnv deps (warnings, tcm) <- withWarnings "typecheck" $ \tweak -> - GHC.typecheckModule pm{pm_mod_summary = tweak $ pm_mod_summary pm} + GHC.typecheckModule $ demoteIfDefer pm{pm_mod_summary = tweak $ pm_mod_summary pm} tcm2 <- mkTcModuleResult tcm - return (warnings, tcm2) + return (map unDefer warnings, tcm2) -- | Compile a single type-checked module to a 'CoreModule' value, or -- provide errors. @@ -126,8 +129,32 @@ compileModule packageState deps tmr = (cg_binds tidy) (mg_safe_haskell desugar) - return (warnings, core) + return (map snd warnings, core) +demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule +demoteTypeErrorsToWarnings = + (update_pm_mod_summary . update_hspp_opts) demoteTEsToWarns where + + demoteTEsToWarns :: DynFlags -> DynFlags + demoteTEsToWarns = (`gopt_set` Opt_DeferTypeErrors) + . (`gopt_set` Opt_DeferTypedHoles) + . (`gopt_set` Opt_DeferOutOfScopeVariables) + + update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary + update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms} + + update_pm_mod_summary :: (ModSummary -> ModSummary) -> ParsedModule -> ParsedModule + update_pm_mod_summary up pm = + pm{pm_mod_summary = up $ pm_mod_summary pm} + +unDefer :: (WarnReason, FileDiagnostic) -> FileDiagnostic +unDefer (Reason Opt_WarnDeferredTypeErrors , fd) = upgradeWarningToError fd +unDefer (Reason Opt_WarnTypedHoles , fd) = upgradeWarningToError fd +unDefer (Reason Opt_WarnDeferredOutOfScopeVariables, fd) = upgradeWarningToError fd +unDefer ( _ , fd) = fd + +upgradeWarningToError :: FileDiagnostic -> FileDiagnostic +upgradeWarningToError (nfp, fd) = (nfp, fd{_severity = Just DsError}) addRelativeImport :: ParsedModule -> DynFlags -> DynFlags addRelativeImport modu dflags = dflags diff --git a/src/Development/IDE/Core/Rules.hs b/src/Development/IDE/Core/Rules.hs index 9176ab44..6e48e5df 100644 --- a/src/Development/IDE/Core/Rules.hs +++ b/src/Development/IDE/Core/Rules.hs @@ -312,7 +312,8 @@ typeCheckRule = tms <- uses_ TypeCheck (transitiveModuleDeps deps) setPriority priorityTypeCheck packageState <- hscEnv <$> use_ GhcSession file - liftIO $ typecheckModule packageState tms pm + IdeOptions{ optDefer = defer} <- getIdeOptions + liftIO $ typecheckModule defer packageState tms pm generateCoreRule :: Rules () diff --git a/src/Development/IDE/GHC/Warnings.hs b/src/Development/IDE/GHC/Warnings.hs index 5a162164..354d8f0f 100644 --- a/src/Development/IDE/GHC/Warnings.hs +++ b/src/Development/IDE/GHC/Warnings.hs @@ -25,14 +25,14 @@ import Development.IDE.GHC.Error -- https://github.com/ghc/ghc/blob/5f1d949ab9e09b8d95319633854b7959df06eb58/compiler/main/GHC.hs#L623-L640 -- which basically says that log_action is taken from the ModSummary when GHC feels like it. -- The given argument lets you refresh a ModSummary log_action -withWarnings :: GhcMonad m => T.Text -> ((ModSummary -> ModSummary) -> m a) -> m ([FileDiagnostic], a) +withWarnings :: GhcMonad m => T.Text -> ((ModSummary -> ModSummary) -> m a) -> m ([(WarnReason, FileDiagnostic)], a) withWarnings diagSource action = do warnings <- liftIO $ newVar [] oldFlags <- getDynFlags let newAction :: DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO () - newAction dynFlags _ _ loc style msg = do - let d = diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags loc (queryQual style) msg - modifyVar_ warnings $ return . (d:) + newAction dynFlags wr _ loc style msg = do + let wr_d = fmap (wr,) $ diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags loc (queryQual style) msg + modifyVar_ warnings $ return . (wr_d:) setLogAction newAction res <- action $ \x -> x{ms_hspp_opts = (ms_hspp_opts x){log_action = newAction}} setLogAction $ log_action oldFlags diff --git a/src/Development/IDE/Types/Options.hs b/src/Development/IDE/Types/Options.hs index b2e39ebf..da8361db 100644 --- a/src/Development/IDE/Types/Options.hs +++ b/src/Development/IDE/Types/Options.hs @@ -7,6 +7,7 @@ module Development.IDE.Types.Options ( IdeOptions(..) , IdeReportProgress(..) + , IdeDefer(..) , clientSupportsProgress , IdePkgLocationOptions(..) , defaultIdeOptions @@ -44,9 +45,16 @@ data IdeOptions = IdeOptions -- ^ the ```language to use , optNewColonConvention :: Bool -- ^ whether to use new colon convention + , optDefer :: IdeDefer + -- ^ Whether to defer type errors, typed holes and out of scope + -- variables. Deferral allows the IDE to continue to provide + -- features such as diagnostics and go-to-definition, in + -- situations in which they would become unavailable because of + -- the presence of type errors, holes or unbound variables. } newtype IdeReportProgress = IdeReportProgress Bool +newtype IdeDefer = IdeDefer Bool clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress clientSupportsProgress caps = IdeReportProgress $ fromMaybe False $ @@ -63,6 +71,7 @@ defaultIdeOptions session = IdeOptions ,optReportProgress = IdeReportProgress False ,optLanguageSyntax = "haskell" ,optNewColonConvention = False + ,optDefer = IdeDefer True } diff --git a/test/exe/Main.hs b/test/exe/Main.hs index b4e233f3..9e6f6426 100644 --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -85,6 +85,43 @@ diagnosticTests = testGroup "diagnostics" , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")] ) ] + , testSession "typed hole" $ do + let content = T.unlines + [ "module Testing where" + , "foo :: Int -> String" + , "foo a = _ a" + ] + _ <- openDoc' "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs" + , [(DsError, (2, 8), "Found hole: _ :: Int -> String")] + ) + ] + + , testGroup "deferral" $ + let sourceA a = T.unlines + [ "module A where" + , "a :: Int" + , "a = " <> a] + sourceB = T.unlines + [ "module B where" + , "import A" + , "b :: Float" + , "b = True"] + bMessage = "Couldn't match expected type 'Float' with actual type 'Bool'" + expectedDs aMessage = + [ ("A.hs", [(DsError, (2,4), aMessage)]) + , ("B.hs", [(DsError, (3,4), bMessage)])] + deferralTest title binding message = testSession title $ do + _ <- openDoc' "A.hs" "haskell" $ sourceA binding + _ <- openDoc' "B.hs" "haskell" sourceB + expectDiagnostics $ expectedDs message + in + [ deferralTest "type error" "True" "Couldn't match expected type" + , deferralTest "typed hole" "_" "Found hole" + , deferralTest "out of scope var" "unbound" "Variable not in scope" + ] + , testSession "remove required module" $ do let contentA = T.unlines [ "module ModuleA where" ] docA <- openDoc' "ModuleA.hs" "haskell" contentA