X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcPat.lhs;h=4fe704a84abca4f32842bce3370be85f5cac1312;hb=90dc9026b091be5cca5da4c6cbd3713ecc493361;hp=6cb177ed54044994ed4f878637eb83d368a7a582;hpb=ab22f4e6456820c1b5169d75f5975a94e61f54ce;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index 6cb177e..4fe704a 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 { @@ -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,8 +583,6 @@ 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. -- @@ -794,13 +813,27 @@ 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 ; res_tau <- zapToMonotype res_ty ; new_uniq <- newUnique ; let lit_nm = mkSystemVarName new_uniq FSLIT("lit") - lit_inst = LitInst lit_nm lit res_tau loc + lit_inst = LitInst {tci_name = lit_nm, tci_lit = lit, + tci_ty = res_tau, tci_loc = loc} ; extendLIE lit_inst ; return (HsVar (instToId lit_inst)) } \end{code} @@ -889,7 +922,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) @@ -902,8 +935,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