Easy way to defer type errors (implements #8353)

Added load! and reload! commands, effectively setting
"-fdefer-type-errors" before loading a file and
unsetting it after loading if it has not been set before.

Differential Revision: https://phabricator.haskell.org/D960

7 files changed, 117 insertions, 25 deletions

diff --git a/docs/users_guide/7.12.1-notes.xml b/docs/users_guide/7.12.1-notes.xml
index f217b91cdd..dc191d2638 100644
--- a/docs/users_guide/7.12.1-notes.xml
+++ b/docs/users_guide/7.12.1-notes.xml
@@ -101,6 +101,11 @@
                     commands now take an optional count allowing the user to move forward or
                     backward in history several steps at a time.
                </para>
+               <para>
+                    Added commands <literal>:load!</literal> and <literal>:reload!</literal>,
+                    effectively setting "-fdefer-type-errors" before loading a module and
+                    unsetting it after loading if it has not been set before (#8353).
+               </para>
            </listitem>
        </itemizedlist>
     </sect3>
diff --git a/docs/users_guide/ghci.xml b/docs/users_guide/ghci.xml
index a1271e1ac1..399cda90ea 100644
--- a/docs/users_guide/ghci.xml
+++ b/docs/users_guide/ghci.xml
@@ -674,13 +674,13 @@ Prelude>
       <title>What's really in scope at the prompt?</title>
 
       <para>When you type an expression at the prompt, what
-      identifiers and types are in scope?  
+      identifiers and types are in scope?
       GHCi provides a flexible
       way to control exactly how the context for an expression is
       constructed:
   <itemizedlist>
   <listitem><para>
-        The <literal>:load</literal>, <literal>:add</literal>, 
+        The <literal>:load</literal>, <literal>:add</literal>,
         and <literal>:reload</literal> commands (<xref linkend="ghci-load-scope"/>).
    </para></listitem>
   <listitem><para>
@@ -702,8 +702,8 @@ Prelude>
    <sect3 id="ghci-load-scope">
    <title>The effect of <literal>:load</literal> on what is in scope</title>
       <para>
-      The <literal>:load</literal>, <literal>:add</literal>, and <literal>:reload</literal> 
-       commands (<xref linkend="loading-source-files"/> 
+      The <literal>:load</literal>, <literal>:add</literal>, and <literal>:reload</literal>
+       commands (<xref linkend="loading-source-files"/>
       and <xref linkend="ghci-compiled"/>) affect the top-level scope.
       Let's start with the simple cases; when you start
       GHCi the prompt looks like this:
@@ -830,7 +830,7 @@ Prelude System.IO Map>
       <title>Controlling what is in scope with the <literal>:module</literal> command</title>
 
       <para>Another way to manipulate the scope is to use the
-      <literal>:module</literal> command, whose syntax is this: 
+      <literal>:module</literal> command, whose syntax is this:
 
 <screen>
 :module <optional>+|-</optional> <optional>*</optional><replaceable>mod<subscript>1</subscript></replaceable> ... <optional>*</optional><replaceable>mod<subscript>n</subscript></replaceable>
@@ -881,7 +881,7 @@ Prelude System.IO Map>
         <literal>:load</literal></title>
 
         <para>It might seem that <literal>:module</literal>/<literal>import</literal> and
-        <literal>:load</literal>/<literal>:add</literal>/<literal>:reload</literal> 
+        <literal>:load</literal>/<literal>:add</literal>/<literal>:reload</literal>
         do similar things: you can use both
         to bring a module into scope.  However, there is a very important
         difference.  GHCi is concerned with two sets of modules:</para>
@@ -907,7 +907,7 @@ Prelude System.IO Map>
           </listitem>
         </itemizedlist>
 
-        <para>You can add a module to the scope (via <literal>:module</literal> 
+        <para>You can add a module to the scope (via <literal>:module</literal>
            or <literal>import</literal>)
           only if either (a) it is loaded, or
           (b) it is a module from a package that GHCi knows about.
@@ -2627,7 +2627,7 @@ T Int :: * -> *
 
       <varlistentry>
         <term>
-          <literal>:load</literal> <optional><literal>*</literal></optional><replaceable>module</replaceable> ...
+          <literal>:load</literal><optional><literal>!</literal></optional> <optional><literal>*</literal></optional><replaceable>module</replaceable> ...
           <indexterm><primary><literal>:load</literal></primary></indexterm>
         </term>
         <listitem>
@@ -2649,6 +2649,15 @@ T Int :: * -> *
           byte-code.  Using the <literal>*</literal> prefix forces a
           module to be loaded as byte-code.</para>
 
+          <para>Adding the optional "<literal>!</literal>" turns type
+          errors into warnings while loading. This allows to use the
+          portions of the module that are correct, even if there are
+          type errors in some definitions. Effectively, the
+          "-fdefer-type-errors" flag is set before loading and unset
+          after loading if the flag has not already been set
+          before. See <xref linkend="defer-type-errors" /> for further
+          motivation and details.</para>
+
           <para>After a <literal>:load</literal> command, the current
           context is set to:</para>
 
@@ -2785,7 +2794,7 @@ bar
 
       <varlistentry>
         <term>
-          <literal>:reload</literal>
+          <literal>:reload</literal><optional><literal>!</literal></optional>
           <indexterm><primary><literal>:reload</literal></primary></indexterm>
         </term>
         <listitem>
@@ -2794,6 +2803,15 @@ bar
           or any dependent module, has changed.  Note that this may
           entail loading new modules, or dropping modules which are no
           longer indirectly required by the target.</para>
+
+          <para>Adding the optional "<literal>!</literal>" turns type
+          errors into warnings while loading. This allows to use the
+          portions of the module that are correct, even if there are
+          type errors in some definitions. Effectively, the
+          "-fdefer-type-errors" flag is set before loading and unset
+          after loading if the flag has not already been set
+          before. See <xref linkend="defer-type-errors" /> for further
+          motivation and details.</para>
         </listitem>
       </varlistentry>
 
@@ -3302,7 +3320,7 @@ Prelude> :set -fno-warn-incomplete-patterns -XNoMultiParamTypeClasses
       <title>Setting options for interactive evaluation only</title>
 
       <para>
-        GHCi actually maintains <emphasis>two</emphasis> sets of options: 
+        GHCi actually maintains <emphasis>two</emphasis> sets of options:
 <itemizedlist>
 <listitem><para>
   The <emphasis>loading options</emphasis> apply when loading modules
@@ -3317,7 +3335,7 @@ The <literal>:set</literal> command modifies both, but there is
       </para>
 
       <para>
-        It is often useful to change the interactive options, 
+        It is often useful to change the interactive options,
         without having that option apply to loaded modules
         too.  For example
 <screen>
diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index 3912198ed1..cd58fc2fff 100644
--- a/ghc/InteractiveUI.hs
+++ b/ghc/InteractiveUI.hs
@@ -172,13 +172,15 @@ ghciCommands = [
   ("issafe",    keepGoing' isSafeCmd,           completeModule),
   ("kind",      keepGoing' (kindOfType False),  completeIdentifier),
   ("kind!",     keepGoing' (kindOfType True),   completeIdentifier),
-  ("load",      keepGoingPaths loadModule_,     completeHomeModuleOrFile),
+  ("load",      keepGoingPaths (loadModule_ False), completeHomeModuleOrFile),
+  ("load!",     keepGoingPaths (loadModule_ True), completeHomeModuleOrFile),
   ("list",      keepGoing' listCmd,             noCompletion),
   ("module",    keepGoing moduleCmd,            completeSetModule),
   ("main",      keepGoing runMain,              completeFilename),
   ("print",     keepGoing printCmd,             completeExpression),
   ("quit",      quit,                           noCompletion),
-  ("reload",    keepGoing' reloadModule,        noCompletion),
+  ("reload",    keepGoing' (reloadModule False), noCompletion),
+  ("reload!",   keepGoing' (reloadModule True), noCompletion),
   ("run",       keepGoing runRun,               completeFilename),
   ("script",    keepGoing' scriptCmd,           completeFilename),
   ("set",       keepGoing setCmd,               completeSetOptions),
@@ -256,11 +258,13 @@ defFullHelpText =
   "   :issafe [<mod>]             display safe haskell information of module <mod>\n" ++
   "   :kind[!] <type>             show the kind of <type>\n" ++
   "                               (!: also print the normalised type)\n" ++
-  "   :load [*]<module> ...       load module(s) and their dependents\n" ++
+  "   :load[!] [*]<module> ...    load module(s) and their dependents\n" ++
+  "                               (!: defer type errors)\n" ++
   "   :main [<arguments> ...]     run the main function with the given arguments\n" ++
   "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
   "   :quit                       exit GHCi\n" ++
-  "   :reload                     reload the current module set\n" ++
+  "   :reload[!]                  reload the current module set\n" ++
+  "                               (!: defer type errors)\n" ++
   "   :run function [<arguments> ...] run the function with the given arguments\n" ++
   "   :script <filename>          run the script <filename>\n" ++
   "   :type <expr>                show the type of <expr>\n" ++
@@ -1272,7 +1276,7 @@ editFile str =
      code <- liftIO $ system (cmd ++ cmdArgs)
 
      when (code == ExitSuccess)
-       $ reloadModule ""
+       $ reloadModule False ""
 
 -- The user didn't specify a file so we pick one for them.
 -- Our strategy is to pick the first module that failed to load,
@@ -1418,11 +1422,24 @@ checkModule m = do
 -----------------------------------------------------------------------------
 -- :load, :add, :reload
 
+-- | Sets '-fdefer-type-errors' if 'defer' is true, executes 'load' and unsets
+-- '-fdefer-type-errors' again if it has not been set before
+deferredLoad :: Bool -> InputT GHCi SuccessFlag -> InputT GHCi ()
+deferredLoad defer load = do
+  flags <- getDynFlags
+  deferredBefore <- return (gopt Opt_DeferTypeErrors flags)
+  when (defer) $ Monad.void $
+    GHC.setProgramDynFlags $ gopt_set flags Opt_DeferTypeErrors
+  Monad.void $ load
+  flags <- getDynFlags
+  when (not deferredBefore) $ Monad.void $
+    GHC.setProgramDynFlags $ gopt_unset flags Opt_DeferTypeErrors
+
 loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
 loadModule fs = timeIt (const Nothing) (loadModule' fs)
 
-loadModule_ :: [FilePath] -> InputT GHCi ()
-loadModule_ fs = loadModule (zip fs (repeat Nothing)) >> return ()
+loadModule_ :: Bool -> [FilePath] -> InputT GHCi ()
+loadModule_ defer fs = deferredLoad defer (loadModule (zip fs (repeat Nothing)))
 
 loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
 loadModule' files = do
@@ -1460,13 +1477,10 @@ addModule files = do
 
 
 -- :reload
-reloadModule :: String -> InputT GHCi ()
-reloadModule m = do
-  _ <- doLoad True $
-        if null m then LoadAllTargets
-                  else LoadUpTo (GHC.mkModuleName m)
-  return ()
-
+reloadModule :: Bool -> String -> InputT GHCi ()
+reloadModule defer m = deferredLoad defer load
+  where load = doLoad True $
+               if null m then LoadAllTargets else LoadUpTo (GHC.mkModuleName m)
 
 doLoad :: Bool -> LoadHowMuch -> InputT GHCi SuccessFlag
 doLoad retain_context howmuch = do
diff --git a/testsuite/tests/ghci/scripts/Defer03.hs b/testsuite/tests/ghci/scripts/Defer03.hs
new file mode 100755
index 0000000000..b91a7ac8d0
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/Defer03.hs
@@ -0,0 +1,7 @@
+module Main where
+
+a :: Int
+a = 'p'
+
+main :: IO ()
+main = print "No errors!"
diff --git a/testsuite/tests/ghci/scripts/T8353.script b/testsuite/tests/ghci/scripts/T8353.script
new file mode 100644
index 0000000000..d93fb6e4cb
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T8353.script
@@ -0,0 +1,22 @@
+-- Test :load! and :reload!
+
+-- main is independent of functions with type errors and thus
+-- executable after load
+-- warnings on type errors are emitted nevertheless
+:load!   Defer03
+
+-- fails to load module due to type errors
+:load    Defer03
+
+-- succeeds again to load module
+:reload!
+
+-- also succeeds, because the module has not been touched since load
+:reload
+
+-- now, after touching, reloading should fail
+:! touch Defer03.hs
+:reload
+
+-- using the deferred version of reload, loading should succeed again
+:reload!
diff --git a/testsuite/tests/ghci/scripts/T8353.stderr b/testsuite/tests/ghci/scripts/T8353.stderr
new file mode 100644
index 0000000000..7303142d10
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T8353.stderr
@@ -0,0 +1,25 @@
+
+Defer03.hs:4:5: warning:
+    Couldn't match expected type ‘Int’ with actual type ‘Char’
+    In the expression: 'p'
+    In an equation for ‘a’: a = 'p'
+
+Defer03.hs:4:5: error:
+    Couldn't match expected type ‘Int’ with actual type ‘Char’
+    In the expression: 'p'
+    In an equation for ‘a’: a = 'p'
+
+Defer03.hs:4:5: warning:
+    Couldn't match expected type ‘Int’ with actual type ‘Char’
+    In the expression: 'p'
+    In an equation for ‘a’: a = 'p'
+
+Defer03.hs:4:5: error:
+    Couldn't match expected type ‘Int’ with actual type ‘Char’
+    In the expression: 'p'
+    In an equation for ‘a’: a = 'p'
+
+Defer03.hs:4:5: warning:
+    Couldn't match expected type ‘Int’ with actual type ‘Char’
+    In the expression: 'p'
+    In an equation for ‘a’: a = 'p'
diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T
index 747e708aad..1efa0099f1 100755
--- a/testsuite/tests/ghci/scripts/all.T
+++ b/testsuite/tests/ghci/scripts/all.T
@@ -171,6 +171,7 @@ test('T8113', normal, ghci_script, ['T8113.script'])
 test('T8172', when(opsys('mingw32'), normalise_drive_letter),
      ghci_script, ['T8172.script'])
 test('T8215', normal, ghci_script, ['T8215.script'])
+test('T8353', normal, ghci_script, ['T8353.script'])
 test('T8357', normal, ghci_script, ['T8357.script'])
 test('T8383', normal, ghci_script, ['T8383.script'])
 test('T8469', normal, ghci_script, ['T8469.script'])