[commit: ghc] ghc-new-co: A few more wibbles on ghc-new-co (b855273)
Simon Peyton Jones
simonpj at microsoft.com
Mon May 2 10:00:39 CEST 2011
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : ghc-new-co
http://hackage.haskell.org/trac/ghc/changeset/b855273185a7b86c65172c10674c98bab1052e2c
>---------------------------------------------------------------
commit b855273185a7b86c65172c10674c98bab1052e2c
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Mon May 2 08:49:32 2011 +0100
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 "<recnt>")
- else ptext (sLit "<nt>"))
- | otherwise = empty
-
ppr_tvar :: TyVar -> SDoc
ppr_tvar tv -- Note [Infix type variables]
| isSymOcc (getOccName tv) = parens (ppr tv)
More information about the Cvs-ghc
mailing list