diff options
author | Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io> | 2021-06-19 21:44:17 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-06-24 20:35:56 -0400 |
commit | 4d5967b5148d5502d7c53a5a321919779c3165e4 (patch) | |
tree | 7348b3ae363486350fc0be24f9138be5362be9d3 | |
parent | 138b7a5775251c330ade870a0b8d1f5c4659e669 (diff) | |
download | haskell-4d5967b5148d5502d7c53a5a321919779c3165e4.tar.gz |
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
-rw-r--r-- | compiler/GHC/HsToCore/GuardedRHSs.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Utils.hs | 15 | ||||
-rw-r--r-- | compiler/GHC/Tc/Errors.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Tc/Types/EvTerm.hs | 15 | ||||
-rw-r--r-- | testsuite/tests/deSugar/should_run/T20024.hs | 2 | ||||
-rw-r--r-- | testsuite/tests/deSugar/should_run/T20024.stderr | 2 | ||||
-rw-r--r-- | testsuite/tests/deSugar/should_run/all.T | 1 | ||||
-rw-r--r-- | testsuite/tests/linear/should_compile/LinearPolyDollar.hs | 10 | ||||
-rw-r--r-- | testsuite/tests/linear/should_compile/T20023.hs | 5 | ||||
-rw-r--r-- | testsuite/tests/linear/should_compile/all.T | 4 | ||||
-rw-r--r-- | testsuite/tests/linear/should_fail/all.T | 2 |
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, ['']) |