Commit 5e04c384 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Simplify the MonadFail code

Simplify and tidy up the MonadFail code.
See TcMatches.tcMonadFailOp

Less, code; and more robust.

This incidentally fixes a bug; see the change
to MonadFailErrors.stderr
parent 8dc6da83
...@@ -40,7 +40,6 @@ import SrcLoc ...@@ -40,7 +40,6 @@ import SrcLoc
import FastString import FastString
import DynFlags import DynFlags
import PrelNames (monadFailClassName) import PrelNames (monadFailClassName)
import Type
import Inst import Inst
-- Create chunkified tuple tybes for monad comprehensions -- Create chunkified tuple tybes for monad comprehensions
...@@ -523,19 +522,13 @@ tcMcStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside ...@@ -523,19 +522,13 @@ tcMcStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
; bind_op' <- tcSyntaxOp MCompOrigin bind_op ; bind_op' <- tcSyntaxOp MCompOrigin bind_op
(mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty) (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
-- If (but only if) the pattern can fail, typecheck the 'fail' operator
; fail_op' <- if isIrrefutableHsPat pat
then return noSyntaxExpr
else tcSyntaxOp (MCompPatOrigin pat)
fail_op
(mkFunTy stringTy new_res_ty)
; rhs' <- tcMonoExprNC rhs rhs_ty ; rhs' <- tcMonoExprNC rhs rhs_ty
; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $ ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
thing_inside new_res_ty thing_inside new_res_ty
; monadFailWarnings pat' new_res_ty -- If (but only if) the pattern can fail, typecheck the 'fail' operator
; fail_op' <- tcMonadFailOp (MCompPatOrigin pat) pat' fail_op new_res_ty
; return (BindStmt pat' rhs' bind_op' fail_op', thing) } ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
...@@ -775,19 +768,13 @@ tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside ...@@ -775,19 +768,13 @@ tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
; bind_op' <- tcSyntaxOp DoOrigin bind_op ; bind_op' <- tcSyntaxOp DoOrigin bind_op
(mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty) (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
-- If (but only if) the pattern can fail, typecheck the 'fail' operator
; fail_op' <- if isIrrefutableHsPat pat
then return noSyntaxExpr
else tcSyntaxOp (DoPatOrigin pat)
fail_op
(mkFunTy stringTy new_res_ty)
; rhs' <- tcMonoExprNC rhs rhs_ty ; rhs' <- tcMonoExprNC rhs rhs_ty
; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $ ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
thing_inside new_res_ty thing_inside new_res_ty
; monadFailWarnings pat' new_res_ty -- If (but only if) the pattern can fail, typecheck the 'fail' operator
; fail_op' <- tcMonadFailOp (DoPatOrigin pat) pat' fail_op new_res_ty
; return (BindStmt pat' rhs' bind_op' fail_op', thing) } ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
...@@ -887,24 +874,44 @@ the expected/inferred stuff is back to front (see Trac #3613). ...@@ -887,24 +874,44 @@ the expected/inferred stuff is back to front (see Trac #3613).
-- when the constraint cannot be satisfied, we only issue a warning in -- when the constraint cannot be satisfied, we only issue a warning in
-- TcErrors.hs. -- TcErrors.hs.
monadFailWarnings :: LPat TcId -> TcType -> TcRn () tcMonadFailOp :: CtOrigin
monadFailWarnings pat doExprType = unless (isIrrefutableHsPat pat) $ do -> LPat TcId
rebindableSyntax <- xoptM Opt_RebindableSyntax -> HsExpr Name -- The fail op
desugarFlag <- xoptM Opt_MonadFailDesugaring -> TcType -- Type of the whole do-expression
missingWarning <- woptM Opt_WarnMissingMonadFailInstance -> TcRn (HsExpr TcId) -- Typechecked fail op
if | rebindableSyntax && (desugarFlag || missingWarning) -- Get a 'fail' operator expression, to use if the pattern
-> warnRebindableClash pat -- match fails. If the pattern is irrefutatable, just return
| not desugarFlag && missingWarning -- noSyntaxExpr; it won't be used
-> addMonadFailConstraint pat doExprType tcMonadFailOp orig pat fail_op res_ty
| otherwise -> pure () | isIrrefutableHsPat pat
= return noSyntaxExpr
addMonadFailConstraint :: LPat TcId -> TcType -> TcRn ()
addMonadFailConstraint pat doExprType = do | otherwise
doExprTypeHead <- tyHead <$> zonkType doExprType = do { -- Issue MonadFail warnings
monadFailClass <- tcLookupClass monadFailClassName rebindableSyntax <- xoptM Opt_RebindableSyntax
let predType = mkClassPred monadFailClass [doExprTypeHead] ; desugarFlag <- xoptM Opt_MonadFailDesugaring
_ <- emitWanted (FailablePattern pat) predType ; missingWarning <- woptM Opt_WarnMissingMonadFailInstance
pure () ; if | rebindableSyntax && (desugarFlag || missingWarning)
-> warnRebindableClash pat
| not desugarFlag && missingWarning
-> emitMonadFailConstraint pat res_ty
| otherwise
-> return ()
-- Get the fail op itself
; tcSyntaxOp orig fail_op (mkFunTy stringTy res_ty) }
emitMonadFailConstraint :: LPat TcId -> TcType -> TcRn ()
emitMonadFailConstraint pat res_ty
= do { -- We expect res_ty to be of form (monad_ty arg_ty)
(_co, (monad_ty, _arg_ty)) <- matchExpectedAppTy res_ty
-- Emit (MonadFail m), but ignore the evidence; it's
-- just there to generate a warning
; monadFailClass <- tcLookupClass monadFailClassName
; _ <- emitWanted (FailablePattern pat)
(mkClassPred monadFailClass [monad_ty])
; return () }
warnRebindableClash :: LPat TcId -> TcRn () warnRebindableClash :: LPat TcId -> TcRn ()
warnRebindableClash pattern = addWarnAt (getLoc pattern) warnRebindableClash pattern = addWarnAt (getLoc pattern)
...@@ -915,25 +922,6 @@ warnRebindableClash pattern = addWarnAt (getLoc pattern) ...@@ -915,25 +922,6 @@ warnRebindableClash pattern = addWarnAt (getLoc pattern)
$$ $$
text "compile with -fno-warn-missing-monadfail-instance.")) text "compile with -fno-warn-missing-monadfail-instance."))
zonkType :: TcType -> TcRn TcType
zonkType ty = do
tidyEnv <- tcInitTidyEnv
(_, zonkedType) <- zonkTidyTcType tidyEnv ty
pure zonkedType
tyHead :: TcType -> TcType
tyHead ty
| Just (con, _) <- splitAppTy_maybe ty = con
| Just _ <- splitFunTy_maybe ty = panicFor "FunTy"
| Just _ <- splitTyConApp_maybe ty = panicFor "TyConApp"
| Just _ <- splitForAllTy_maybe ty = panicFor "ForAllTy"
| otherwise = panicFor "<some other>"
where panicFor x = panic ("MonadFail check applied to " ++ x ++ " type")
{- {-
Note [typechecking ApplicativeStmt] Note [typechecking ApplicativeStmt]
......
MonadFailErrors.hs:16:5: error: MonadFailErrors.hs:16:5: error:
Could not deduce (MonadFail m) Could not deduce (MonadFail m)
arising from a do statement arising from a do statement
with the failable pattern ‘Just x’ with the failable pattern ‘Just x’
from the context: Monad m from the context: Monad m
bound by the type signature for: bound by the type signature for:
general :: Monad m => m a general :: Monad m => m a
at MonadFailErrors.hs:14:12-25 at MonadFailErrors.hs:14:12-25
Possible fix: Possible fix:
add (MonadFail m) to the context of add (MonadFail m) to the context of
the type signature for: the type signature for:
general :: Monad m => m a general :: Monad m => m a
In a stmt of a 'do' block: Just x <- undefined In a stmt of a 'do' block: Just x <- undefined
In the expression: In the expression:
do { Just x <- undefined; do { Just x <- undefined;
undefined } undefined }
In an equation for ‘general’: In an equation for ‘general’:
general general
= do { Just x <- undefined; = do { Just x <- undefined;
undefined } undefined }
MonadFailErrors.hs:30:5: error: MonadFailErrors.hs:30:5: error:
No instance for (MonadFail Identity) No instance for (MonadFail Identity)
arising from a do statement arising from a do statement
with the failable pattern ‘Just x’ with the failable pattern ‘Just x’
In a stmt of a 'do' block: Just x <- undefined In a stmt of a 'do' block: Just x <- undefined
In the expression: In the expression:
do { Just x <- undefined; do { Just x <- undefined;
undefined } undefined }
In an equation for ‘identity’: In an equation for ‘identity’:
identity identity
= do { Just x <- undefined; = do { Just x <- undefined;
undefined } undefined }
MonadFailErrors.hs:44:5: error: MonadFailErrors.hs:44:5: error:
No instance for (MonadFail (ST s)) No instance for (MonadFail (ST s))
arising from a do statement arising from a do statement
with the failable pattern ‘Just x’ with the failable pattern ‘Just x’
In a stmt of a 'do' block: Just x <- undefined In a stmt of a 'do' block: Just x <- undefined
In the expression: In the expression:
do { Just x <- undefined; do { Just x <- undefined;
undefined } undefined }
In an equation for ‘st’: In an equation for ‘st’:
st st
= do { Just x <- undefined; = do { Just x <- undefined;
undefined } undefined }
MonadFailErrors.hs:51:5: error: MonadFailErrors.hs:51:5: error:
No instance for (MonadFail ((->) r)) • No instance for (MonadFail ((->) r))
arising from a do statement arising from a do statement
with the failable pattern ‘Just x’ with the failable pattern ‘Just x’
In a stmt of a 'do' block: Just x <- undefined • In a stmt of a 'do' block: Just x <- undefined
In the expression: In the expression:
do { Just x <- undefined; do { Just x <- undefined;
undefined } undefined }
In an equation for ‘reader’: In an equation for ‘reader’:
reader reader
= do { Just x <- undefined; = do { Just x <- undefined;
undefined } undefined }
MonadFailErrors.hs:59:5: error:
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;
undefined }
In an equation for ‘newtypeMatch’:
newtypeMatch
= do { Newtype x <- undefined;
undefined }
MonadFailErrors.hs:67:5: error:
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;
undefined }
In an equation for ‘singleConMatch’:
singleConMatch
= do { Data x <- undefined;
undefined }
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment