From: Simon Peyton Jones Date: Mon, 2 May 2011 09:25:36 +0000 (+0100) Subject: Merge in changes from HEAD X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=db4f42a8e38bfead11f5af78557e18b9f42b10b3 Merge in changes from HEAD --- db4f42a8e38bfead11f5af78557e18b9f42b10b3 diff --cc compiler/typecheck/TcDeriv.lhs index 195eb99,1798be3..72b99c5 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@@ -1294,10 -1294,10 +1294,10 @@@ inferInstanceContexts oflag infer_spec ; let tv_set = mkVarSet tyvars weird_preds = [pred | pred <- deriv_rhs - , not (tyVarsOfPred pred `subVarSet` tv_set)] + , not (tyVarsOfPred pred `subVarSet` tv_set)] ; mapM_ (addErrTc . badDerivedPred) weird_preds - ; theta <- simplifyDeriv orig tyvars deriv_rhs + ; theta <- simplifyDeriv orig the_pred tyvars deriv_rhs -- checkValidInstance tyvars theta clas inst_tys -- Not necessary; see Note [Exotic derived instance contexts] -- in TcSimplify diff --cc compiler/types/OptCoercion.lhs index c955712,26f3295..559ea65 --- a/compiler/types/OptCoercion.lhs +++ b/compiler/types/OptCoercion.lhs @@@ -85,89 -82,123 +85,92 @@@ opt_co env sym c (text "input=" <+> ppr co) $$ (text "simple=" <+> ppr simple_result) $$ (text "opt=" <+> ppr co1) ) - co1 + co1) where co1 = opt_co' env sym co - same_co_kind = s1 `coreEqType` s2 && t1 `coreEqType` t2 - (s,t) = coercionKind (substTy env co) + same_co_kind = s1 `eqType` s2 && t1 `eqType` t2 + Pair s t = coercionKind (substCo env co) (s1,t1) | sym = (t,s) | otherwise = (s,t) - (s2,t2) = coercionKind co1 + Pair s2 t2 = coercionKind co1 - simple_result | sym = mkSymCoercion (substTy env co) - | otherwise = substTy env co + simple_result | sym = mkSymCo (substCo env co) + | otherwise = substCo env co -} -opt_co' env sym (AppTy ty1 ty2) = mkAppTy (opt_co env sym ty1) (opt_co env sym ty2) -opt_co' env sym (FunTy ty1 ty2) = FunTy (opt_co env sym ty1) (opt_co env sym ty2) -opt_co' env sym (PredTy (ClassP cls tys)) = PredTy (ClassP cls (map (opt_co env sym) tys)) -opt_co' env sym (PredTy (IParam n ty)) = PredTy (IParam n (opt_co env sym ty)) -opt_co' _ _ co@(PredTy (EqPred {})) = pprPanic "optCoercion" (ppr co) - -opt_co' env sym co@(TyVarTy tv) - | Just ty <- lookupTyVar env tv = opt_co' (zapTvSubstEnv env) sym ty - | not (isCoVar tv) = co -- Identity; does not mention a CoVar - | ty1 `coreEqType` ty2 = ty1 -- Identity; ..ditto.. - | not sym = co - | otherwise = mkSymCoercion co +opt_co' env _ (Refl ty) = Refl (substTy env ty) +opt_co' env sym (SymCo co) = opt_co env (not sym) co - opt_co' env sym (TyConAppCo tc cos) = TyConAppCo tc (map (opt_co env sym) cos) ++ ++opt_co' env sym (TyConAppCo tc cos) = mkTyConAppCo tc (map (opt_co env sym) cos) +opt_co' env sym (AppCo co1 co2) = mkAppCo (opt_co env sym co1) (opt_co env sym co2) +opt_co' env sym (ForAllCo tv co) = case substTyVarBndr env tv of - (env', tv') -> ForAllCo tv' (opt_co env' sym co) ++ (env', tv') -> mkForAllCo tv' (opt_co env' sym co) ++ -- Use the "mk" functions to check for nested Refls ++ +opt_co' env sym (CoVarCo cv) + | Just co <- lookupCoVar env cv + = opt_co (zapCvSubstEnv env) sym co + + | Just cv1 <- lookupInScope (getCvInScope env) cv + = ASSERT( isCoVar cv1 ) wrapSym sym (CoVarCo cv1) + -- cv1 might have a substituted kind! + + | otherwise = WARN( True, ptext (sLit "opt_co: not in scope:") <+> ppr cv $$ ppr env) + ASSERT( isCoVar cv ) + wrapSym sym (CoVarCo cv) + +opt_co' env sym (AxiomInstCo con cos) + -- Do *not* push sym inside top-level axioms + -- e.g. if g is a top-level axiom + -- g a : f a ~ a + -- then (sym (g ty)) /= g (sym ty) !! + = wrapSym sym $ AxiomInstCo con (map (opt_co env False) cos) + -- Note that the_co does *not* have sym pushed into it + +opt_co' env sym (UnsafeCo ty1 ty2) + | ty1' `eqType` ty2' = Refl ty1' + | sym = mkUnsafeCo ty2' ty1' + | otherwise = mkUnsafeCo ty1' ty2' where - (ty1,ty2) = coVarKind tv - -opt_co' env sym (ForAllTy tv cor) - | isTyVar tv = case substTyVarBndr env tv of - (env', tv') -> ForAllTy tv' (opt_co' env' sym cor) + ty1' = substTy env ty1 + ty2' = substTy env ty2 -opt_co' env sym co@(ForAllTy co_var cor) - | isCoVar co_var - = WARN( co_var `elemVarSet` tyVarsOfType cor, ppr co ) - ForAllTy co_var' cor' +opt_co' env sym (TransCo co1 co2) + | sym = opt_trans opt_co2 opt_co1 -- sym (g `o` h) = sym h `o` sym g + | otherwise = opt_trans opt_co1 opt_co2 where - (co1,co2) = coVarKind co_var - co1' = opt_co' env sym co1 - co2' = opt_co' env sym co2 - cor' = opt_co' env sym cor - co_var' = uniqAway (getTvInScope env) (mkWildCoVar (mkCoKind co1' co2')) - -- See Note [Subtle shadowing in coercions] - -opt_co' env sym (TyConApp tc cos) - | Just (arity, desc) <- isCoercionTyCon_maybe tc - = mkAppTys (opt_co_tc_app env sym tc desc (take arity cos)) - (map (opt_co env sym) (drop arity cos)) - | otherwise - = TyConApp tc (map (opt_co env sym) cos) - --------- -opt_co_tc_app :: TvSubst -> Bool -> TyCon -> CoTyConDesc -> [Coercion] -> NormalCo --- Used for CoercionTyCons only --- Arguments are *not* already simplified/substituted -opt_co_tc_app env sym tc desc cos - = case desc of - CoAxiom {} -- Do *not* push sym inside top-level axioms - -- e.g. if g is a top-level axiom - -- g a : F a ~ a - -- Then (sym (g ty)) /= g (sym ty) !! - | sym -> mkSymCoercion the_co - | otherwise -> the_co - where - the_co = TyConApp tc (map (opt_co env False) cos) - -- Note that the_co does *not* have sym pushed into it - - CoTrans - | sym -> opt_trans opt_co2 opt_co1 -- sym (g `o` h) = sym h `o` sym g - | otherwise -> opt_trans opt_co1 opt_co2 - - CoUnsafe - | sym -> mkUnsafeCoercion ty2' ty1' - | otherwise -> mkUnsafeCoercion ty1' ty2' - - CoSym -> opt_co env (not sym) co1 - CoLeft -> opt_lr fst - CoRight -> opt_lr snd - CoCsel1 -> opt_csel fstOf3 - CoCsel2 -> opt_csel sndOf3 - CoCselR -> opt_csel thirdOf3 - - CoInst -- See if the first arg is already a forall - -- ...then we can just extend the current substitution - | Just (tv, co1_body) <- splitForAllTy_maybe co1 - -> opt_co (extendTvSubst env tv ty2') sym co1_body - - -- See if is *now* a forall - | Just (tv, opt_co1_body) <- splitForAllTy_maybe opt_co1 - -> substTyWith [tv] [ty2'] opt_co1_body -- An inefficient one-variable substitution - - | otherwise - -> TyConApp tc [opt_co1, ty2'] + opt_co1 = opt_co env sym co1 + opt_co2 = opt_co env sym co2 +opt_co' env sym (NthCo n co) + | TyConAppCo tc cos <- co' + , isDecomposableTyCon tc -- Not synonym families + = ASSERT( n < length cos ) + cos !! n + | otherwise + = NthCo n co' where - (co1 : cos1) = cos - (co2 : _) = cos1 + co' = opt_co env sym co - ty1' = substTy env co1 - ty2' = substTy env co2 +opt_co' env sym (InstCo co ty) + -- See if the first arg is already a forall + -- ...then we can just extend the current substitution + | Just (tv, co_body) <- splitForAllCo_maybe co + = opt_co (extendTvSubst env tv ty') sym co_body - -- These opt_cos have the sym pushed into them - opt_co1 = opt_co env sym co1 - opt_co2 = opt_co env sym co2 + -- See if it is a forall after optimization + | Just (tv, co'_body) <- splitForAllCo_maybe co' + = substCoWithTy tv ty' co'_body -- An inefficient one-variable substitution - the_unary_opt_co = TyConApp tc [opt_co1] + | otherwise = InstCo co' ty' - opt_lr sel = case splitAppTy_maybe opt_co1 of - Nothing -> the_unary_opt_co - Just lr -> sel lr - opt_csel sel = case splitCoPredTy_maybe opt_co1 of - Nothing -> the_unary_opt_co - Just lr -> sel lr + where + co' = opt_co env sym co + ty' = substTy env ty ------------- -opt_transL :: [NormalCo] -> [NormalCo] -> [NormalCo] -opt_transL = zipWith opt_trans +opt_transList :: [NormalCo] -> [NormalCo] -> [NormalCo] +opt_transList = zipWith opt_trans opt_trans :: NormalCo -> NormalCo -> NormalCo opt_trans co1 co2 diff --cc compiler/types/TypeRep.lhs index c12f9c8,7fdf4ae..71d1f8d --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@@ -555,13 -480,15 +555,11 @@@ instance Outputable name => OutputableB ------------------ -- OK, here's the main printer -pprKind, pprParendKind :: Kind -> SDoc -pprKind = pprType -pprParendKind = pprParendType - ppr_type :: Prec -> Type -> SDoc - ppr_type _ (TyVarTy tv) -- Note [Infix type variables] - | isSymOcc (getOccName tv) = parens (ppr tv) - | otherwise = ppr tv + ppr_type _ (TyVarTy tv) = ppr_tvar tv ppr_type p (PredTy pred) = maybeParen p TyConPrec $ - ifPprDebug (ptext (sLit "")) <> (ppr pred) -ppr_type p (TyConApp tc tys) = ppr_tc_app p tc tys + ifPprDebug (ptext (sLit "")) <> (pprPredTy pred) +ppr_type p (TyConApp tc tys) = pprTcApp p ppr_type tc tys ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $ pprType t1 <+> ppr_type TyConPrec t2 @@@ -588,23 -515,74 +586,27 @@@ ppr_forall_type p t (tvs, rho) = split1 [] ty (ctxt, tau) = split2 [] rho - -- We need to be extra careful here as equality constraints will occur as - -- type variables with an equality kind. So, while collecting quantified - -- variables, we separate the coercion variables out and turn them into - -- equality predicates. - split1 tvs (ForAllTy tv ty) - | not (isCoVar tv) = split1 (tv:tvs) ty - split1 tvs ty = (reverse tvs, ty) + split1 tvs (ForAllTy tv ty) = split1 (tv:tvs) ty + split1 tvs ty = (reverse tvs, ty) split2 ps (PredTy p `FunTy` ty) = split2 (p:ps) ty - split2 ps (ForAllTy tv ty) - | isCoVar tv = split2 (coVarPred tv : ps) ty split2 ps ty = (reverse ps, ty) - ------------------- -ppr_tc_app :: Prec -> TyCon -> [Type] -> SDoc -ppr_tc_app _ tc [] - = ppr_tc tc -ppr_tc_app _ tc [ty] - | tc `hasKey` listTyConKey = brackets (pprType ty) - | tc `hasKey` parrTyConKey = ptext (sLit "[:") <> pprType ty <> ptext (sLit ":]") - | tc `hasKey` liftedTypeKindTyConKey = ptext (sLit "*") - | tc `hasKey` unliftedTypeKindTyConKey = ptext (sLit "#") - | tc `hasKey` openTypeKindTyConKey = ptext (sLit "(?)") - | tc `hasKey` ubxTupleKindTyConKey = ptext (sLit "(#)") - | tc `hasKey` argTypeKindTyConKey = ptext (sLit "??") - -ppr_tc_app p tc tys - | isTupleTyCon tc && tyConArity tc == length tys - = tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map pprType tys))) - | otherwise - = ppr_type_app p (getName tc) tys - -ppr_type_app :: Prec -> Name -> [Type] -> SDoc --- Used for classes as well as types; that's why it's separate from ppr_tc_app -ppr_type_app p tc tys - | is_sym_occ -- Print infix if possible - , [ty1,ty2] <- tys -- We know nothing of precedence though - = maybeParen p FunPrec (sep [ppr_type FunPrec ty1, - pprInfixVar True (ppr tc) <+> ppr_type FunPrec ty2]) - | otherwise - = maybeParen p TyConPrec (hang (pprPrefixVar is_sym_occ (ppr tc)) - 2 (sep (map pprParendType tys))) - where - is_sym_occ = isSymOcc (getOccName tc) - -ppr_tc :: TyCon -> SDoc -- No brackets for SymOcc -ppr_tc tc - = pp_nt_debug <> ppr tc - where - pp_nt_debug | isNewTyCon tc = ifPprDebug (if isRecursiveTyCon tc - then ptext (sLit "") - else ptext (sLit "")) - | otherwise = empty - + ppr_tvar :: TyVar -> SDoc + ppr_tvar tv -- Note [Infix type variables] + | isSymOcc (getOccName tv) = parens (ppr tv) + | otherwise = ppr tv + -------------------- pprForAll :: [TyVar] -> SDoc pprForAll [] = empty pprForAll tvs = ptext (sLit "forall") <+> sep (map pprTvBndr tvs) <> dot pprTvBndr :: TyVar -> SDoc -pprTvBndr tv | isLiftedTypeKind kind = ppr_tvar tv - | otherwise = parens (ppr_tvar tv <+> dcolon <+> pprKind kind) - where - kind = tyVarKind tv +pprTvBndr tv - | isLiftedTypeKind kind = ppr tv - | otherwise = parens (ppr tv <+> dcolon <+> pprKind kind) ++ | isLiftedTypeKind kind = ppr_tvar tv ++ | otherwise = parens (ppr_tvar tv <+> dcolon <+> pprKind kind) + where + kind = tyVarKind tv \end{code} Note [Infix type variables]