import BasicTypes hiding (SuccessFlag(..))
import DynFlags
import SrcLoc
-import ErrUtils
import Util
import Outputable
import FastString
-> TcM a
-> TcM (LPat TcId, a)
tc_lpat (L span pat) pat_ty penv thing_inside
- = setSrcSpan span $
- maybeAddErrCtxt (patCtxt pat) $
- do { (pat', res) <- tc_pat penv pat pat_ty thing_inside
+ = setSrcSpan span $
+ do { (pat', res) <- maybeWrapPatCtxt pat (tc_pat penv pat pat_ty)
+ thing_inside
; return (L span pat', res) }
tc_lpats :: PatEnv
; return (mkHsWrapPat wrap (SigPatOut pat' inner_ty) pat_ty, res) }
-tc_pat _ pat@(TypePat _) _ _
- = failWithTc (badTypePat pat)
-
------------------------
-- Lists, tuples, arrays
tc_pat penv (ListPat pats _) pat_ty thing_inside
else do -- The general case, with existential,
-- and local equality constraints
- { let eq_preds = [mkEqPred (mkTyVarTy tv, ty) | (tv, ty) <- eq_spec]
- theta' = substTheta tenv (eq_preds ++ theta)
+ { let theta' = substTheta tenv (eqSpecPreds eq_spec ++ theta)
-- order is *important* as we generate the list of
-- dictionary binders from theta'
no_equalities = not (any isEqPred theta')
-- coi : T tys ~ pat_ty
\end{code}
-Noate [
Note [Matching constructor patterns]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose (coi, tys) = matchExpectedConType data_tc pat_ty
-}
\begin{code}
-patCtxt :: Pat Name -> Maybe Message -- Not all patterns are worth pushing a context
-patCtxt (VarPat _) = Nothing
-patCtxt (ParPat _) = Nothing
-patCtxt (AsPat _ _) = Nothing
-patCtxt pat = Just (hang (ptext (sLit "In the pattern:"))
- 2 (ppr pat))
+maybeWrapPatCtxt :: Pat Name -> (TcM a -> TcM b) -> TcM a -> TcM b
+-- Not all patterns are worth pushing a context
+maybeWrapPatCtxt pat tcm thing_inside
+ | not (worth_wrapping pat) = tcm thing_inside
+ | otherwise = addErrCtxt msg $ tcm $ popErrCtxt thing_inside
+ -- Remember to pop before doing thing_inside
+ where
+ worth_wrapping (VarPat {}) = False
+ worth_wrapping (ParPat {}) = False
+ worth_wrapping (AsPat {}) = False
+ worth_wrapping _ = True
+ msg = hang (ptext (sLit "In the pattern:")) 2 (ppr pat)
-----------------------------------------------
checkExistentials :: [TyVar] -> PatEnv -> TcM ()
= hang (ptext (sLit "Illegal polymorphic type signature in pattern:"))
2 (ppr sig_ty)
-badTypePat :: Pat Name -> SDoc
-badTypePat pat = ptext (sLit "Illegal type pattern") <+> ppr pat
-
lazyUnliftedPatErr :: OutputableBndr name => Pat name -> TcM ()
lazyUnliftedPatErr pat
= failWithTc $