Fixes around incomplete guards (#20023, #20024)

- Fix linearity error with incomplete MultiWayIf (#20023)
- Fix partial pattern binding error message (#20024)
- Remove obsolete test LinearPolyTest
  It tested the special typing rule for ($), which was removed
  during the implementation of Quick Look 97cff9190d3.
- Fix ticket numbers in linear/*/all.T, they referred to linear types
  issue tracker

11 files changed, 27 insertions, 36 deletions

diff --git a/compiler/GHC/HsToCore/GuardedRHSs.hs b/compiler/GHC/HsToCore/GuardedRHSs.hs
index 6f1de8ae16..8ecf6c84ed 100644
--- a/compiler/GHC/HsToCore/GuardedRHSs.hs
+++ b/compiler/GHC/HsToCore/GuardedRHSs.hs
@@ -49,7 +49,8 @@ necessary.  The type argument gives the type of the @ei@.
 dsGuarded :: GRHSs GhcTc (LHsExpr GhcTc) -> Type -> NonEmpty Nablas -> DsM CoreExpr
 dsGuarded grhss rhs_ty rhss_nablas = do
     match_result <- dsGRHSs PatBindRhs grhss rhs_ty rhss_nablas
-    error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty
+    error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty
+                               (text "pattern binding")
     extractMatchResult match_result error_expr
 
 -- In contrast, @dsGRHSs@ produces a @MatchResult CoreExpr@.
diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs
index b68cf061a0..5c68525f12 100644
--- a/compiler/GHC/HsToCore/Utils.hs
+++ b/compiler/GHC/HsToCore/Utils.hs
@@ -405,11 +405,10 @@ mkErrorAppDs :: Id              -- The error function
 mkErrorAppDs err_id ty msg = do
     src_loc <- getSrcSpanDs
     dflags <- getDynFlags
-    let
-        full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg])
-        core_msg = Lit (mkLitString full_msg)
-        -- mkLitString returns a result of type String#
-    return (mkApps (Var err_id) [Type (getRuntimeRep ty), Type ty, core_msg])
+    let full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg])
+        fail_expr = mkRuntimeErrorApp err_id unitTy full_msg
+    return $ mkWildCase fail_expr (unrestricted unitTy) ty []
+    -- See Note [Incompleteness and linearity]
 
 {-
 Note [Incompleteness and linearity]
@@ -426,7 +425,7 @@ the linearity of x.
 Instead, we use 'f x False = case error "Non-exhausive pattern..." :: () of {}'.
 This case expression accounts for linear variables by assigning bottom usage
 (See Note [Bottom as a usage] in GHC.Core.Multiplicity).
-This is done in mkFailExpr.
+This is done in mkErrorAppDs, called from mkFailExpr.
 We use '()' instead of the original return type ('a' in this case)
 because there might be representation polymorphism, e.g. in
 
@@ -458,9 +457,7 @@ is disabled.
 
 mkFailExpr :: HsMatchContext GhcRn -> Type -> DsM CoreExpr
 mkFailExpr ctxt ty
-  = do fail_expr <- mkErrorAppDs pAT_ERROR_ID unitTy (matchContextErrString ctxt)
-       return $ mkWildCase fail_expr (unrestricted unitTy) ty []
-       -- See Note [Incompleteness and linearity]
+  = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt)
 
 {-
 'mkCoreAppDs' and 'mkCoreAppsDs' handle the special-case desugaring of 'seq'.
diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
index f3c8a19b04..e45d051e50 100644
--- a/compiler/GHC/Tc/Errors.hs
+++ b/compiler/GHC/Tc/Errors.hs
@@ -953,10 +953,10 @@ mkErrorTerm ctxt ct_loc ty report
          -- This will be reported at runtime, so we always want "error:" in the report, never "warning:"
        ; dflags <- getDynFlags
        ; let err_msg = pprLocMsgEnvelope msg
-             err_fs  = mkFastString $ showSDoc dflags $
+             err_str = showSDoc dflags $
                        err_msg $$ text "(deferred type error)"
 
-       ; return $ evDelayedError ty err_fs }
+       ; return $ evDelayedError ty err_str }
 
 tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct])
 -- Use the first reporter in the list whose predicate says True
diff --git a/compiler/GHC/Tc/Types/EvTerm.hs b/compiler/GHC/Tc/Types/EvTerm.hs
index 19afec031a..ad380ec0a2 100644
--- a/compiler/GHC/Tc/Types/EvTerm.hs
+++ b/compiler/GHC/Tc/Types/EvTerm.hs
@@ -13,34 +13,27 @@ import GHC.Tc.Types.Evidence
 import GHC.Unit
 
 import GHC.Builtin.Names
-import GHC.Builtin.Types ( liftedRepTy, unitTy )
+import GHC.Builtin.Types ( unitTy )
 
 import GHC.Core.Type
 import GHC.Core
 import GHC.Core.Make
 import GHC.Core.Utils
 
-import GHC.Types.Literal ( Literal(..) )
 import GHC.Types.SrcLoc
 import GHC.Types.Name
 import GHC.Types.TyThing
 
-import GHC.Data.FastString
-
 -- Used with Opt_DeferTypeErrors
 -- See Note [Deferring coercion errors to runtime]
 -- in GHC.Tc.Solver
-evDelayedError :: Type -> FastString -> EvTerm
+evDelayedError :: Type -> String -> EvTerm
 evDelayedError ty msg
   = EvExpr $
-    let fail_expr = Var errorId `mkTyApps` [liftedRepTy, unitTy] `mkApps` [litMsg]
+    let fail_expr = mkRuntimeErrorApp tYPE_ERROR_ID unitTy msg
     in mkWildCase fail_expr (unrestricted unitTy) ty []
        -- See Note [Incompleteness and linearity] in GHC.HsToCore.Utils
-       -- c.f. mkFailExpr in GHC.HsToCore.Utils
-
-  where
-    errorId = tYPE_ERROR_ID
-    litMsg  = Lit (LitString (bytesFS msg))
+       -- c.f. mkErrorAppDs in GHC.HsToCore.Utils
 
 -- Dictionary for CallStack implicit parameters
 evCallStack :: (MonadThings m, HasModule m, HasDynFlags m) =>
diff --git a/testsuite/tests/deSugar/should_run/T20024.hs b/testsuite/tests/deSugar/should_run/T20024.hs
new file mode 100644
index 0000000000..560c48852b
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/T20024.hs
@@ -0,0 +1,2 @@
+module Main where
+main = let (x,y) | False = (1,2) in print x
diff --git a/testsuite/tests/deSugar/should_run/T20024.stderr b/testsuite/tests/deSugar/should_run/T20024.stderr
new file mode 100644
index 0000000000..24e6227fdc
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/T20024.stderr
@@ -0,0 +1,2 @@
+T20024: T20024.hs:2:12-32: Non-exhaustive guards in pattern binding
+
diff --git a/testsuite/tests/deSugar/should_run/all.T b/testsuite/tests/deSugar/should_run/all.T
index c9ef02c074..ce3185c213 100644
--- a/testsuite/tests/deSugar/should_run/all.T
+++ b/testsuite/tests/deSugar/should_run/all.T
@@ -73,3 +73,4 @@ test('DsMonadCompFailMsg', exit_code(1), compile_and_run, [''])
 test('T19289', normal, compile_and_run, [''])
 test('T19680', normal, compile_and_run, [''])
 test('T19680A', normal, compile_and_run, [''])
+test('T20024', exit_code(1), compile_and_run, [''])
diff --git a/testsuite/tests/linear/should_compile/LinearPolyDollar.hs b/testsuite/tests/linear/should_compile/LinearPolyDollar.hs
deleted file mode 100644
index 7d14351cfc..0000000000
--- a/testsuite/tests/linear/should_compile/LinearPolyDollar.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-{-# LANGUAGE LinearTypes #-}
-
-module LinearPolyDollar where
-
--- The goal of this test is to ensure that the special typing rule of ($) plays
--- well with multiplicity-polymorphic functions
-
-data F = F Bool
-
-x = F $ True
diff --git a/testsuite/tests/linear/should_compile/T20023.hs b/testsuite/tests/linear/should_compile/T20023.hs
new file mode 100644
index 0000000000..13fd8a1dd5
--- /dev/null
+++ b/testsuite/tests/linear/should_compile/T20023.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE LinearTypes, MultiWayIf #-}
+module T20023 where
+
+f :: Bool -> a %1-> a
+f b x = if | b -> x
diff --git a/testsuite/tests/linear/should_compile/all.T b/testsuite/tests/linear/should_compile/all.T
index 17e04ca94a..77cd913b81 100644
--- a/testsuite/tests/linear/should_compile/all.T
+++ b/testsuite/tests/linear/should_compile/all.T
@@ -24,16 +24,16 @@ test('Linear4', normal, compile, [''])
 test('Linear6', normal, compile, [''])
 test('Linear8', normal, compile, [''])
 test('LinearGuards', normal, compile, [''])
-test('LinearPolyDollar', normal, compile, [''])
 test('LinearConstructors', normal, compile, [''])
 test('Linear1Rule', normal, compile, [''])
 test('LinearEmptyCase', normal, compile, [''])
 test('Tunboxer', normal, compile, [''])
 test('MultConstructor', expect_broken(19165), compile, [''])
-test('LinearLetRec', expect_broken(405), compile, ['-O -dlinear-core-lint'])
+test('LinearLetRec', expect_broken(18694), compile, ['-O -dlinear-core-lint'])
 test('LinearTH1', normal, compile, [''])
 test('LinearTH2', normal, compile, [''])
 test('LinearTH3', normal, compile, [''])
 test('LinearHole', normal, compile, [''])
 test('T18731', normal, compile, [''])
 test('T19400', unless(compiler_debugged(), skip), compile, [''])
+test('T20023', normal, compile, [''])
diff --git a/testsuite/tests/linear/should_fail/all.T b/testsuite/tests/linear/should_fail/all.T
index 3dbf154705..a831011cef 100644
--- a/testsuite/tests/linear/should_fail/all.T
+++ b/testsuite/tests/linear/should_fail/all.T
@@ -25,7 +25,7 @@ test('LinearKind2', normal, compile_fail, [''])
 test('LinearKind3', normal, compile_fail, [''])
 test('LinearVar', normal, compile_fail, ['-XLinearTypes'])
 test('LinearErrOrigin', normal, compile_fail, ['-XLinearTypes'])
-test('LinearPolyType', normal, compile_fail, [''])  # not supported yet (#390)
+test('LinearPolyType', normal, compile_fail, [''])  # not supported yet (#19517)
 test('LinearBottomMult', normal, compile_fail, [''])
 test('LinearSequenceExpr', normal, compile_fail, [''])
 test('LinearIf', normal, compile_fail, [''])