X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcPat.lhs;h=39594f0d47fc86bdf5f72800c4e89c4cca48ac5d;hp=1e391de4ddc267cc22ca8fbb32e3be8bc6ea712a;hb=3bb700d515de2405fa5db3326482e529f332d508;hpb=edeee10702955ca3c53444f2f328b4cce0ab3e32 diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index 1e391de..39594f0 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -32,12 +32,10 @@ import Coercion 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 @@ -59,14 +57,13 @@ tcLetPat :: TcSigFun -> LetBndrSpec 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) @@ -81,39 +78,27 @@ tcPats :: HsMatchContext Name -- 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 @@ -188,7 +173,7 @@ Note [Existential check] 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, @@ -294,7 +279,7 @@ bindInstsOfPatId id thing_inside | 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) } -} @@ -362,9 +347,9 @@ tc_lpat :: LPat Name -> 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 @@ -389,16 +374,6 @@ tc_pat penv (VarPat name) pat_ty thing_inside ; 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) } @@ -410,11 +385,12 @@ tc_pat penv (BangPat pat) pat_ty thing_inside 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') $ @@ -571,7 +547,7 @@ tc_pat penv (NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside ; 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 @@ -593,7 +569,7 @@ We can't discharge the Num constraint from dictionaries bound by 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 @@ -692,10 +668,7 @@ tcConPat penv (L con_span con_name) pat_ty arg_pats thing_inside ; 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 @@ -727,25 +700,19 @@ tcConPat penv (L con_span con_name) pat_ty arg_pats thing_inside -- 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, @@ -806,7 +773,6 @@ matchExpectedConTy data_tc pat_ty -- coi : T tys ~ pat_ty \end{code} -Noate [ Note [Matching constructor patterns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose (coi, tys) = matchExpectedConType data_tc pat_ty @@ -1038,12 +1004,18 @@ sigPatCtxt pats bound_tvs pat_tys body_ty tidy_env -} \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 ()