X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcPat.lhs;h=f64dcb25cd3bfc1717b57110cf2ac227757aae0b;hb=d107207d57f6102f580578e7c168b7317b04b9c4;hp=a5dd0012bbe9a9171c6276cf18451249109ec305;hpb=4226903dd2bd0a08e1b7e10547a57588e8371e78;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index a5dd001..f64dcb2 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -36,7 +36,6 @@ import VarSet import TcUnify import TcHsType import TysWiredIn -import TcGadt import Type import Coercion import StaticFlags @@ -120,10 +119,11 @@ tc_lam_pats :: PatCtxt tc_lam_pats ctxt pat_ty_prs res_ty thing_inside = do { let init_state = PS { pat_ctxt = ctxt, pat_eqs = False } - ; (pats', ex_tvs, res) <- tcMultiple tc_lpat_pr pat_ty_prs init_state $ \ pstate' -> - if (pat_eqs pstate' && (not $ isRigidTy res_ty)) - then failWithTc (nonRigidResult res_ty) - else thing_inside res_ty + ; (pats', ex_tvs, res) <- do { traceTc (text "tc_lam_pats" <+> (ppr pat_ty_prs $$ ppr res_ty)) + ; tcMultiple tc_lpat_pr pat_ty_prs init_state $ \ pstate' -> + if (pat_eqs pstate' && (not $ isRigidTy res_ty)) + then nonRigidResult res_ty + else thing_inside res_ty } ; let tys = map snd pat_ty_prs ; tcCheckExistentialPat pats' ex_tvs tys res_ty @@ -153,8 +153,9 @@ tcCheckExistentialPat pats ex_tvs pat_tys body_ty data PatState = PS { pat_ctxt :: PatCtxt, - pat_eqs :: Bool -- <=> there are GADT equational constraints - -- for refinement + pat_eqs :: Bool -- <=> there are any equational constraints + -- Used at the end to say whether the result + -- type must be rigid } data PatCtxt @@ -213,9 +214,9 @@ bindInstsOfPatId id thing_inside ; return (res, binds) } ------------------- -unBoxPatBndrType ty name = unBoxArgType ty (ptext SLIT("The variable") <+> quotes (ppr name)) -unBoxWildCardType ty = unBoxArgType ty (ptext SLIT("A wild-card pattern")) -unBoxViewPatType ty pat = unBoxArgType ty (ptext SLIT("The view pattern") <+> ppr pat) +unBoxPatBndrType ty name = unBoxArgType ty (ptext (sLit "The variable") <+> quotes (ppr name)) +unBoxWildCardType ty = unBoxArgType ty (ptext (sLit "A wild-card pattern")) +unBoxViewPatType ty pat = unBoxArgType ty (ptext (sLit "The view pattern") <+> ppr pat) unBoxArgType :: BoxyType -> SDoc -> TcM TcType -- In addition to calling unbox, unBoxArgType ensures that the type is of ArgTypeKind; @@ -236,7 +237,7 @@ unBoxArgType ty pp_this ; unifyType ty' ty2 ; return ty' }} where - msg = pp_this <+> ptext SLIT("cannot be bound to an unboxed tuple") + msg = pp_this <+> ptext (sLit "cannot be bound to an unboxed tuple") \end{code} @@ -646,12 +647,7 @@ tcConPat pstate con_span data_con tycon 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) - -- order is *important* as we generate the list of - -- dictionary binders from theta' - ctxt = pat_ctxt pstate - ; checkTc (case ctxt of { ProcPat -> False; other -> True }) + { checkTc (case pat_ctxt pstate of { ProcPat -> False; other -> True }) (existentialProcPat data_con) -- Need to test for rigidity if *any* constraints in theta as class @@ -662,15 +658,23 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside -- FIXME: AT THE MOMENT WE CHEAT! We only perform the rigidity test -- if we explicit or implicit (by a GADT def) have equality -- constraints. - ; unless (all (not . isEqPred) theta') $ - checkTc (isRigidTy pat_ty) (nonRigidMatch data_con) + ; let eq_preds = [mkEqPred (mkTyVarTy tv, ty) | (tv, ty) <- eq_spec] + theta' = substTheta tenv (eq_preds ++ full_theta) + -- order is *important* as we generate the list of + -- dictionary binders from theta' + no_equalities = not (any isEqPred theta') + pstate' | no_equalities = pstate + | otherwise = pstate { pat_eqs = True } + + ; unless no_equalities (checkTc (isRigidTy pat_ty) + (nonRigidMatch data_con)) ; ((arg_pats', inner_tvs, res), lie_req) <- getLIE $ - tcConArgs data_con arg_tys' arg_pats pstate thing_inside + tcConArgs data_con arg_tys' arg_pats pstate' thing_inside ; loc <- getInstLoc origin ; dicts <- newDictBndrs loc theta' - ; dict_binds <- tcSimplifyCheckPat loc [] ex_tvs' dicts lie_req + ; dict_binds <- tcSimplifyCheckPat loc ex_tvs' dicts lie_req ; let res_pat = ConPatOut { pat_con = L con_span data_con, pat_tvs = ex_tvs', @@ -710,7 +714,7 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside -- NB: We can use CoPat directly, rather than mkCoPat, as we know the -- coercion is not the identity; mkCoPat is inconvenient as it -- wants a located pattern. - = CoPat (WpCo $ mkTyConApp co_con args) -- co fam ty to repr ty + = CoPat (WpCast $ mkTyConApp co_con args) -- co fam ty to repr ty (pat {pat_ty = mkTyConApp tycon args}) -- representation type pat_ty -- family inst type | otherwise @@ -844,63 +848,37 @@ tcOverloadedLit :: InstOrigin -> HsOverLit Name -> BoxyRhoType -> TcM (HsOverLit TcId) -tcOverloadedLit orig lit@(HsIntegral i fi _) res_ty - | not (fi `isHsVar` fromIntegerName) -- Do not generate a LitInst for rebindable syntax. +tcOverloadedLit orig lit@(OverLit { ol_val = val, ol_rebindable = rebindable + , ol_witness = meth_name }) res_ty + | rebindable + -- Do not generate a LitInst for rebindable syntax. -- Reason: If we do, tcSimplify will call lookupInst, which -- will call tcSyntaxName, which does unification, -- which tcSimplify doesn't like -- ToDo: noLoc sadness - = do { integer_ty <- tcMetaTy integerTyConName - ; fi' <- tcSyntaxOp orig fi (mkFunTy integer_ty res_ty) - ; return (HsIntegral i (HsApp (noLoc fi') (nlHsLit (HsInteger i integer_ty))) res_ty) } - - | Just expr <- shortCutIntLit i res_ty - = return (HsIntegral i expr res_ty) - - | otherwise - = do { expr <- newLitInst orig lit res_ty - ; return (HsIntegral i expr res_ty) } - -tcOverloadedLit orig lit@(HsFractional r fr _) res_ty - | not (fr `isHsVar` fromRationalName) -- c.f. HsIntegral case - = do { rat_ty <- tcMetaTy rationalTyConName - ; fr' <- tcSyntaxOp orig fr (mkFunTy rat_ty res_ty) + = do { hs_lit <- mkOverLit val + ; let lit_ty = hsLitType hs_lit + ; fi' <- tcSyntaxOp orig meth_name (mkFunTy lit_ty res_ty) -- Overloaded literals must have liftedTypeKind, because -- we're instantiating an overloaded function here, -- whereas res_ty might be openTypeKind. This was a bug in 6.2.2 -- However this'll be picked up by tcSyntaxOp if necessary - ; return (HsFractional r (HsApp (noLoc fr') (nlHsLit (HsRat r rat_ty))) res_ty) } - - | Just expr <- shortCutFracLit r res_ty - = return (HsFractional r expr res_ty) + ; let witness = HsApp (noLoc fi') (noLoc (HsLit hs_lit)) + ; return (lit { ol_witness = witness, ol_type = res_ty }) } - | otherwise - = do { expr <- newLitInst orig lit res_ty - ; return (HsFractional r expr res_ty) } - -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))) res_ty) } - - | Just expr <- shortCutStringLit s res_ty - = return (HsIsString s expr res_ty) + | Just expr <- shortCutLit val res_ty + = return (lit { ol_witness = expr, ol_type = res_ty }) | otherwise - = do { expr <- newLitInst orig lit res_ty - ; return (HsIsString s expr res_ty) } - -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") + ; let lit_nm = mkSystemVarName new_uniq (fsLit "lit") lit_inst = LitInst {tci_name = lit_nm, tci_lit = lit, tci_ty = res_tau, tci_loc = loc} + witness = HsVar (instToId lit_inst) ; extendLIE lit_inst - ; return (HsVar (instToId lit_inst)) } + ; return (lit { ol_witness = witness, ol_type = res_ty }) } \end{code} @@ -976,7 +954,7 @@ patCtxt :: Pat Name -> Maybe Message -- Not all patterns are worth pushing a con patCtxt (VarPat _) = Nothing patCtxt (ParPat _) = Nothing patCtxt (AsPat _ _) = Nothing -patCtxt pat = Just (hang (ptext SLIT("In the pattern:")) +patCtxt pat = Just (hang (ptext (sLit "In the pattern:")) 4 (ppr pat)) ----------------------------------------------- @@ -995,10 +973,10 @@ sigPatCtxt pats bound_tvs pat_tys body_ty tidy_env (env2, tidy_pat_tys) = tidyOpenTypes env1 pat_tys' (env3, tidy_body_ty) = tidyOpenType env2 body_ty' ; return (env3, - sep [ptext SLIT("When checking an existential match that binds"), + sep [ptext (sLit "When checking an existential match that binds"), nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)), - ptext SLIT("The pattern(s) have type(s):") <+> vcat (map ppr tidy_pat_tys), - ptext SLIT("The body has type:") <+> ppr tidy_body_ty + ptext (sLit "The pattern(s) have type(s):") <+> vcat (map ppr tidy_pat_tys), + ptext (sLit "The body has type:") <+> ppr tidy_body_ty ]) } where bound_ids = collectPatsBinders pats @@ -1010,34 +988,38 @@ sigPatCtxt pats bound_tvs pat_tys body_ty tidy_env badFieldCon :: DataCon -> Name -> SDoc badFieldCon con field - = hsep [ptext SLIT("Constructor") <+> quotes (ppr con), - ptext SLIT("does not have field"), quotes (ppr field)] + = hsep [ptext (sLit "Constructor") <+> quotes (ppr con), + ptext (sLit "does not have field"), quotes (ppr field)] polyPatSig :: TcType -> SDoc polyPatSig sig_ty - = hang (ptext SLIT("Illegal polymorphic type signature in pattern:")) + = hang (ptext (sLit "Illegal polymorphic type signature in pattern:")) 2 (ppr sig_ty) -badTypePat pat = ptext SLIT("Illegal type pattern") <+> ppr pat +badTypePat pat = ptext (sLit "Illegal type pattern") <+> ppr pat existentialProcPat :: DataCon -> SDoc existentialProcPat con - = hang (ptext SLIT("Illegal constructor") <+> quotes (ppr con) <+> ptext SLIT("in a 'proc' pattern")) - 2 (ptext SLIT("Proc patterns cannot use existentials or GADTs")) + = hang (ptext (sLit "Illegal constructor") <+> quotes (ppr con) <+> ptext (sLit "in a 'proc' pattern")) + 2 (ptext (sLit "Proc patterns cannot use existentials or GADTs")) lazyPatErr pat tvs = failWithTc $ - hang (ptext SLIT("A lazy (~) pattern cannot bind existential type variables")) + hang (ptext (sLit "A lazy (~) pattern cannot bind existential type variables")) 2 (vcat (map pprSkolTvBinding tvs)) nonRigidMatch con - = hang (ptext SLIT("GADT pattern match in non-rigid context for") <+> quotes (ppr con)) - 2 (ptext SLIT("Solution: add a type signature")) + = hang (ptext (sLit "GADT pattern match in non-rigid context for") <+> quotes (ppr con)) + 2 (ptext (sLit "Solution: add a type signature")) nonRigidResult res_ty - = hang (ptext SLIT("GADT pattern match with non-rigid result type") <+> quotes (ppr res_ty)) - 2 (ptext SLIT("Solution: add a type signature")) + = do { env0 <- tcInitTidyEnv + ; let (env1, res_ty') = tidyOpenType env0 res_ty + msg = hang (ptext (sLit "GADT pattern match with non-rigid result type") + <+> quotes (ppr res_ty')) + 2 (ptext (sLit "Solution: add a type signature")) + ; failWithTcM (env1, msg) } inaccessibleAlt msg - = hang (ptext SLIT("Inaccessible case alternative:")) 2 msg + = hang (ptext (sLit "Inaccessible case alternative:")) 2 msg \end{code}