diff options
| -rw-r--r-- | compiler/typecheck/TcMatches.hs | 8 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnTypes.hs | 29 | ||||
| -rw-r--r-- | testsuite/tests/driver/T4437.hs | 1 | ||||
| -rw-r--r-- | testsuite/tests/monadfail/MonadFailErrors.stderr | 24 | ||||
| -rw-r--r-- | testsuite/tests/rebindable/rebindable6.stderr | 1 |
5 files changed, 48 insertions, 15 deletions
diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs index b504206a2a..cd1cddd786 100644 --- a/compiler/typecheck/TcMatches.hs +++ b/compiler/typecheck/TcMatches.hs @@ -526,7 +526,9 @@ tcMcStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside -- If (but only if) the pattern can fail, typecheck the 'fail' operator ; fail_op' <- if isIrrefutableHsPat pat then return noSyntaxExpr - else tcSyntaxOp MCompOrigin fail_op (mkFunTy stringTy new_res_ty) + else tcSyntaxOp (MCompPatOrigin pat) + fail_op + (mkFunTy stringTy new_res_ty) ; rhs' <- tcMonoExprNC rhs rhs_ty @@ -776,7 +778,9 @@ tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside -- If (but only if) the pattern can fail, typecheck the 'fail' operator ; fail_op' <- if isIrrefutableHsPat pat then return noSyntaxExpr - else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty) + else tcSyntaxOp (DoPatOrigin pat) + fail_op + (mkFunTy stringTy new_res_ty) ; rhs' <- tcMonoExprNC rhs rhs_ty diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 18ba7cec63..b1d8d46a5f 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -2247,7 +2247,11 @@ data CtOrigin | StandAloneDerivOrigin -- Typechecking stand-alone deriving | DefaultOrigin -- Typechecking a default decl | DoOrigin -- Arising from a do expression + | DoPatOrigin (LPat Name) -- Arising from a failable pattern in + -- a do expression | MCompOrigin -- Arising from a monad comprehension + | MCompPatOrigin (LPat Name) -- Arising from a failable pattern in a + -- monad comprehension | IfOrigin -- Arising from an if statement | ProcOrigin -- Arising from a proc expression | AnnOrigin -- An annotation @@ -2267,7 +2271,8 @@ data CtOrigin | ListOrigin -- An overloaded list | StaticOrigin -- A static form | FailablePattern (LPat TcId) -- A failable pattern in do-notation for the - -- MonadFail Proposal (MFP) + -- MonadFail Proposal (MFP). Obsolete when + -- actual desugaring to MonadFail.fail is live. ctoHerald :: SDoc ctoHerald = ptext (sLit "arising from") @@ -2321,11 +2326,25 @@ pprCtOrigin (DerivOriginCoerce meth ty1 ty2) 2 (sep [ text "from type" <+> quotes (ppr ty1) , nest 2 $ text "to type" <+> quotes (ppr ty2) ]) +pprCtOrigin (DoPatOrigin pat) + = ctoHerald <+> text "a do statement" + $$ + text "with the failable pattern" <+> quotes (ppr pat) + +pprCtOrigin (MCompPatOrigin pat) + = ctoHerald <+> hsep [ text "the failable pattern" + , quotes (ppr pat) + , text "in a statement in a monad comprehension" ] +pprCtOrigin (FailablePattern pat) + = ctoHerald <+> text "the failable pattern" <+> quotes (ppr pat) + $$ + text "(this will become an error a future GHC release)" + pprCtOrigin simple_origin = ctoHerald <+> pprCtO simple_origin ----------------- -pprCtO :: CtOrigin -> SDoc -- Ones that are short one-liners +-- | Short one-liners +pprCtO :: CtOrigin -> SDoc pprCtO (OccurrenceOf name) = hsep [ptext (sLit "a use of"), quotes (ppr name)] pprCtO (OccurrenceOfRecSel name) = hsep [ptext (sLit "a use of"), quotes (ppr name)] pprCtO AppOrigin = ptext (sLit "an application") @@ -2350,15 +2369,13 @@ pprCtO DerivOrigin = ptext (sLit "the 'deriving' clause of a data type pprCtO StandAloneDerivOrigin = ptext (sLit "a 'deriving' declaration") pprCtO DefaultOrigin = ptext (sLit "a 'default' declaration") pprCtO DoOrigin = ptext (sLit "a do statement") -pprCtO MCompOrigin = ptext (sLit "a statement in a monad comprehension") +pprCtO MCompOrigin = text "a statement in a monad comprehension" pprCtO ProcOrigin = ptext (sLit "a proc expression") pprCtO (TypeEqOrigin t1 t2) = ptext (sLit "a type equality") <+> sep [ppr t1, char '~', ppr t2] pprCtO AnnOrigin = ptext (sLit "an annotation") pprCtO HoleOrigin = ptext (sLit "a use of") <+> quotes (ptext $ sLit "_") pprCtO ListOrigin = ptext (sLit "an overloaded list") pprCtO StaticOrigin = ptext (sLit "a static form") -pprCtO (FailablePattern pat) = text "the failable pattern" <+> quotes (ppr pat) - $$ text "(this will become an error a future GHC release)" pprCtO _ = panic "pprCtOrigin" {- diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs index d3bee2a61a..5c087311cc 100644 --- a/testsuite/tests/driver/T4437.hs +++ b/testsuite/tests/driver/T4437.hs @@ -34,7 +34,6 @@ expectedGhcOnlyExtensions = ["RelaxedLayout", "AlternativeLayoutRule", "AlternativeLayoutRuleTransitional", "OverloadedLabels", - "Strict", "MonadFailDesugaring"] expectedCabalOnlyExtensions :: [String] diff --git a/testsuite/tests/monadfail/MonadFailErrors.stderr b/testsuite/tests/monadfail/MonadFailErrors.stderr index ad661772c7..17807a4be0 100644 --- a/testsuite/tests/monadfail/MonadFailErrors.stderr +++ b/testsuite/tests/monadfail/MonadFailErrors.stderr @@ -1,6 +1,8 @@ MonadFailErrors.hs:16:5: error: - Could not deduce (MonadFail m) arising from a do statement + Could not deduce (MonadFail m) + arising from a do statement + with the failable pattern ‘Just x’ from the context: Monad m bound by the type signature for: general :: Monad m => m a @@ -19,7 +21,9 @@ MonadFailErrors.hs:16:5: error: undefined } MonadFailErrors.hs:30:5: error: - No instance for (MonadFail Identity) arising from a do statement + No instance for (MonadFail Identity) + arising from a do statement + with the failable pattern ‘Just x’ In a stmt of a 'do' block: Just x <- undefined In the expression: do { Just x <- undefined; @@ -30,7 +34,9 @@ MonadFailErrors.hs:30:5: error: undefined } MonadFailErrors.hs:44:5: error: - No instance for (MonadFail (ST s)) arising from a do statement + No instance for (MonadFail (ST s)) + arising from a do statement + with the failable pattern ‘Just x’ In a stmt of a 'do' block: Just x <- undefined In the expression: do { Just x <- undefined; @@ -41,7 +47,9 @@ MonadFailErrors.hs:44:5: error: undefined } MonadFailErrors.hs:51:5: error: - No instance for (MonadFail ((->) r)) arising from a do statement + No instance for (MonadFail ((->) r)) + arising from a do statement + with the failable pattern ‘Just x’ In a stmt of a 'do' block: Just x <- undefined In the expression: do { Just x <- undefined; @@ -52,7 +60,9 @@ MonadFailErrors.hs:51:5: error: undefined } MonadFailErrors.hs:59:5: error: - No instance for (MonadFail Identity) arising from a do statement + No instance for (MonadFail Identity) + arising from a do statement + with the failable pattern ‘Newtype x’ In a stmt of a 'do' block: Newtype x <- undefined In the expression: do { Newtype x <- undefined; @@ -63,7 +73,9 @@ MonadFailErrors.hs:59:5: error: undefined } MonadFailErrors.hs:67:5: error: - No instance for (MonadFail Identity) arising from a do statement + No instance for (MonadFail Identity) + arising from a do statement + with the failable pattern ‘Data x’ In a stmt of a 'do' block: Data x <- undefined In the expression: do { Data x <- undefined; diff --git a/testsuite/tests/rebindable/rebindable6.stderr b/testsuite/tests/rebindable/rebindable6.stderr index 269ea8ff05..2f1331db86 100644 --- a/testsuite/tests/rebindable/rebindable6.stderr +++ b/testsuite/tests/rebindable/rebindable6.stderr @@ -26,6 +26,7 @@ rebindable6.hs:109:17: error: rebindable6.hs:110:17: error: Ambiguous type variable ‘t1’ arising from a do statement + with the failable pattern ‘Just (b :: b)’ prevents the constraint ‘(HasFail ([Char] -> t1))’ from being solved. (maybe you haven't applied a function to enough arguments?) |