A few more wibbles on ghc-new-co

diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 85883dc..65cb815 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- a/compiler/types/OptCoercion.lhs
+++ b/compiler/types/OptCoercion.lhs
@@ -3,26 +3,18 @@
 %\r
 \r
 \begin{code}\r
-{-# OPTIONS_GHC -w #-}\r
-module OptCoercion (\r
-       optCoercion\r
-   ) where \r
+module OptCoercion ( optCoercion ) where \r
 \r
 #include "HsVersions.h"\r
 \r
-import Unify   ( tcMatchTy )\r
 import Coercion\r
 import Type hiding( substTyVarBndr, substTy, extendTvSubst )\r
-import TypeRep\r
 import TyCon\r
 import Var\r
 import VarSet\r
 import VarEnv\r
-import PrelNames\r
 import StaticFlags     ( opt_NoOptCoercion )\r
-import Util\r
 import Outputable\r
-import Unify\r
 import Pair\r
 import Maybes( allMaybes )\r
 import FastString\r
@@ -100,7 +92,8 @@ opt_co env sym co
 \r
 opt_co' env _   (Refl ty)           = Refl (substTy env ty)\r
 opt_co' env sym (SymCo co)          = opt_co env (not sym) co\r
-opt_co' env sym (TyConAppCo tc cos) = TyConAppCo tc (map (opt_co env sym) cos)\r
+opt_co' env sym (TyConAppCo tc cos) = mkTyConAppCo tc (map (opt_co env sym) cos)\r
+opt_co' env sym (PredCo cos)        = mkPredCo (fmap (opt_co env sym) cos)\r
 opt_co' env sym (AppCo co1 co2)     = mkAppCo (opt_co env sym co1) (opt_co env sym co2)\r
 opt_co' env sym (ForAllCo tv co)    = case substTyVarBndr env tv of\r
                                          (env', tv') -> ForAllCo tv' (opt_co env' sym co)\r
@@ -338,8 +331,8 @@ opt_trans_pred (IParam n1 co1) (IParam n2 co2)
 opt_trans_pred _ _ = Nothing\r
 \r
 fireTransRule :: String -> Coercion -> Coercion -> Coercion -> Maybe Coercion\r
-fireTransRule rule co1 co2 res\r
-  = -- pprTrace ("Trans rule fired: " ++ rule) (vcat [ppr co1, ppr co2, ppr res]) $\r
+fireTransRule _rule _co1 _co2 res\r
+  = -- pprTrace ("Trans rule fired: " ++ _rule) (vcat [ppr _co1, ppr _co2, ppr res]) $\r
     Just res\r
 \r
 -----------\r

diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index 87ffacd..0f400fa 100644 (file)
--- 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)