X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcPat.lhs;h=9d4c9b0c1187ecdd1392ccaa003ac9838c651959;hb=940524aec90652b5ef81789c9a453c57c0e42cc9;hp=e1a1f242040a43f0bf5e6852ee0df643d27278e4;hpb=32722dc3f6466f01698f7a42298a8acedd4059c2;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index e1a1f24..9d4c9b0 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -132,7 +132,7 @@ tcCheckExistentialPat pats [] pat_tys body_ty = return () -- Short cut for case when there are no existentials tcCheckExistentialPat pats ex_tvs pat_tys body_ty - = addErrCtxtM (sigPatCtxt (collectPatsBinders pats) ex_tvs pat_tys body_ty) $ + = addErrCtxtM (sigPatCtxt pats ex_tvs pat_tys body_ty) $ checkSigTyVarsWrt (tcTyVarsOfTypes (body_ty:pat_tys)) ex_tvs data PatState = PS { @@ -228,7 +228,7 @@ unBoxArgType ty pp_this Note [Nesting] ~~~~~~~~~~~~~~ -tcPat takes a "thing inside" over which the patter scopes. This is partly +tcPat takes a "thing inside" over which the pattern scopes. This is partly so that tcPat can extend the environment for the thing_inside, but also so that constraints arising in the thing_inside can be discharged by the pattern. @@ -279,7 +279,9 @@ tc_lpat :: LPat Name tc_lpat (L span pat) pat_ty pstate thing_inside = setSrcSpan span $ maybeAddErrCtxt (patCtxt pat) $ - do { let (coercion, pat_ty') = refineType (pat_reft pstate) pat_ty + do { let mb_reft = refineType (pat_reft pstate) pat_ty + pat_ty' = case mb_reft of { Just (_, ty') -> ty'; Nothing -> pat_ty } + -- Make sure the result type reflects the current refinement -- We must do this here, so that it correctly ``sees'' all -- the refinements to the left. Example: @@ -289,7 +291,10 @@ tc_lpat (L span pat) pat_ty pstate thing_inside -- pattern had better see it. ; (pat', tvs, res) <- tc_pat pstate pat pat_ty' thing_inside - ; return (mkCoPat coercion (L span pat') pat_ty, tvs, res) } + ; let final_pat = case mb_reft of + Nothing -> pat' + Just (co,_) -> CoPat (WpCo co) pat' pat_ty + ; return (L span final_pat, tvs, res) } -------------------- tc_pat :: PatState @@ -327,11 +332,26 @@ tc_pat pstate (BangPat pat) pat_ty thing_inside -- -- Nor should a lazy pattern bind any existential type variables -- because they won't be in scope when we do the desugaring +-- +-- Note [Hopping the LIE in lazy patterns] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- In a lazy pattern, we must *not* discharge constraints from the RHS +-- from dictionaries bound in the pattern. E.g. +-- f ~(C x) = 3 +-- 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 getLLE and extendLIEs later. + tc_pat pstate lpat@(LazyPat pat) pat_ty thing_inside - = do { (pat', pat_tvs, res) <- tc_lpat pat pat_ty pstate $ \ _ -> - thing_inside pstate - -- Ignore refined pstate', - -- revert to pstate + = do { (pat', pat_tvs, (res,lie)) + <- tc_lpat pat pat_ty pstate $ \ _ -> + getLIE (thing_inside pstate) + -- Ignore refined pstate', revert to pstate + ; extendLIEs lie + -- getLIE/extendLIEs: see Note [Hopping the LIE in lazy patterns] + -- Check no existentials ; if (null pat_tvs) then return () else lazyPatErr lpat pat_tvs @@ -526,16 +546,16 @@ tcConPat :: PatState -> SrcSpan -> DataCon -> TyCon -> HsConDetails Name (LPat Name) -> (PatState -> TcM a) -> TcM (Pat TcId, [TcTyVar], a) tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside - = do { span <- getSrcSpanM -- Span for the whole pattern - ; let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys) = dataConFullSig data_con - skol_info = PatSkol data_con span + = do { let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con + skol_info = PatSkol data_con origin = SigOrigin skol_info -- Instantiate the constructor type variables [a->ty] ; ctxt_res_tys <- boxySplitTyConAppWithFamily tycon pat_ty - ; ex_tvs' <- tcInstSkolTyVars skol_info ex_tvs + ; ex_tvs' <- tcInstSkolTyVars skol_info ex_tvs -- Get location from monad, + -- not from ex_tvs ; let tenv = zipTopTvSubst (univ_tvs ++ ex_tvs) - (ctxt_res_tys ++ mkTyVarTys ex_tvs') + (ctxt_res_tys ++ mkTyVarTys ex_tvs') eq_spec' = substEqSpec tenv eq_spec theta' = substTheta tenv theta arg_tys' = substTys tenv arg_tys @@ -548,7 +568,8 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside ; loc <- getInstLoc origin ; dicts <- newDictBndrs loc theta' - ; dict_binds <- tcSimplifyCheck doc ex_tvs' dicts lie_req + ; dict_binds <- tcSimplifyCheckPat loc co_vars (pat_reft pstate') + ex_tvs' dicts lie_req ; addDataConStupidTheta data_con ctxt_res_tys @@ -562,11 +583,8 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside ex_tvs' ++ inner_tvs, res) } where - doc = ptext SLIT("existential context for") <+> quotes (ppr data_con) - - -- Split against the family tycon if the pattern constructor belongs to a - -- representation tycon. - -- + -- Split against the family tycon if the pattern constructor + -- belongs to a family instance tycon. boxySplitTyConAppWithFamily tycon pat_ty = traceTc traceMsg >> case tyConFamInst_maybe tycon of @@ -794,6 +812,19 @@ tcOverloadedLit orig lit@(HsFractional r fr) res_ty = do { expr <- newLitInst orig lit res_ty ; return (HsFractional r expr) } +tcOverloadedLit orig lit@(HsIsString s fr) res_ty + | not (fr `isHsVar` fromStringName) -- c.f. HsIntegral case + = do { str_ty <- tcMetaTy stringTyConName + ; fr' <- tcSyntaxOp orig fr (mkFunTy str_ty res_ty) + ; return (HsIsString s (HsApp (noLoc fr') (nlHsLit (HsString s)))) } + + | Just expr <- shortCutStringLit s res_ty + = return (HsIsString s expr) + + | otherwise + = do { expr <- newLitInst orig lit res_ty + ; return (HsIsString s expr) } + newLitInst :: InstOrigin -> HsOverLit Name -> BoxyRhoType -> TcM (HsExpr TcId) newLitInst orig lit res_ty -- Make a LitInst = do { loc <- getInstLoc orig @@ -890,7 +921,7 @@ existentialExplode pat text "In the binding group for"]) 4 (ppr pat) -sigPatCtxt bound_ids bound_tvs pat_tys body_ty tidy_env +sigPatCtxt pats bound_tvs pat_tys body_ty tidy_env = do { pat_tys' <- mapM zonkTcType pat_tys ; body_ty' <- zonkTcType body_ty ; let (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids) @@ -903,8 +934,9 @@ sigPatCtxt bound_ids bound_tvs pat_tys body_ty tidy_env ptext SLIT("The body has type:") <+> ppr tidy_body_ty ]) } where + bound_ids = collectPatsBinders pats show_ids = filter is_interesting bound_ids - is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs + is_interesting id = any (`elemVarSet` varTypeTyVars id) bound_tvs ppr_id id ty = ppr id <+> dcolon <+> ppr ty -- Don't zonk the types so we get the separate, un-unified versions