X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcPat.lhs;h=8304a22ddbe20cdf95fb0fff6824a2543c518ee4;hp=49d0c8ab7c6e36483a23aa212f2c1649bfc763f1;hb=HEAD;hpb=a6f2d598e1e7760d334d1b5ea0b7745e66835e11 diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index 49d0c8a..8304a22 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -6,8 +6,9 @@ TcPat: Typechecking patterns \begin{code} -module TcPat ( tcLetPat, TcSigFun, TcSigInfo(..) - , tcPat, tcPats, newLetBndr +module TcPat ( tcLetPat, TcSigFun, TcSigInfo(..), TcPragFun + , LetBndrSpec(..), addInlinePrags, warnPrags + , tcPat, tcPats, newNoSigLetBndr, newSigLetBndr , addDataConStupidTheta, badFieldCon, polyPatSig ) where #include "HsVersions.h" @@ -31,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 @@ -51,22 +50,20 @@ import Control.Monad %************************************************************************ \begin{code} -tcLetPat :: (Name -> Maybe TcSigInfo) - -> Bool -- True <=> monomorphic +tcLetPat :: TcSigFun -> LetBndrSpec -> LPat Name -> TcSigmaType -> TcM a -> TcM (LPat TcId, a) -tcLetPat sig_fn is_mono pat pat_ty thing_inside +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 - , pe_ctxt = LetPat sig_fn is_mono } + 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 @@ -121,9 +106,16 @@ data PatCtxt | LetPat -- Used only for let(rec) bindings -- See Note [Let binders] - TcSigFun -- Tells type sig if any - Bool -- True <=> no generalisation of this let - + TcSigFun -- Tells type sig if any + LetBndrSpec -- True <=> no generalisation of this let + +data LetBndrSpec + = LetLclBndr -- The binder is just a local one; + -- an AbsBinds will provide the global version + + | LetGblBndr TcPragFun -- There isn't going to be an AbsBinds; + -- here is the inline-pragma information + makeLazy :: PatEnv -> PatEnv makeLazy penv = penv { pe_lazy = True } @@ -132,7 +124,8 @@ patSigCtxt (PE { pe_ctxt = LetPat {} }) = BindPatSigCtxt patSigCtxt (PE { pe_ctxt = LamPat {} }) = LamPatSigCtxt --------------- -type TcSigFun = Name -> Maybe TcSigInfo +type TcPragFun = Name -> [LSig Name] +type TcSigFun = Name -> Maybe TcSigInfo data TcSigInfo = TcSigInfo { @@ -155,7 +148,7 @@ data TcSigInfo instance Outputable TcSigInfo where ppr (TcSigInfo { sig_id = id, sig_tvs = tyvars, sig_theta = theta, sig_tau = tau}) - = ppr id <+> ptext (sLit "::") <+> ppr tyvars <+> pprThetaArrow theta <+> ppr tau + = ppr id <+> ptext (sLit "::") <+> ppr tyvars <+> pprThetaArrowTy theta <+> ppr tau \end{code} Note [sig_tau may be polymorphic] @@ -180,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, @@ -199,36 +192,67 @@ res_ty free vars. %************************************************************************ \begin{code} -tcPatBndr :: PatEnv -> Name -> TcSigmaType -> TcM (CoercionI, TcId) +tcPatBndr :: PatEnv -> Name -> TcSigmaType -> TcM (Coercion, TcId) -- (coi, xp) = tcPatBndr penv x pat_ty -- Then coi : pat_ty ~ typeof(xp) -- tcPatBndr (PE { pe_ctxt = LetPat lookup_sig no_gen}) bndr_name pat_ty | Just sig <- lookup_sig bndr_name - = do { bndr_id <- if no_gen then return (sig_id sig) - else do { mono_name <- newLocalName bndr_name - ; return (Id.mkLocalId mono_name (sig_tau sig)) } + = do { bndr_id <- newSigLetBndr no_gen bndr_name sig ; coi <- unifyPatType (idType bndr_id) pat_ty ; return (coi, bndr_id) } | otherwise - = do { bndr_id <- newLetBndr no_gen bndr_name pat_ty - ; return (IdCo pat_ty, bndr_id) } + = do { bndr_id <- newNoSigLetBndr no_gen bndr_name pat_ty + ; return (mkReflCo pat_ty, bndr_id) } tcPatBndr (PE { pe_ctxt = _lam_or_proc }) bndr_name pat_ty = do { bndr <- mkLocalBinder bndr_name pat_ty - ; return (IdCo pat_ty, bndr) } - -newLetBndr :: Bool -> Name -> TcType -> TcM TcId + ; return (mkReflCo pat_ty, bndr) } + +------------ +newSigLetBndr :: LetBndrSpec -> Name -> TcSigInfo -> TcM TcId +newSigLetBndr LetLclBndr name sig + = do { mono_name <- newLocalName name + ; mkLocalBinder mono_name (sig_tau sig) } +newSigLetBndr (LetGblBndr prags) name sig + = addInlinePrags (sig_id sig) (prags name) + +------------ +newNoSigLetBndr :: LetBndrSpec -> Name -> TcType -> TcM TcId -- In the polymorphic case (no_gen = False), generate a "monomorphic version" -- of the Id; the original name will be bound to the polymorphic version -- by the AbsBinds -- In the monomorphic case there is no AbsBinds, and we use the original -- name directly -newLetBndr no_gen name ty - | no_gen = mkLocalBinder name ty - | otherwise = do { mono_name <- newLocalName name - ; mkLocalBinder mono_name ty } +newNoSigLetBndr LetLclBndr name ty + =do { mono_name <- newLocalName name + ; mkLocalBinder mono_name ty } +newNoSigLetBndr (LetGblBndr prags) name ty + = do { id <- mkLocalBinder name ty + ; addInlinePrags id (prags name) } + +---------- +addInlinePrags :: TcId -> [LSig Name] -> TcM TcId +addInlinePrags poly_id prags + = tc_inl inl_sigs + where + inl_sigs = filter isInlineLSig prags + tc_inl [] = return poly_id + tc_inl (L loc (InlineSig _ prag) : other_inls) + = do { unless (null other_inls) (setSrcSpan loc warn_dup_inline) + ; return (poly_id `setInlinePragma` prag) } + tc_inl _ = panic "tc_inl" + + warn_dup_inline = warnPrags poly_id inl_sigs $ + ptext (sLit "Duplicate INLINE pragmas for") + +warnPrags :: Id -> [LSig Name] -> SDoc -> TcM () +warnPrags id bad_sigs herald + = addWarnTc (hang (herald <+> quotes (ppr id)) + 2 (ppr_sigs bad_sigs)) + where + ppr_sigs sigs = vcat (map (ppr . getLoc) sigs) ----------------- mkLocalBinder :: Name -> TcType -> TcM TcId @@ -255,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) } -} @@ -323,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 @@ -348,17 +372,7 @@ tc_pat :: PatEnv tc_pat penv (VarPat name) pat_ty thing_inside = do { (coi, id) <- tcPatBndr penv name pat_ty ; 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) } --} + ; return (mkHsWrapPatCo coi (VarPat id) pat_ty, res) } tc_pat penv (ParPat pat) pat_ty thing_inside = do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside @@ -371,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') $ @@ -407,7 +422,7 @@ tc_pat penv (AsPat (L nm_loc name) pat) pat_ty thing_inside -- perhaps be fixed, but only with a bit more work. -- -- If you fix it, don't forget the bindInstsOfPatIds! - ; return (mkHsWrapPatCoI coi (AsPat (L nm_loc bndr_id) pat') pat_ty, res) } + ; return (mkHsWrapPatCo coi (AsPat (L nm_loc bndr_id) pat') pat_ty, res) } tc_pat penv vpat@(ViewPat expr pat _) overall_pat_ty thing_inside = do { checkUnboxedTuple overall_pat_ty $ @@ -432,7 +447,7 @@ tc_pat penv vpat@(ViewPat expr pat _) overall_pat_ty thing_inside -- pattern must have pat_ty ; (pat', res) <- tc_lpat pat pat_ty penv thing_inside - ; return (ViewPat (mkLHsWrapCoI expr_coi expr') pat' overall_pat_ty, res) } + ; return (ViewPat (mkLHsWrapCo expr_coi expr') pat' overall_pat_ty, res) } -- Type signatures in patterns -- See Note [Pattern coercions] below @@ -443,9 +458,6 @@ tc_pat penv (SigPatIn pat sig_ty) pat_ty thing_inside ; 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 @@ -495,7 +507,7 @@ tc_pat _ (LitPat simple_lit) pat_ty thing_inside ; coi <- unifyPatType lit_ty pat_ty -- coi is of kind: pat_ty ~ lit_ty ; res <- thing_inside - ; return ( mkHsWrapPatCoI coi (LitPat simple_lit) pat_ty + ; return ( mkHsWrapPatCo coi (LitPat simple_lit) pat_ty , res) } ------------------------ @@ -530,19 +542,19 @@ tc_pat penv (NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside ; instStupidTheta orig [mkClassPred icls [pat_ty']] ; res <- tcExtendIdEnv1 name bndr_id thing_inside - ; return (mkHsWrapPatCoI coi pat' pat_ty, res) } + ; return (mkHsWrapPatCo 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 +unifyPatType :: TcType -> TcType -> TcM Coercion -- In patterns we want a coercion from the -- context type (expected) to the actual pattern type -- But we don't want to reverse the args to unifyType because -- that controls the actual/expected stuff in error messages unifyPatType actual_ty expected_ty = do { coi <- unifyType actual_ty expected_ty - ; return (mkSymCoI coi) } + ; return (mkSymCo coi) } \end{code} Note [Hopping the LIE in lazy patterns] @@ -554,7 +566,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 @@ -641,7 +653,7 @@ tcConPat penv (L con_span con_name) pat_ty arg_pats thing_inside = do { data_con <- tcLookupDataCon con_name ; let tycon = dataConTyCon data_con -- For data families this is the representation tycon - (univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _) + (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con -- Instantiate the constructor type variables [a->ty] @@ -653,10 +665,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 @@ -666,9 +675,8 @@ tcConPat penv (L con_span con_name) pat_ty arg_pats thing_inside tenv = zipTopTvSubst (univ_tvs ++ ex_tvs) (ctxt_res_tys ++ mkTyVarTys ex_tvs') arg_tys' = substTys tenv arg_tys - full_theta = eq_theta ++ dict_theta - ; if null ex_tvs && null eq_spec && null full_theta + ; if null ex_tvs && null eq_spec && null theta then do { -- The common case; no class bindings etc -- (see Note [Arrows and patterns]) (arg_pats', res) <- tcConArgs data_con arg_tys' @@ -683,30 +691,23 @@ tcConPat penv (L con_span con_name) pat_ty arg_pats 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 ++ full_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') - + 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, @@ -719,21 +720,21 @@ tcConPat penv (L con_span con_name) pat_ty arg_pats thing_inside } } ---------------------------- -matchExpectedPatTy :: (TcRhoType -> TcM (CoercionI, a)) +matchExpectedPatTy :: (TcRhoType -> TcM (Coercion, a)) -> TcRhoType -> TcM (HsWrapper, a) -- See Note [Matching polytyped patterns] -- Returns a wrapper : pat_ty ~ inner_ty matchExpectedPatTy inner_match pat_ty | null tvs && null theta = do { (coi, res) <- inner_match pat_ty - ; return (coiToHsWrapper (mkSymCoI coi), res) } + ; return (coToHsWrapper (mkSymCo coi), res) } -- The Sym is because the inner_match returns a coercion -- that is the other way round to matchExpectedPatTy | otherwise = do { (_, tys, subst) <- tcInstTyVars tvs ; wrap1 <- instCall PatOrigin tys (substTheta subst theta) - ; (wrap2, arg_tys) <- matchExpectedPatTy inner_match (substTy subst tau) + ; (wrap2, arg_tys) <- matchExpectedPatTy inner_match (TcType.substTy subst tau) ; return (wrap2 <.> wrap1 , arg_tys) } where (tvs, theta, tau) = tcSplitSigmaTy pat_ty @@ -742,7 +743,7 @@ matchExpectedPatTy inner_match pat_ty matchExpectedConTy :: TyCon -- The TyCon that this data -- constructor actually returns -> TcRhoType -- The type of the pattern - -> TcM (CoercionI, [TcSigmaType]) + -> TcM (Coercion, [TcSigmaType]) -- See Note [Matching constructor patterns] -- Returns a coercion : T ty1 ... tyn ~ pat_ty -- This is the same way round as matchExpectedListTy etc @@ -757,17 +758,16 @@ matchExpectedConTy data_tc pat_ty ; coi1 <- unifyType (mkTyConApp fam_tc (substTys subst fam_args)) pat_ty -- coi1 : T (ty1,ty2) ~ pat_ty - ; let coi2 = ACo (mkTyConApp co_tc tys) + ; let coi2 = mkAxInstCo co_tc tys -- coi2 : T (ty1,ty2) ~ T7 ty1 ty2 - ; return (mkTransCoI (mkSymCoI coi2) coi1, tys) } + ; return (mkTransCo (mkSymCo coi2) coi1, tys) } | otherwise = matchExpectedTyConApp data_tc pat_ty -- coi : T tys ~ pat_ty \end{code} -Noate [ Note [Matching constructor patterns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose (coi, tys) = matchExpectedConType data_tc pat_ty @@ -999,12 +999,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 () @@ -1040,9 +1046,6 @@ polyPatSig sig_ty = 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 $