import StaticFlags
import TyCon
import DataCon
-import VarSet ( emptyVarSet )
import PrelNames
import BasicTypes hiding (SuccessFlag(..))
import DynFlags
import SrcLoc
-import ErrUtils
import Util
import Outputable
import FastString
tcLetPat sig_fn no_gen pat pat_ty thing_inside
= tc_lpat pat pat_ty penv thing_inside
where
- penv = PE { pe_res_tvs = emptyVarSet, pe_lazy = True
+ penv = PE { pe_lazy = True
, pe_ctxt = LetPat sig_fn no_gen }
-----------------
tcPats :: HsMatchContext Name
-> [LPat Name] -- Patterns,
-> [TcSigmaType] -- and their types
- -> TcRhoType -- Result type,
-> TcM a -- and the checker for the body
-> TcM ([LPat TcId], a)
-- 3. Check the body
-- 4. Check that no existentials escape
-tcPats ctxt pats pat_tys res_ty thing_inside
+tcPats ctxt pats pat_tys thing_inside
= tc_lpats penv pats pat_tys thing_inside
where
- penv = PE { pe_res_tvs = tyVarsOfTypes (res_ty : pat_tys)
- , pe_lazy = False
- , pe_ctxt = LamPat ctxt }
+ penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt }
tcPat :: HsMatchContext Name
-> LPat Name -> TcSigmaType
- -> TcRhoType -- Result type
-> TcM a -- Checker for body, given
-- its result type
-> TcM (LPat TcId, a)
-tcPat ctxt pat pat_ty res_ty thing_inside
+tcPat ctxt pat pat_ty thing_inside
= tc_lpat pat pat_ty penv thing_inside
where
- penv = PE { pe_res_tvs = tyVarsOfTypes [res_ty, pat_ty]
- , pe_lazy = False
- , pe_ctxt = LamPat ctxt }
+ penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt }
-----------------
data PatEnv
- = PE { pe_res_tvs :: TcTyVarSet
- -- For existential escape check; see Note [Existential check]
- -- Nothing <=> inside a "~"
- -- Just tvs <=> unification tvs free in the result
- -- (which should be made untouchable in
- -- any existentials we encounter in the pattern)
-
- , pe_lazy :: Bool -- True <=> lazy context, so no existentials allowed
+ = PE { pe_lazy :: Bool -- True <=> lazy context, so no existentials allowed
, pe_ctxt :: PatCtxt -- Context in which the whole pattern appears
- }
+ }
data PatCtxt
= LamPat -- Used for lambdas, case etc
Lazy patterns can't bind existentials. They arise in two ways:
* Let bindings let { C a b = e } in b
* Twiddle patterns f ~(C a b) = e
-The pe_res_tvs field of PatEnv says whether we are inside a lazy
+The pe_lazy field of PatEnv says whether we are inside a lazy
pattern (perhaps deeply)
If we aren't inside a lazy pattern then we can bind existentials,
| not (isOverloadedTy (idType id))
= do { res <- thing_inside; return (res, emptyTcEvBinds) }
| otherwise
- = do { (res, lie) <- getConstraints thing_inside
+ = do { (res, lie) <- captureConstraints thing_inside
; binds <- bindLocalMethods lie [id]
; return (res, binds) }
-}
-> 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
; res <- tcExtendIdEnv1 name id thing_inside
; return (mkHsWrapPatCoI coi (VarPat id) pat_ty, res) }
-{- Need this if we re-add Method constraints
- ; (res, binds) <- bindInstsOfPatId id $
- tcExtendIdEnv1 name id $
- (traceTc (text "binding" <+> ppr name <+> ppr (idType id))
- >> thing_inside)
- ; let pat' | isEmptyTcEvBinds binds = VarPat id
- | otherwise = VarPatOut id binds
- ; return (mkHsWrapPatCoI coi pat' pat_ty, res) }
--}
-
tc_pat penv (ParPat pat) pat_ty thing_inside
= do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside
; return (ParPat pat', res) }
tc_pat penv lpat@(LazyPat pat) pat_ty thing_inside
= do { (pat', (res, pat_ct))
<- tc_lpat pat pat_ty (makeLazy penv) $
- getConstraints thing_inside
+ captureConstraints thing_inside
-- Ignore refined penv', revert to penv
; emitConstraints pat_ct
- -- getConstraints/extendConstraintss: see Note [Hopping the LIE in lazy patterns]
+ -- captureConstraints/extendConstraints:
+ -- see Note [Hopping the LIE in lazy patterns]
-- Check there are no unlifted types under the lazy pattern
; when (any (isUnLiftedType . idType) $ collectPatBinders pat') $
; res <- tcExtendIdEnv1 name bndr_id thing_inside
; return (mkHsWrapPatCoI coi pat' pat_ty, res) }
-tc_pat _ _other_pat _ _ = panic "tc_pat" -- ConPatOut, SigPatOut, VarPatOut
+tc_pat _ _other_pat _ _ = panic "tc_pat" -- ConPatOut, SigPatOut
----------------
unifyPatType :: TcType -> TcType -> TcM CoercionI
the pattern C!
So we have to make the constraints from thing_inside "hop around"
-the pattern. Hence the getConstraints and emitConstraints.
+the pattern. Hence the captureConstraints and emitConstraints.
The same thing ensures that equality constraints in a lazy match
are not made available in the RHS of the match. For example
; setSrcSpan con_span $ addDataConStupidTheta data_con ctxt_res_tys
; checkExistentials ex_tvs penv
- ; let skol_info = case pe_ctxt penv of
- LamPat mc -> PatSkol data_con mc
- LetPat {} -> UnkSkol -- Doesn't matter
- ; ex_tvs' <- tcInstSkolTyVars skol_info ex_tvs
+ ; ex_tvs' <- tcInstSuperSkolTyVars ex_tvs
-- Get location from monad, not from ex_tvs
; let pat_ty' = mkTyConApp tycon ctxt_res_tys
-- order is *important* as we generate the list of
-- dictionary binders from theta'
no_equalities = not (any isEqPred theta')
-
+ skol_info = case pe_ctxt penv of
+ LamPat mc -> PatSkol data_con mc
+ LetPat {} -> UnkSkol -- Doesn't matter
+
; gadts_on <- xoptM Opt_GADTs
; checkTc (no_equalities || gadts_on)
(ptext (sLit "A pattern match on a GADT requires -XGADTs"))
-- Trac #2905 decided that a *pattern-match* of a GADT
-- should require the GADT language flag
- ; given <- newEvVars theta'
- ; let free_tvs = pe_res_tvs penv
- -- Since we have done checkExistentials,
- -- pe_res_tvs can only be Just at this point
- --
- -- Nor do we need pat_ty, because we've put all the
- -- unification variables in right at the start when
- -- initialising the PatEnv; and the pattern itself
- -- only adds skolems.
-
+ ; given <- newEvVars theta'
; (ev_binds, (arg_pats', res))
- <- checkConstraints skol_info free_tvs ex_tvs' given $
+ <- checkConstraints skol_info ex_tvs' given $
tcConArgs data_con arg_tys' arg_pats penv thing_inside
; let res_pat = ConPatOut { pat_con = L con_span data_con,
-- 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 ()
projects / ghc-hetmet.git / blobdiff