Defer type errors

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

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 ()

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

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
     }
 
 

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