summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/coreSyn/CoreLint.hs8
-rw-r--r--compiler/hsSyn/HsExpr.hs2
-rw-r--r--compiler/main/DynFlags.hs4
-rw-r--r--compiler/parser/Lexer.x8
-rw-r--r--compiler/prelude/PrelNames.hs39
-rw-r--r--compiler/prelude/PrelRules.hs8
-rw-r--r--compiler/rename/RnEnv.hs4
-rw-r--r--compiler/rename/RnExpr.hs17
-rw-r--r--compiler/specialise/Specialise.hs8
-rw-r--r--compiler/typecheck/TcArrows.hs2
-rw-r--r--compiler/typecheck/TcErrors.hs23
-rw-r--r--compiler/typecheck/TcMatches.hs87
-rw-r--r--compiler/typecheck/TcRnDriver.hs3
-rw-r--r--compiler/typecheck/TcRnTypes.hs12
-rw-r--r--compiler/typecheck/TcSMonad.hs8
-rw-r--r--compiler/types/Unify.hs8
-rw-r--r--compiler/utils/IOEnv.hs9
-rw-r--r--compiler/utils/Maybes.hs9
18 files changed, 224 insertions, 35 deletions
diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index da08c21fca..00a7fd0b19 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -64,6 +64,9 @@ import Demand ( splitStrictSig, isBotRes )
import HscTypes
import DynFlags
import Control.Monad
+#if __GLASGOW_HASKELL__ > 710
+import qualified Control.Monad.Fail as MonadFail
+#endif
import MonadUtils
import Data.Maybe
import Pair
@@ -1503,6 +1506,11 @@ instance Monad LintM where
Just r -> unLintM (k r) env errs'
Nothing -> (Nothing, errs'))
+#if __GLASGOW_HASKELL__ > 710
+instance MonadFail.MonadFail LintM where
+ fail err = failWithL (text err)
+#endif
+
instance HasDynFlags LintM where
getDynFlags = LintM (\ e errs -> (Just (le_dynflags e), errs))
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index 8a733adec4..09717b768a 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -1336,7 +1336,7 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
-- For details on above see note [Api annotations] in ApiAnnotation
| BindStmt (LPat idL)
body
- (SyntaxExpr idR) -- The (>>=) operator; see Note [The type of bind]
+ (SyntaxExpr idR) -- The (>>=) operator; see Note [The type of bind in Stmts]
(SyntaxExpr idR) -- The fail operator
-- The fail operator is noSyntaxExpr
-- if the pattern match can't fail
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 5f63b1048e..45fb72e06d 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -505,6 +505,7 @@ data WarningFlag =
| Opt_WarnWarningsDeprecations
| Opt_WarnDeprecatedFlags
| Opt_WarnAMP
+ | Opt_WarnMissingMonadFailInstance
| Opt_WarnDodgyExports
| Opt_WarnDodgyImports
| Opt_WarnOrphans
@@ -656,6 +657,7 @@ data ExtensionFlag
| Opt_StaticPointers
| Opt_Strict
| Opt_StrictData
+ | Opt_MonadFailDesugaring
deriving (Eq, Enum, Show)
type SigOf = Map ModuleName Module
@@ -2898,6 +2900,7 @@ fWarningFlags = [
flagSpec "warn-missing-import-lists" Opt_WarnMissingImportList,
flagSpec "warn-missing-local-sigs" Opt_WarnMissingLocalSigs,
flagSpec "warn-missing-methods" Opt_WarnMissingMethods,
+ flagSpec "warn-missing-monadfail-instance" Opt_WarnMissingMonadFailInstance,
flagSpec "warn-missing-signatures" Opt_WarnMissingSigs,
flagSpec "warn-missing-exported-sigs" Opt_WarnMissingExportedSigs,
flagSpec "warn-monomorphism-restriction" Opt_WarnMonomorphism,
@@ -3168,6 +3171,7 @@ xFlags = [
flagSpec "LiberalTypeSynonyms" Opt_LiberalTypeSynonyms,
flagSpec "MagicHash" Opt_MagicHash,
flagSpec "MonadComprehensions" Opt_MonadComprehensions,
+ flagSpec "MonadFailDesugaring" Opt_MonadFailDesugaring,
flagSpec "MonoLocalBinds" Opt_MonoLocalBinds,
flagSpec' "MonoPatBinds" Opt_MonoPatBinds
(\ turn_on -> when turn_on $
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 8f29a270e0..da9424d5bc 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -78,6 +78,9 @@ module Lexer (
import Control.Applicative
#endif
import Control.Monad
+#if __GLASGOW_HASKELL__ > 710
+import Control.Monad.Fail
+#endif
import Data.Bits
import Data.Char
import Data.List
@@ -1755,6 +1758,11 @@ instance Monad P where
(>>=) = thenP
fail = failP
+#if __GLASGOW_HASKELL__ > 710
+instance MonadFail P where
+ fail = failP
+#endif
+
returnP :: a -> P a
returnP a = a `seq` (P $ \s -> POk s a)
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index 346f3a382d..1b1ffaabdf 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -239,10 +239,11 @@ basicKnownKeyNames
apAName,
-- Monad stuff
- thenIOName, bindIOName, returnIOName, failIOName,
- failMName, bindMName, thenMName, returnMName,
- fmapName,
- joinMName,
+ thenIOName, bindIOName, returnIOName, failIOName, bindMName, thenMName,
+ returnMName, fmapName, joinMName,
+
+ -- MonadFail
+ monadFailClassName, failMName, failMName_preMFP,
-- MonadFix
monadFixClassName, mfixName,
@@ -408,7 +409,7 @@ gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
gHC_ST, gHC_ARR, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL,
gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC,
tYPEABLE, tYPEABLE_INTERNAL, gENERICS,
- rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_ZIP,
+ rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_ZIP, mONAD_FAIL,
aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS,
cONTROL_EXCEPTION_BASE, gHC_TYPELITS :: Module
@@ -456,6 +457,7 @@ gHC_WORD = mkBaseModule (fsLit "GHC.Word")
mONAD = mkBaseModule (fsLit "Control.Monad")
mONAD_FIX = mkBaseModule (fsLit "Control.Monad.Fix")
mONAD_ZIP = mkBaseModule (fsLit "Control.Monad.Zip")
+mONAD_FAIL = mkBaseModule (fsLit "Control.Monad.Fail")
aRROW = mkBaseModule (fsLit "Control.Arrow")
cONTROL_APPLICATIVE = mkBaseModule (fsLit "Control.Applicative")
gHC_DESUGAR = mkBaseModule (fsLit "GHC.Desugar")
@@ -566,11 +568,12 @@ map_RDR, append_RDR :: RdrName
map_RDR = varQual_RDR gHC_BASE (fsLit "map")
append_RDR = varQual_RDR gHC_BASE (fsLit "++")
-foldr_RDR, build_RDR, returnM_RDR, bindM_RDR, failM_RDR :: RdrName
+foldr_RDR, build_RDR, returnM_RDR, bindM_RDR, failM_RDR_preMFP, failM_RDR:: RdrName
foldr_RDR = nameRdrName foldrName
build_RDR = nameRdrName buildName
returnM_RDR = nameRdrName returnMName
bindM_RDR = nameRdrName bindMName
+failM_RDR_preMFP = nameRdrName failMName_preMFP
failM_RDR = nameRdrName failMName
left_RDR, right_RDR :: RdrName
@@ -912,12 +915,17 @@ functorClassName = clsQual gHC_BASE (fsLit "Functor") functorClassKey
fmapName = varQual gHC_BASE (fsLit "fmap") fmapClassOpKey
-- Class Monad
-monadClassName, thenMName, bindMName, returnMName, failMName :: Name
+monadClassName, thenMName, bindMName, returnMName, failMName_preMFP :: Name
monadClassName = clsQual gHC_BASE (fsLit "Monad") monadClassKey
thenMName = varQual gHC_BASE (fsLit ">>") thenMClassOpKey
bindMName = varQual gHC_BASE (fsLit ">>=") bindMClassOpKey
returnMName = varQual gHC_BASE (fsLit "return") returnMClassOpKey
-failMName = varQual gHC_BASE (fsLit "fail") failMClassOpKey
+failMName_preMFP = varQual gHC_BASE (fsLit "fail") failMClassOpKey_preMFP
+
+-- Class MonadFail
+monadFailClassName, failMName :: Name
+monadFailClassName = clsQual mONAD_FAIL (fsLit "MonadFail") monadFailClassKey
+failMName = varQual mONAD_FAIL (fsLit "fail") failMClassOpKey
-- Classes (Applicative, Foldable, Traversable)
applicativeClassName, foldableClassName, traversableClassName :: Name
@@ -1385,6 +1393,9 @@ typeable7ClassKey = mkPreludeClassUnique 27
monadFixClassKey :: Unique
monadFixClassKey = mkPreludeClassUnique 28
+monadFailClassKey :: Unique
+monadFailClassKey = mkPreludeClassUnique 29
+
monadPlusClassKey, randomClassKey, randomGenClassKey :: Unique
monadPlusClassKey = mkPreludeClassUnique 30
randomClassKey = mkPreludeClassUnique 31
@@ -1951,14 +1962,14 @@ uniques so we can look them up easily when we want to conjure them up
during type checking.
-}
- -- Just a place holder for unbound variables produced by the renamer:
+-- Just a placeholder for unbound variables produced by the renamer:
unboundKey :: Unique
unboundKey = mkPreludeMiscIdUnique 158
fromIntegerClassOpKey, minusClassOpKey, fromRationalClassOpKey,
enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey,
enumFromThenToClassOpKey, eqClassOpKey, geClassOpKey, negateClassOpKey,
- failMClassOpKey, bindMClassOpKey, thenMClassOpKey, returnMClassOpKey,
+ failMClassOpKey_preMFP, bindMClassOpKey, thenMClassOpKey, returnMClassOpKey,
fmapClassOpKey
:: Unique
fromIntegerClassOpKey = mkPreludeMiscIdUnique 160
@@ -1971,7 +1982,7 @@ enumFromThenToClassOpKey = mkPreludeMiscIdUnique 166
eqClassOpKey = mkPreludeMiscIdUnique 167
geClassOpKey = mkPreludeMiscIdUnique 168
negateClassOpKey = mkPreludeMiscIdUnique 169
-failMClassOpKey = mkPreludeMiscIdUnique 170
+failMClassOpKey_preMFP = mkPreludeMiscIdUnique 170
bindMClassOpKey = mkPreludeMiscIdUnique 171 -- (>>=)
thenMClassOpKey = mkPreludeMiscIdUnique 172 -- (>>)
fmapClassOpKey = mkPreludeMiscIdUnique 173
@@ -1981,6 +1992,10 @@ returnMClassOpKey = mkPreludeMiscIdUnique 174
mfixIdKey :: Unique
mfixIdKey = mkPreludeMiscIdUnique 175
+-- MonadFail operations
+failMClassOpKey :: Unique
+failMClassOpKey = mkPreludeMiscIdUnique 176
+
-- Arrow notation
arrAIdKey, composeAIdKey, firstAIdKey, appAIdKey, choiceAIdKey,
loopAIdKey :: Unique
@@ -2086,7 +2101,7 @@ standardClassKeys :: [Unique]
standardClassKeys = derivableClassKeys ++ numericClassKeys
++ [randomClassKey, randomGenClassKey,
functorClassKey,
- monadClassKey, monadPlusClassKey,
+ monadClassKey, monadPlusClassKey, monadFailClassKey,
isStringClassKey,
applicativeClassKey, foldableClassKey,
traversableClassKey, alternativeClassKey
diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs
index 919a1d51fe..68140f73f3 100644
--- a/compiler/prelude/PrelRules.hs
+++ b/compiler/prelude/PrelRules.hs
@@ -55,6 +55,9 @@ import Control.Applicative ( Applicative(..), Alternative(..) )
#endif
import Control.Monad
+#if __GLASGOW_HASKELL__ > 710
+import qualified Control.Monad.Fail as MonadFail
+#endif
import Data.Bits as Bits
import qualified Data.ByteString as BS
import Data.Int
@@ -653,6 +656,11 @@ instance Monad RuleM where
Just r -> runRuleM (g r) dflags iu e
fail _ = mzero
+#if __GLASGOW_HASKELL__ > 710
+instance MonadFail.MonadFail RuleM where
+ fail _ = mzero
+#endif
+
instance Alternative RuleM where
empty = mzero
(<|>) = mplus
diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs
index 1e8eb27e9f..c0d88e9f35 100644
--- a/compiler/rename/RnEnv.hs
+++ b/compiler/rename/RnEnv.hs
@@ -1441,8 +1441,8 @@ lookupIfThenElse :: RnM (Maybe (SyntaxExpr Name), FreeVars)
-- case we desugar directly rather than calling an existing function
-- Hence the (Maybe (SyntaxExpr Name)) return type
lookupIfThenElse
- = do { rebind <- xoptM Opt_RebindableSyntax
- ; if not rebind
+ = do { rebindable_on <- xoptM Opt_RebindableSyntax
+ ; if not rebindable_on
then return (Nothing, emptyFVs)
else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse"))
; return (Just (HsVar ite), unitFV ite) } }
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index d748bf0bc0..a8b1d2e7c8 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -10,7 +10,8 @@ general, all of these functions return a renamed thing, and a set of
free variables.
-}
-{-# LANGUAGE CPP, ScopedTypeVariables, RecordWildCards #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module RnExpr (
rnLExpr, rnExpr, rnStmts
@@ -787,7 +788,12 @@ rnStmt ctxt rnBody (L loc (BindStmt pat body _ _)) thing_inside
= do { (body', fv_expr) <- rnBody body
-- The binders do not scope over the expression
; (bind_op, fvs1) <- lookupStmtName ctxt bindMName
- ; (fail_op, fvs2) <- lookupStmtName ctxt failMName
+
+ ; xMonadFailEnabled <- fmap (xopt Opt_MonadFailDesugaring) getDynFlags
+ ; let failFunction | xMonadFailEnabled = failMName
+ | otherwise = failMName_preMFP
+ ; (fail_op, fvs2) <- lookupSyntaxName failFunction
+
; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
{ (thing, fvs3) <- thing_inside (collectPatBinders pat')
; return (( [(L loc (BindStmt pat' body' bind_op fail_op), fv_expr)]
@@ -1091,7 +1097,12 @@ rn_rec_stmt rnBody _ (L loc (BodyStmt body _ _ _), _)
rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _), fv_pat)
= do { (body', fv_expr) <- rnBody body
; (bind_op, fvs1) <- lookupSyntaxName bindMName
- ; (fail_op, fvs2) <- lookupSyntaxName failMName
+
+ ; xMonadFailEnabled <- fmap (xopt Opt_MonadFailDesugaring) getDynFlags
+ ; let failFunction | xMonadFailEnabled = failMName
+ | otherwise = failMName_preMFP
+ ; (fail_op, fvs2) <- lookupSyntaxName failFunction
+
; let bndrs = mkNameSet (collectPatBinders pat')
fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs
index 31d8212831..cb671be7a5 100644
--- a/compiler/specialise/Specialise.hs
+++ b/compiler/specialise/Specialise.hs
@@ -40,6 +40,9 @@ import State
import Control.Applicative (Applicative(..))
#endif
import Control.Monad
+#if __GLASGOW_HASKELL__ > 710
+import qualified Control.Monad.Fail as MonadFail
+#endif
import Data.Map (Map)
import qualified Data.Map as Map
import qualified FiniteMap as Map
@@ -2088,6 +2091,11 @@ instance Monad SpecM where
return = pure
fail str = SpecM $ fail str
+#if __GLASGOW_HASKELL__ > 710
+instance MonadFail.MonadFail SpecM where
+ fail str = SpecM $ fail str
+#endif
+
instance MonadUnique SpecM where
getUniqueSupplyM
= SpecM $ do st <- get
diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs
index bb7a3744f0..0d6e185ab8 100644
--- a/compiler/typecheck/TcArrows.hs
+++ b/compiler/typecheck/TcArrows.hs
@@ -354,7 +354,7 @@ tcArrDoStmt env ctxt (BindStmt pat rhs _ _) res_ty thing_inside
= do { (rhs', pat_ty) <- tc_arr_rhs env rhs
; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
thing_inside res_ty
- ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
+ ; return (mkBindStmt pat' rhs', thing) }
tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
, recS_rec_ids = rec_names }) res_ty thing_inside
diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs
index 5fdd7def0d..011b70299f 100644
--- a/compiler/typecheck/TcErrors.hs
+++ b/compiler/typecheck/TcErrors.hs
@@ -463,12 +463,23 @@ mkGroupReporter mk_err ctxt cts
reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> ReportErrCtxt
-> [Ct] -> TcM ()
-reportGroup mk_err ctxt cts
- = do { err <- mk_err ctxt cts
- ; maybeReportError ctxt err
- ; mapM_ (maybeAddDeferredBinding ctxt err) cts }
- -- Add deferred bindings for all
- -- But see Note [Always warn with -fdefer-type-errors]
+reportGroup mk_err ctxt cts =
+ case partition isMonadFailInstanceMissing cts of
+ -- Only warn about missing MonadFail constraint when
+ -- there are no other missing contstraints!
+ (monadFailCts, []) -> do { err <- mk_err ctxt monadFailCts
+ ; reportWarning err }
+
+ (_, cts') -> do { err <- mk_err ctxt cts'
+ ; maybeReportError ctxt err
+ ; mapM_ (maybeAddDeferredBinding ctxt err) cts' }
+ -- Add deferred bindings for all
+ -- But see Note [Always warn with -fdefer-type-errors]
+ where
+ isMonadFailInstanceMissing ct =
+ case ctLocOrigin (ctLoc ct) of
+ FailablePattern _pat -> True
+ _otherwise -> False
maybeReportHoleError :: ReportErrCtxt -> Ct -> ErrMsg -> TcM ()
maybeReportHoleError ctxt ct err
diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs
index d7dbddf6ec..b504206a2a 100644
--- a/compiler/typecheck/TcMatches.hs
+++ b/compiler/typecheck/TcMatches.hs
@@ -6,7 +6,9 @@
TcMatches: Typecheck some @Matches@
-}
-{-# LANGUAGE CPP, RankNTypes #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MultiWayIf #-}
module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
TcMatchCtxt(..), TcStmtChecker, TcExprStmtChecker, TcCmdStmtChecker,
@@ -36,6 +38,10 @@ import Outputable
import Util
import SrcLoc
import FastString
+import DynFlags
+import PrelNames (monadFailClassName)
+import Type
+import Inst
-- Create chunkified tuple tybes for monad comprehensions
import MkCore
@@ -517,15 +523,18 @@ 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
+ -- 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)
+ then return noSyntaxExpr
+ else tcSyntaxOp MCompOrigin 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
+
; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
-- Boolean expressions.
@@ -764,16 +773,18 @@ 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
+ -- 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)
+ then return noSyntaxExpr
+ else tcSyntaxOp DoOrigin 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
+
; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
tcDoStmt ctxt (ApplicativeStmt pairs mb_join _) res_ty thing_inside
@@ -847,6 +858,8 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
tcDoStmt _ stmt _ _
= pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
+
+
{-
Note [Treat rebindable syntax first]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -859,6 +872,64 @@ Otherwise the error shows up when cheking the rebindable syntax, and
the expected/inferred stuff is back to front (see Trac #3613).
-}
+
+
+---------------------------------------------------
+-- MonadFail Proposal warnings
+---------------------------------------------------
+
+-- The idea behind issuing MonadFail warnings is that we add them whenever a
+-- failable pattern is encountered. However, instead of throwing a type error
+-- 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 ()
+
+warnRebindableClash :: LPat TcId -> TcRn ()
+warnRebindableClash pattern = addWarnAt (getLoc pattern)
+ (text "The failable pattern" <+> quotes (ppr pattern)
+ $$
+ nest 2 (text "is used together with -XRebindableSyntax."
+ <+> text "If this is intentional,"
+ $$
+ 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]
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index 1b2a8d993e..a15fa7c923 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -76,7 +76,7 @@ import RnEnv
import RnSource
import ErrUtils
import Id
-import IdInfo( IdDetails( VanillaId ) )
+import IdInfo
import VarEnv
import Module
import UniqFM
@@ -103,7 +103,6 @@ import FastString
import Maybes
import Util
import Bag
-import IdInfo
import Control.Monad
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 66635a0e6c..18ba7cec63 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -147,6 +147,9 @@ import FastString
import GHC.Fingerprint
import Control.Monad (ap, liftM, msum)
+#if __GLASGOW_HASKELL__ > 710
+import qualified Control.Monad.Fail as MonadFail
+#endif
#ifdef GHCI
import Data.Map ( Map )
@@ -2263,6 +2266,8 @@ data CtOrigin
| UnboundOccurrenceOf RdrName
| ListOrigin -- An overloaded list
| StaticOrigin -- A static form
+ | FailablePattern (LPat TcId) -- A failable pattern in do-notation for the
+ -- MonadFail Proposal (MFP)
ctoHerald :: SDoc
ctoHerald = ptext (sLit "arising from")
@@ -2352,6 +2357,8 @@ 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"
{-
@@ -2380,6 +2387,11 @@ instance Monad TcPluginM where
TcPluginM (\ ev -> do a <- m ev
runTcPluginM (k a) ev)
+#if __GLASGOW_HASKELL__ > 710
+instance MonadFail.MonadFail TcPluginM where
+ fail x = TcPluginM (const $ fail x)
+#endif
+
runTcPluginM :: TcPluginM a -> Maybe EvBindsVar -> TcM a
runTcPluginM (TcPluginM m) = m
diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
index ec1ef18890..7f2dd66228 100644
--- a/compiler/typecheck/TcSMonad.hs
+++ b/compiler/typecheck/TcSMonad.hs
@@ -144,6 +144,9 @@ import Maybes ( orElse, firstJusts )
import TrieMap
import Control.Arrow ( first )
import Control.Monad( ap, when, unless, MonadPlus(..) )
+#if __GLASGOW_HASKELL__ > 710
+import qualified Control.Monad.Fail as MonadFail
+#endif
import MonadUtils
import Data.IORef
import Data.List ( foldl', partition )
@@ -2166,6 +2169,11 @@ instance Monad TcS where
fail err = TcS (\_ -> fail err)
m >>= k = TcS (\ebs -> unTcS m ebs >>= \r -> unTcS (k r) ebs)
+#if __GLASGOW_HASKELL__ > 710
+instance MonadFail.MonadFail TcS where
+ fail err = TcS (\_ -> fail err)
+#endif
+
instance MonadUnique TcS where
getUniqueSupplyM = wrapTcS getUniqueSupplyM
diff --git a/compiler/types/Unify.hs b/compiler/types/Unify.hs
index 87681e0eb8..a29c85f2da 100644
--- a/compiler/types/Unify.hs
+++ b/compiler/types/Unify.hs
@@ -34,6 +34,9 @@ import Outputable
import FastString (sLit)
import Control.Monad (liftM, foldM, ap)
+#if __GLASGOW_HASKELL__ > 710
+import qualified Control.Monad.Fail as MonadFail
+#endif
#if __GLASGOW_HASKELL__ < 709
import Control.Applicative (Applicative(..))
#endif
@@ -729,6 +732,11 @@ instance Monad UM where
other -> other
SurelyApart -> SurelyApart)
+#if __GLASGOW_HASKELL__ > 710
+instance MonadFail.MonadFail UM where
+ fail _ = UM (\_tvs _subst -> SurelyApart) -- failed pattern match
+#endif
+
-- returns an idempotent substitution
initUM :: (TyVar -> BindFlag) -> UM () -> UnifyResult
initUM badtvs um = fmap (niFixTvSubst . snd) $ unUM um badtvs emptyTvSubstEnv
diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs
index 31ac2b3731..804ddd8e70 100644
--- a/compiler/utils/IOEnv.hs
+++ b/compiler/utils/IOEnv.hs
@@ -43,6 +43,9 @@ import Data.Typeable
import System.IO.Unsafe ( unsafeInterleaveIO )
import System.IO ( fixIO )
import Control.Monad
+#if __GLASGOW_HASKELL__ > 710
+import qualified Control.Monad.Fail as MonadFail
+#endif
import MonadUtils
import Control.Applicative (Alternative(..))
@@ -62,6 +65,12 @@ instance Monad (IOEnv m) where
return = pure
fail _ = failM -- Ignore the string
+#if __GLASGOW_HASKELL__ > 710
+instance MonadFail.MonadFail (IOEnv m) where
+ fail _ = failM -- Ignore the string
+#endif
+
+
instance Applicative (IOEnv m) where
pure = returnM
IOEnv f <*> IOEnv x = IOEnv (\ env -> f env <*> x env )
diff --git a/compiler/utils/Maybes.hs b/compiler/utils/Maybes.hs
index 56b6dab5d9..656f40a372 100644
--- a/compiler/utils/Maybes.hs
+++ b/compiler/utils/Maybes.hs
@@ -20,6 +20,9 @@ module Maybes (
import Control.Applicative
import Control.Monad
+#if __GLASGOW_HASKELL__ > 710
+import Control.Monad.Fail
+#endif
import Data.Maybe
infixr 4 `orElse`
@@ -85,6 +88,12 @@ instance (Monad m) => Monad (MaybeT m) where
x >>= f = MaybeT $ runMaybeT x >>= maybe (pure Nothing) (runMaybeT . f)
fail _ = MaybeT $ pure Nothing
+
+#if __GLASGOW_HASKELL__ > 710
+instance Monad m => MonadFail (MaybeT m) where
+ fail _ = MaybeT $ return Nothing
+#endif
+
#if __GLASGOW_HASKELL__ < 710
-- Pre-AMP change
instance (Monad m, Applicative m) => Alternative (MaybeT m) where
View Lorry Controller Status