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
import FastString
import DynFlags
import PrelNames (monadFailClassName)
import Type
import Inst
-- Create chunkified tuple tybes for monad comprehensions
......@@ -523,19 +522,13 @@ tcMcStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
; bind_op' <- tcSyntaxOp MCompOrigin bind_op
(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
; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_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) }
......@@ -775,19 +768,13 @@ tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
; bind_op' <- tcSyntaxOp DoOrigin bind_op
(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
; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_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) }
......@@ -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
-- TcErrors.hs.
monadFailWarnings :: LPat TcId -> TcType -> TcRn ()
monadFailWarnings pat doExprType = unless (isIrrefutableHsPat pat) $ do
rebindableSyntax <- xoptM Opt_RebindableSyntax
desugarFlag <- xoptM Opt_MonadFailDesugaring
missingWarning <- woptM Opt_WarnMissingMonadFailInstance
if | rebindableSyntax && (desugarFlag || missingWarning)
-> warnRebindableClash pat
| not desugarFlag && missingWarning
-> addMonadFailConstraint pat doExprType
| otherwise -> pure ()
addMonadFailConstraint :: LPat TcId -> TcType -> TcRn ()
addMonadFailConstraint pat doExprType = do
doExprTypeHead <- tyHead <$> zonkType doExprType
monadFailClass <- tcLookupClass monadFailClassName
let predType = mkClassPred monadFailClass [doExprTypeHead]
_ <- emitWanted (FailablePattern pat) predType
pure ()
tcMonadFailOp :: CtOrigin
-> LPat TcId
-> HsExpr Name -- The fail op
-> TcType -- Type of the whole do-expression
-> TcRn (HsExpr TcId) -- Typechecked fail op
-- Get a 'fail' operator expression, to use if the pattern
-- match fails. If the pattern is irrefutatable, just return
-- noSyntaxExpr; it won't be used
tcMonadFailOp orig pat fail_op res_ty
| isIrrefutableHsPat pat
= return noSyntaxExpr
| otherwise
= do { -- Issue MonadFail warnings
rebindableSyntax <- xoptM Opt_RebindableSyntax
; desugarFlag <- xoptM Opt_MonadFailDesugaring
; missingWarning <- woptM Opt_WarnMissingMonadFailInstance
; 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 pattern = addWarnAt (getLoc pattern)
......@@ -915,25 +922,6 @@ warnRebindableClash pattern = addWarnAt (getLoc pattern)
$$
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]
......
MonadFailErrors.hs:16:5: error:
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
at MonadFailErrors.hs:14:12-25
Possible fix:
add (MonadFail m) to the context of
the type signature for:
general :: Monad m => m a
In a stmt of a 'do' block: Just x <- undefined
In the expression:
do { Just x <- undefined;
undefined }
In an equation for ‘general’:
general
= do { Just x <- undefined;
undefined }
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
at MonadFailErrors.hs:14:12-25
Possible fix:
add (MonadFail m) to the context of
the type signature for:
general :: Monad m => m a
In a stmt of a 'do' block: Just x <- undefined
In the expression:
do { Just x <- undefined;
undefined }
In an equation for ‘general’:
general
= do { Just x <- undefined;
undefined }
MonadFailErrors.hs:30:5: error:
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;
undefined }
In an equation for ‘identity’:
identity
= do { Just x <- undefined;
undefined }
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;
undefined }
In an equation for ‘identity’:
identity
= do { Just x <- undefined;
undefined }
MonadFailErrors.hs:44:5: error:
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;
undefined }
In an equation for ‘st’:
st
= do { Just x <- undefined;
undefined }
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;
undefined }
In an equation for ‘st’:
st
= do { Just x <- undefined;
undefined }
MonadFailErrors.hs:51:5: error:
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;
undefined }
In an equation for ‘reader’:
reader
= do { Just x <- 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 }
• 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;
undefined }
In an equation for ‘reader’:
reader
= do { Just 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