From b855273185a7b86c65172c10674c98bab1052e2c Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Mon, 2 May 2011 08:49:32 +0100 Subject: [PATCH] A few more wibbles on ghc-new-co --- compiler/deSugar/DsBinds.lhs | 10 +++++----- compiler/ghci/ByteCodeGen.lhs | 1 + compiler/typecheck/TcInteract.lhs | 2 +- compiler/types/OptCoercion.lhs | 17 +++++----------- compiler/types/TypeRep.lhs | 40 ------------------------------------- 5 files changed, 12 insertions(+), 58 deletions(-) diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 85883dc..65cb815 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -598,13 +598,13 @@ decomposeRuleLhs bndrs lhs bad_shape_msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar")) 2 (ppr opt_lhs) - dead_msg bndr = hang (ptext (sLit "Forall'd") <+> pp_bndr bndr - <+> ptext (sLit "is not bound in RULE lhs")) + dead_msg bndr = hang (sep [ ptext (sLit "Forall'd") <+> pp_bndr bndr + , ptext (sLit "is not bound in RULE lhs")]) 2 (ppr opt_lhs) pp_bndr bndr - | isTyVar bndr = ptext (sLit "type variable") <+> ppr bndr - | isEvVar bndr = ptext (sLit "constraint") <+> ppr bndr <+> dcolon <+> ppr (evVarPred bndr) - | otherwise = ptext (sLit "variable") <+> ppr bndr + | isTyVar bndr = ptext (sLit "type variable") <+> quotes (ppr bndr) + | isEvVar bndr = ptext (sLit "constraint") <+> quotes (ppr (evVarPred bndr)) + | otherwise = ptext (sLit "variable") <+> quotes (ppr bndr) \end{code} Note [Simplifying the left-hand side of a RULE] diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index 8e90d7d..b1d4bd7 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -1470,6 +1470,7 @@ atomPrimRep :: AnnExpr' Id ann -> PrimRep atomPrimRep e | Just e' <- bcView e = atomPrimRep e' atomPrimRep (AnnVar v) = typePrimRep (idType v) atomPrimRep (AnnLit l) = typePrimRep (literalType l) +atomPrimRep (AnnCoercion {}) = VoidRep atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate (undefined,other))) atomRep :: AnnExpr' Id ann -> CgRep diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index d179746..fd66d0a 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -1053,7 +1053,7 @@ doInteractWithInert (CIPCan { cc_id = id1, cc_flavor = ifl, cc_ip_nm = nm1, cc_i Derived {} -> pprPanic "Unexpected derived IP" (ppr workItem) Wanted {} -> do { setIPBind (cc_id workItem) $ - EvCast id1 (mkSymCoercion (mkCoVarCoercion co_var)) + EvCast id1 (mkSymCo (mkCoVarCo co_var)) ; mkIRStopK "IP/IP interaction (solved)" cans } } diff --git a/compiler/types/OptCoercion.lhs b/compiler/types/OptCoercion.lhs index c955712..6d0f2b1 100644 --- a/compiler/types/OptCoercion.lhs +++ b/compiler/types/OptCoercion.lhs @@ -3,26 +3,18 @@ % \begin{code} -{-# OPTIONS_GHC -w #-} -module OptCoercion ( - optCoercion - ) where +module OptCoercion ( optCoercion ) where #include "HsVersions.h" -import Unify ( tcMatchTy ) import Coercion import Type hiding( substTyVarBndr, substTy, extendTvSubst ) -import TypeRep import TyCon import Var import VarSet import VarEnv -import PrelNames import StaticFlags ( opt_NoOptCoercion ) -import Util import Outputable -import Unify import Pair import Maybes( allMaybes ) import FastString @@ -100,7 +92,8 @@ opt_co env sym 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 (PredCo cos) = mkPredCo (fmap (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) @@ -338,8 +331,8 @@ opt_trans_pred (IParam n1 co1) (IParam n2 co2) opt_trans_pred _ _ = Nothing fireTransRule :: String -> Coercion -> Coercion -> Coercion -> Maybe Coercion -fireTransRule rule co1 co2 res - = -- pprTrace ("Trans rule fired: " ++ rule) (vcat [ppr co1, ppr co2, ppr res]) $ +fireTransRule _rule _co1 _co2 res + = -- pprTrace ("Trans rule fired: " ++ _rule) (vcat [ppr _co1, ppr _co2, ppr res]) $ Just res ----------- diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index 87ffacd..0f400fa 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -603,46 +603,6 @@ ppr_forall_type p ty split2 ps (PredTy p `FunTy` ty) = split2 (p: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) -- 1.7.10.4