Commit 233d1312 authored by quchen's avatar quchen Committed by Ben Gamari

MonadFail proposal, phase 1

This implements phase 1 of the MonadFail proposal (MFP, #10751).

- MonadFail warnings are all issued as desired, tunable with two new flags
- GHC was *not* made warning-free with `-fwarn-missing-monadfail-warnings`
  (but it's disabled by default right now)

Credits/thanks to
- Franz Thoma, whose help was crucial to implementing this
- My employer TNG Technology Consulting GmbH for partially funding us
  for this work

Reviewers: goldfire, austin, #core_libraries_committee, hvr, bgamari, fmthoma

Reviewed By: hvr, bgamari, fmthoma

Subscribers: thomie

Projects: #ghc

Differential Revision: https://phabricator.haskell.org/D1248

GHC Trac Issues: #10751
parent 7b962bab
...@@ -64,6 +64,9 @@ import Demand ( splitStrictSig, isBotRes ) ...@@ -64,6 +64,9 @@ import Demand ( splitStrictSig, isBotRes )
import HscTypes import HscTypes
import DynFlags import DynFlags
import Control.Monad import Control.Monad
#if __GLASGOW_HASKELL__ > 710
import qualified Control.Monad.Fail as MonadFail
#endif
import MonadUtils import MonadUtils
import Data.Maybe import Data.Maybe
import Pair import Pair
...@@ -1503,6 +1506,11 @@ instance Monad LintM where ...@@ -1503,6 +1506,11 @@ instance Monad LintM where
Just r -> unLintM (k r) env errs' Just r -> unLintM (k r) env errs'
Nothing -> (Nothing, errs')) Nothing -> (Nothing, errs'))
#if __GLASGOW_HASKELL__ > 710
instance MonadFail.MonadFail LintM where
fail err = failWithL (text err)
#endif
instance HasDynFlags LintM where instance HasDynFlags LintM where
getDynFlags = LintM (\ e errs -> (Just (le_dynflags e), errs)) getDynFlags = LintM (\ e errs -> (Just (le_dynflags e), errs))
......
...@@ -1336,7 +1336,7 @@ data StmtLR idL idR body -- body should always be (LHs**** idR) ...@@ -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 -- For details on above see note [Api annotations] in ApiAnnotation
| BindStmt (LPat idL) | BindStmt (LPat idL)
body 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 (SyntaxExpr idR) -- The fail operator
-- The fail operator is noSyntaxExpr -- The fail operator is noSyntaxExpr
-- if the pattern match can't fail -- if the pattern match can't fail
......
...@@ -505,6 +505,7 @@ data WarningFlag = ...@@ -505,6 +505,7 @@ data WarningFlag =
| Opt_WarnWarningsDeprecations | Opt_WarnWarningsDeprecations
| Opt_WarnDeprecatedFlags | Opt_WarnDeprecatedFlags
| Opt_WarnAMP | Opt_WarnAMP
| Opt_WarnMissingMonadFailInstance
| Opt_WarnDodgyExports | Opt_WarnDodgyExports
| Opt_WarnDodgyImports | Opt_WarnDodgyImports
| Opt_WarnOrphans | Opt_WarnOrphans
...@@ -656,6 +657,7 @@ data ExtensionFlag ...@@ -656,6 +657,7 @@ data ExtensionFlag
| Opt_StaticPointers | Opt_StaticPointers
| Opt_Strict | Opt_Strict
| Opt_StrictData | Opt_StrictData
| Opt_MonadFailDesugaring
deriving (Eq, Enum, Show) deriving (Eq, Enum, Show)
type SigOf = Map ModuleName Module type SigOf = Map ModuleName Module
...@@ -2898,6 +2900,7 @@ fWarningFlags = [ ...@@ -2898,6 +2900,7 @@ fWarningFlags = [
flagSpec "warn-missing-import-lists" Opt_WarnMissingImportList, flagSpec "warn-missing-import-lists" Opt_WarnMissingImportList,
flagSpec "warn-missing-local-sigs" Opt_WarnMissingLocalSigs, flagSpec "warn-missing-local-sigs" Opt_WarnMissingLocalSigs,
flagSpec "warn-missing-methods" Opt_WarnMissingMethods, flagSpec "warn-missing-methods" Opt_WarnMissingMethods,
flagSpec "warn-missing-monadfail-instance" Opt_WarnMissingMonadFailInstance,
flagSpec "warn-missing-signatures" Opt_WarnMissingSigs, flagSpec "warn-missing-signatures" Opt_WarnMissingSigs,
flagSpec "warn-missing-exported-sigs" Opt_WarnMissingExportedSigs, flagSpec "warn-missing-exported-sigs" Opt_WarnMissingExportedSigs,
flagSpec "warn-monomorphism-restriction" Opt_WarnMonomorphism, flagSpec "warn-monomorphism-restriction" Opt_WarnMonomorphism,
...@@ -3168,6 +3171,7 @@ xFlags = [ ...@@ -3168,6 +3171,7 @@ xFlags = [
flagSpec "LiberalTypeSynonyms" Opt_LiberalTypeSynonyms, flagSpec "LiberalTypeSynonyms" Opt_LiberalTypeSynonyms,
flagSpec "MagicHash" Opt_MagicHash, flagSpec "MagicHash" Opt_MagicHash,
flagSpec "MonadComprehensions" Opt_MonadComprehensions, flagSpec "MonadComprehensions" Opt_MonadComprehensions,
flagSpec "MonadFailDesugaring" Opt_MonadFailDesugaring,
flagSpec "MonoLocalBinds" Opt_MonoLocalBinds, flagSpec "MonoLocalBinds" Opt_MonoLocalBinds,
flagSpec' "MonoPatBinds" Opt_MonoPatBinds flagSpec' "MonoPatBinds" Opt_MonoPatBinds
(\ turn_on -> when turn_on $ (\ turn_on -> when turn_on $
......
...@@ -78,6 +78,9 @@ module Lexer ( ...@@ -78,6 +78,9 @@ module Lexer (
import Control.Applicative import Control.Applicative
#endif #endif
import Control.Monad import Control.Monad
#if __GLASGOW_HASKELL__ > 710
import Control.Monad.Fail
#endif
import Data.Bits import Data.Bits
import Data.Char import Data.Char
import Data.List import Data.List
...@@ -1755,6 +1758,11 @@ instance Monad P where ...@@ -1755,6 +1758,11 @@ instance Monad P where
(>>=) = thenP (>>=) = thenP
fail = failP fail = failP
#if __GLASGOW_HASKELL__ > 710
instance MonadFail P where
fail = failP
#endif
returnP :: a -> P a returnP :: a -> P a
returnP a = a `seq` (P $ \s -> POk s a) returnP a = a `seq` (P $ \s -> POk s a)
......
...@@ -239,10 +239,11 @@ basicKnownKeyNames ...@@ -239,10 +239,11 @@ basicKnownKeyNames
apAName, apAName,
-- Monad stuff -- Monad stuff
thenIOName, bindIOName, returnIOName, failIOName, thenIOName, bindIOName, returnIOName, failIOName, bindMName, thenMName,
failMName, bindMName, thenMName, returnMName, returnMName, fmapName, joinMName,
fmapName,
joinMName, -- MonadFail
monadFailClassName, failMName, failMName_preMFP,
-- MonadFix -- MonadFix
monadFixClassName, mfixName, monadFixClassName, mfixName,
...@@ -408,7 +409,7 @@ gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC, ...@@ -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_ST, gHC_ARR, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL,
gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC,
tYPEABLE, tYPEABLE_INTERNAL, gENERICS, 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, aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS,
cONTROL_EXCEPTION_BASE, gHC_TYPELITS :: Module cONTROL_EXCEPTION_BASE, gHC_TYPELITS :: Module
...@@ -456,6 +457,7 @@ gHC_WORD = mkBaseModule (fsLit "GHC.Word") ...@@ -456,6 +457,7 @@ gHC_WORD = mkBaseModule (fsLit "GHC.Word")
mONAD = mkBaseModule (fsLit "Control.Monad") mONAD = mkBaseModule (fsLit "Control.Monad")
mONAD_FIX = mkBaseModule (fsLit "Control.Monad.Fix") mONAD_FIX = mkBaseModule (fsLit "Control.Monad.Fix")
mONAD_ZIP = mkBaseModule (fsLit "Control.Monad.Zip") mONAD_ZIP = mkBaseModule (fsLit "Control.Monad.Zip")
mONAD_FAIL = mkBaseModule (fsLit "Control.Monad.Fail")
aRROW = mkBaseModule (fsLit "Control.Arrow") aRROW = mkBaseModule (fsLit "Control.Arrow")
cONTROL_APPLICATIVE = mkBaseModule (fsLit "Control.Applicative") cONTROL_APPLICATIVE = mkBaseModule (fsLit "Control.Applicative")
gHC_DESUGAR = mkBaseModule (fsLit "GHC.Desugar") gHC_DESUGAR = mkBaseModule (fsLit "GHC.Desugar")
...@@ -566,11 +568,12 @@ map_RDR, append_RDR :: RdrName ...@@ -566,11 +568,12 @@ map_RDR, append_RDR :: RdrName
map_RDR = varQual_RDR gHC_BASE (fsLit "map") map_RDR = varQual_RDR gHC_BASE (fsLit "map")
append_RDR = varQual_RDR gHC_BASE (fsLit "++") 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 foldr_RDR = nameRdrName foldrName
build_RDR = nameRdrName buildName build_RDR = nameRdrName buildName
returnM_RDR = nameRdrName returnMName returnM_RDR = nameRdrName returnMName
bindM_RDR = nameRdrName bindMName bindM_RDR = nameRdrName bindMName
failM_RDR_preMFP = nameRdrName failMName_preMFP
failM_RDR = nameRdrName failMName failM_RDR = nameRdrName failMName
left_RDR, right_RDR :: RdrName left_RDR, right_RDR :: RdrName
...@@ -912,12 +915,17 @@ functorClassName = clsQual gHC_BASE (fsLit "Functor") functorClassKey ...@@ -912,12 +915,17 @@ functorClassName = clsQual gHC_BASE (fsLit "Functor") functorClassKey
fmapName = varQual gHC_BASE (fsLit "fmap") fmapClassOpKey fmapName = varQual gHC_BASE (fsLit "fmap") fmapClassOpKey
-- Class Monad -- Class Monad
monadClassName, thenMName, bindMName, returnMName, failMName :: Name monadClassName, thenMName, bindMName, returnMName, failMName_preMFP :: Name
monadClassName = clsQual gHC_BASE (fsLit "Monad") monadClassKey monadClassName = clsQual gHC_BASE (fsLit "Monad") monadClassKey
thenMName = varQual gHC_BASE (fsLit ">>") thenMClassOpKey thenMName = varQual gHC_BASE (fsLit ">>") thenMClassOpKey
bindMName = varQual gHC_BASE (fsLit ">>=") bindMClassOpKey bindMName = varQual gHC_BASE (fsLit ">>=") bindMClassOpKey
returnMName = varQual gHC_BASE (fsLit "return") returnMClassOpKey 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) -- Classes (Applicative, Foldable, Traversable)
applicativeClassName, foldableClassName, traversableClassName :: Name applicativeClassName, foldableClassName, traversableClassName :: Name
...@@ -1385,6 +1393,9 @@ typeable7ClassKey = mkPreludeClassUnique 27 ...@@ -1385,6 +1393,9 @@ typeable7ClassKey = mkPreludeClassUnique 27
monadFixClassKey :: Unique monadFixClassKey :: Unique
monadFixClassKey = mkPreludeClassUnique 28 monadFixClassKey = mkPreludeClassUnique 28
monadFailClassKey :: Unique
monadFailClassKey = mkPreludeClassUnique 29
monadPlusClassKey, randomClassKey, randomGenClassKey :: Unique monadPlusClassKey, randomClassKey, randomGenClassKey :: Unique
monadPlusClassKey = mkPreludeClassUnique 30 monadPlusClassKey = mkPreludeClassUnique 30
randomClassKey = mkPreludeClassUnique 31 randomClassKey = mkPreludeClassUnique 31
...@@ -1951,14 +1962,14 @@ uniques so we can look them up easily when we want to conjure them up ...@@ -1951,14 +1962,14 @@ uniques so we can look them up easily when we want to conjure them up
during type checking. 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 :: Unique
unboundKey = mkPreludeMiscIdUnique 158 unboundKey = mkPreludeMiscIdUnique 158
fromIntegerClassOpKey, minusClassOpKey, fromRationalClassOpKey, fromIntegerClassOpKey, minusClassOpKey, fromRationalClassOpKey,
enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey, enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey,
enumFromThenToClassOpKey, eqClassOpKey, geClassOpKey, negateClassOpKey, enumFromThenToClassOpKey, eqClassOpKey, geClassOpKey, negateClassOpKey,
failMClassOpKey, bindMClassOpKey, thenMClassOpKey, returnMClassOpKey, failMClassOpKey_preMFP, bindMClassOpKey, thenMClassOpKey, returnMClassOpKey,
fmapClassOpKey fmapClassOpKey
:: Unique :: Unique
fromIntegerClassOpKey = mkPreludeMiscIdUnique 160 fromIntegerClassOpKey = mkPreludeMiscIdUnique 160
...@@ -1971,7 +1982,7 @@ enumFromThenToClassOpKey = mkPreludeMiscIdUnique 166 ...@@ -1971,7 +1982,7 @@ enumFromThenToClassOpKey = mkPreludeMiscIdUnique 166
eqClassOpKey = mkPreludeMiscIdUnique 167 eqClassOpKey = mkPreludeMiscIdUnique 167
geClassOpKey = mkPreludeMiscIdUnique 168 geClassOpKey = mkPreludeMiscIdUnique 168
negateClassOpKey = mkPreludeMiscIdUnique 169 negateClassOpKey = mkPreludeMiscIdUnique 169
failMClassOpKey = mkPreludeMiscIdUnique 170 failMClassOpKey_preMFP = mkPreludeMiscIdUnique 170
bindMClassOpKey = mkPreludeMiscIdUnique 171 -- (>>=) bindMClassOpKey = mkPreludeMiscIdUnique 171 -- (>>=)
thenMClassOpKey = mkPreludeMiscIdUnique 172 -- (>>) thenMClassOpKey = mkPreludeMiscIdUnique 172 -- (>>)
fmapClassOpKey = mkPreludeMiscIdUnique 173 fmapClassOpKey = mkPreludeMiscIdUnique 173
...@@ -1981,6 +1992,10 @@ returnMClassOpKey = mkPreludeMiscIdUnique 174 ...@@ -1981,6 +1992,10 @@ returnMClassOpKey = mkPreludeMiscIdUnique 174
mfixIdKey :: Unique mfixIdKey :: Unique
mfixIdKey = mkPreludeMiscIdUnique 175 mfixIdKey = mkPreludeMiscIdUnique 175
-- MonadFail operations
failMClassOpKey :: Unique
failMClassOpKey = mkPreludeMiscIdUnique 176
-- Arrow notation -- Arrow notation
arrAIdKey, composeAIdKey, firstAIdKey, appAIdKey, choiceAIdKey, arrAIdKey, composeAIdKey, firstAIdKey, appAIdKey, choiceAIdKey,
loopAIdKey :: Unique loopAIdKey :: Unique
...@@ -2086,7 +2101,7 @@ standardClassKeys :: [Unique] ...@@ -2086,7 +2101,7 @@ standardClassKeys :: [Unique]
standardClassKeys = derivableClassKeys ++ numericClassKeys standardClassKeys = derivableClassKeys ++ numericClassKeys
++ [randomClassKey, randomGenClassKey, ++ [randomClassKey, randomGenClassKey,
functorClassKey, functorClassKey,
monadClassKey, monadPlusClassKey, monadClassKey, monadPlusClassKey, monadFailClassKey,
isStringClassKey, isStringClassKey,
applicativeClassKey, foldableClassKey, applicativeClassKey, foldableClassKey,
traversableClassKey, alternativeClassKey traversableClassKey, alternativeClassKey
......
...@@ -55,6 +55,9 @@ import Control.Applicative ( Applicative(..), Alternative(..) ) ...@@ -55,6 +55,9 @@ import Control.Applicative ( Applicative(..), Alternative(..) )
#endif #endif
import Control.Monad import Control.Monad
#if __GLASGOW_HASKELL__ > 710
import qualified Control.Monad.Fail as MonadFail
#endif
import Data.Bits as Bits import Data.Bits as Bits
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Data.Int import Data.Int
...@@ -653,6 +656,11 @@ instance Monad RuleM where ...@@ -653,6 +656,11 @@ instance Monad RuleM where
Just r -> runRuleM (g r) dflags iu e Just r -> runRuleM (g r) dflags iu e
fail _ = mzero fail _ = mzero
#if __GLASGOW_HASKELL__ > 710
instance MonadFail.MonadFail RuleM where
fail _ = mzero
#endif
instance Alternative RuleM where instance Alternative RuleM where
empty = mzero empty = mzero
(<|>) = mplus (<|>) = mplus
......
...@@ -1441,8 +1441,8 @@ lookupIfThenElse :: RnM (Maybe (SyntaxExpr Name), FreeVars) ...@@ -1441,8 +1441,8 @@ lookupIfThenElse :: RnM (Maybe (SyntaxExpr Name), FreeVars)
-- case we desugar directly rather than calling an existing function -- case we desugar directly rather than calling an existing function
-- Hence the (Maybe (SyntaxExpr Name)) return type -- Hence the (Maybe (SyntaxExpr Name)) return type
lookupIfThenElse lookupIfThenElse
= do { rebind <- xoptM Opt_RebindableSyntax = do { rebindable_on <- xoptM Opt_RebindableSyntax
; if not rebind ; if not rebindable_on
then return (Nothing, emptyFVs) then return (Nothing, emptyFVs)
else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse")) else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse"))
; return (Just (HsVar ite), unitFV ite) } } ; return (Just (HsVar ite), unitFV ite) } }
......
...@@ -10,7 +10,8 @@ general, all of these functions return a renamed thing, and a set of ...@@ -10,7 +10,8 @@ general, all of these functions return a renamed thing, and a set of
free variables. free variables.
-} -}
{-# LANGUAGE CPP, ScopedTypeVariables, RecordWildCards #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
module RnExpr ( module RnExpr (
rnLExpr, rnExpr, rnStmts rnLExpr, rnExpr, rnStmts
...@@ -787,7 +788,12 @@ rnStmt ctxt rnBody (L loc (BindStmt pat body _ _)) thing_inside ...@@ -787,7 +788,12 @@ rnStmt ctxt rnBody (L loc (BindStmt pat body _ _)) thing_inside
= do { (body', fv_expr) <- rnBody body = do { (body', fv_expr) <- rnBody body
-- The binders do not scope over the expression -- The binders do not scope over the expression
; (bind_op, fvs1) <- lookupStmtName ctxt bindMName ; (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 ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
{ (thing, fvs3) <- thing_inside (collectPatBinders pat') { (thing, fvs3) <- thing_inside (collectPatBinders pat')
; return (( [(L loc (BindStmt pat' body' bind_op fail_op), fv_expr)] ; return (( [(L loc (BindStmt pat' body' bind_op fail_op), fv_expr)]
...@@ -1091,7 +1097,12 @@ rn_rec_stmt rnBody _ (L loc (BodyStmt body _ _ _), _) ...@@ -1091,7 +1097,12 @@ rn_rec_stmt rnBody _ (L loc (BodyStmt body _ _ _), _)
rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _), fv_pat) rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _), fv_pat)
= do { (body', fv_expr) <- rnBody body = do { (body', fv_expr) <- rnBody body
; (bind_op, fvs1) <- lookupSyntaxName bindMName ; (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') ; let bndrs = mkNameSet (collectPatBinders pat')
fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2 fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
; return [(bndrs, fvs, bndrs `intersectNameSet` fvs, ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
......
...@@ -40,6 +40,9 @@ import State ...@@ -40,6 +40,9 @@ import State
import Control.Applicative (Applicative(..)) import Control.Applicative (Applicative(..))
#endif #endif
import Control.Monad import Control.Monad
#if __GLASGOW_HASKELL__ > 710
import qualified Control.Monad.Fail as MonadFail
#endif
import Data.Map (Map) import Data.Map (Map)
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified FiniteMap as Map import qualified FiniteMap as Map
...@@ -2088,6 +2091,11 @@ instance Monad SpecM where ...@@ -2088,6 +2091,11 @@ instance Monad SpecM where
return = pure return = pure
fail str = SpecM $ fail str fail str = SpecM $ fail str
#if __GLASGOW_HASKELL__ > 710
instance MonadFail.MonadFail SpecM where
fail str = SpecM $ fail str
#endif
instance MonadUnique SpecM where instance MonadUnique SpecM where
getUniqueSupplyM getUniqueSupplyM
= SpecM $ do st <- get = SpecM $ do st <- get
......
...@@ -354,7 +354,7 @@ tcArrDoStmt env ctxt (BindStmt pat rhs _ _) res_ty thing_inside ...@@ -354,7 +354,7 @@ tcArrDoStmt env ctxt (BindStmt pat rhs _ _) res_ty thing_inside
= do { (rhs', pat_ty) <- tc_arr_rhs env rhs = do { (rhs', pat_ty) <- tc_arr_rhs env rhs
; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $ ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
thing_inside res_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 tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
, recS_rec_ids = rec_names }) res_ty thing_inside , recS_rec_ids = rec_names }) res_ty thing_inside
......
...@@ -463,12 +463,23 @@ mkGroupReporter mk_err ctxt cts ...@@ -463,12 +463,23 @@ mkGroupReporter mk_err ctxt cts
reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> ReportErrCtxt reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> ReportErrCtxt
-> [Ct] -> TcM () -> [Ct] -> TcM ()
reportGroup mk_err ctxt cts reportGroup mk_err ctxt cts =
= do { err <- mk_err ctxt cts case partition isMonadFailInstanceMissing cts of
; maybeReportError ctxt err -- Only warn about missing MonadFail constraint when
; mapM_ (maybeAddDeferredBinding ctxt err) cts } -- there are no other missing contstraints!
-- Add deferred bindings for all (monadFailCts, []) -> do { err <- mk_err ctxt monadFailCts
-- But see Note [Always warn with -fdefer-type-errors] ; 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 :: ReportErrCtxt -> Ct -> ErrMsg -> TcM ()
maybeReportHoleError ctxt ct err maybeReportHoleError ctxt ct err
......
...@@ -6,7 +6,9 @@ ...@@ -6,7 +6,9 @@
TcMatches: Typecheck some @Matches@ TcMatches: Typecheck some @Matches@
-} -}
{-# LANGUAGE CPP, RankNTypes #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MultiWayIf #-}
module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambda, module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
TcMatchCtxt(..), TcStmtChecker, TcExprStmtChecker, TcCmdStmtChecker, TcMatchCtxt(..), TcStmtChecker, TcExprStmtChecker, TcCmdStmtChecker,
...@@ -36,6 +38,10 @@ import Outputable ...@@ -36,6 +38,10 @@ import Outputable
import Util import Util
import SrcLoc import SrcLoc
import FastString import FastString
import DynFlags
import PrelNames (monadFailClassName)
import Type
import Inst
-- Create chunkified tuple tybes for monad comprehensions -- Create chunkified tuple tybes for monad comprehensions
import MkCore import MkCore
...@@ -517,15 +523,18 @@ tcMcStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside ...@@ -517,15 +523,18 @@ 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 -- If (but only if) the pattern can fail, typecheck the 'fail' operator
; fail_op' <- if isIrrefutableHsPat pat ; fail_op' <- if isIrrefutableHsPat pat
then return noSyntaxExpr then return noSyntaxExpr
else tcSyntaxOp MCompOrigin fail_op (mkFunTy stringTy new_res_ty) else tcSyntaxOp MCompOrigin 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
; return (BindStmt pat' rhs' bind_op' fail_op', thing) } ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
-- Boolean expressions. -- Boolean expressions.
...@@ -764,16 +773,18 @@ tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside ...@@ -764,16 +773,18 @@ 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, -- If (but only if) the pattern can fail, typecheck the 'fail' operator
-- typecheck the 'fail' operator
; fail_op' <- if isIrrefutableHsPat pat ; fail_op' <- if isIrrefutableHsPat pat
then return noSyntaxExpr then return noSyntaxExpr
else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty) else tcSyntaxOp DoOrigin 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
; return (BindStmt pat' rhs' bind_op' fail_op', thing) } ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
tcDoStmt ctxt (ApplicativeStmt pairs mb_join _) res_ty thing_inside 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 ...@@ -847,6 +858,8 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
tcDoStmt _ stmt _ _ tcDoStmt _ stmt _ _
= pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt) = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
{- {-
Note [Treat rebindable syntax first] Note [Treat rebindable syntax first]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
...@@ -859,6 +872,64 @@ Otherwise the error shows up when cheking the rebindable syntax, and ...@@ -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). 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] Note [typechecking ApplicativeStmt]
......
...@@ -76,7 +76,7 @@ import RnEnv ...@@ -76,7 +76,7 @@ import RnEnv
import RnSource import RnSource
import ErrUtils import ErrUtils
import Id import Id
import IdInfo( IdDetails( VanillaId ) ) import IdInfo
import VarEnv import VarEnv
import Module import Module
import UniqFM import UniqFM
...@@ -103,7 +103,6 @@ import FastString ...@@ -103,7 +103,6 @@ import FastString
import Maybes import Maybes
import Util import Util
import Bag import Bag
import IdInfo
import Control.Monad import Control.Monad
......
...@@ -147,6 +147,9 @@ import FastString ...@@ -147,6 +147,9 @@ import FastString
import GHC.Fingerprint import GHC.Fingerprint
import Control.Monad (ap, liftM, msum) import Control.Monad (ap, liftM, msum)
#if __GLASGOW_HASKELL__ > 710
import qualified Control.Monad.Fail as MonadFail
#endif