From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Sat, 30 Apr 2011 13:26:48 +0000 (+0100)
Subject: Merge remote branch 'origin/master' into ghc-new-co
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=224ef3094189bc9a33f23285b5dccbffdd8d7de0

Merge remote branch 'origin/master' into ghc-new-co

Conflicts:
	compiler/typecheck/TcErrors.lhs
	compiler/typecheck/TcSMonad.lhs
	compiler/typecheck/TcType.lhs
	compiler/types/TypeRep.lhs
---

224ef3094189bc9a33f23285b5dccbffdd8d7de0
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/typecheck/TcErrors.lhs
index 9cbd47b,645c43a..0d0a9f8
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@@ -15,8 -15,11 +15,9 @@@ import TcMTyp
  import TcSMonad
  import TcType
  import TypeRep
+ import Type( isTyVarTy )
 -
  import Inst
  import InstEnv
 -
  import TyCon
  import Name
  import NameEnv
diff --cc compiler/typecheck/TcType.lhs
index f2b090b,d9166d1..5d0bf48
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@@ -397,12 -390,12 +395,12 @@@ kind_var_occ = mkOccName tvName "k
  \begin{code}
  pprTcTyVarDetails :: TcTyVarDetails -> SDoc
  -- For debugging
- pprTcTyVarDetails (SkolemTv _)         = ptext (sLit "sk")
- pprTcTyVarDetails (RuntimeUnk {})      = ptext (sLit "rt")
- pprTcTyVarDetails (FlatSkol {})        = ptext (sLit "fsk")
- pprTcTyVarDetails (MetaTv TauTv _)     = ptext (sLit "tau")
- pprTcTyVarDetails (MetaTv TcsTv _)     = ptext (sLit "tcs")
- pprTcTyVarDetails (MetaTv (SigTv _) _) = ptext (sLit "sig")
 -pprTcTyVarDetails (SkolemTv {})    = ptext (sLit "sk")
++pprTcTyVarDetails (SkolemTv {})     = ptext (sLit "sk")
+ pprTcTyVarDetails (RuntimeUnk {})  = ptext (sLit "rt")
+ pprTcTyVarDetails (FlatSkol {})    = ptext (sLit "fsk")
+ pprTcTyVarDetails (MetaTv TauTv _) = ptext (sLit "tau")
+ pprTcTyVarDetails (MetaTv TcsTv _) = ptext (sLit "tcs")
+ pprTcTyVarDetails (MetaTv SigTv _) = ptext (sLit "sig")
  
  pprUserTypeCtxt :: UserTypeCtxt -> SDoc
  pprUserTypeCtxt (FunSigCtxt n)  = ptext (sLit "the type signature for") <+> quotes (ppr n)
diff --cc compiler/types/TypeRep.lhs
index 446341d,7fdf4ae..87ffacd
--- a/compiler/types/TypeRep.lhs
+++ b/compiler/types/TypeRep.lhs
@@@ -566,13 -480,15 +566,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 "<pred>")) <> (ppr pred)
 -ppr_type p (TyConApp tc tys)  = ppr_tc_app p tc tys
 +                                ifPprDebug (ptext (sLit "<pred>")) <> (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
@@@ -599,23 -515,74 +597,68 @@@ 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 "<recnt>")
+ 					     else ptext (sLit "<nt>"))
+ 	       | 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 tv
-   | otherwise             = parens (ppr tv <+> dcolon <+> pprKind kind)
-   where
-     kind = tyVarKind tv
 -pprTvBndr tv | isLiftedTypeKind kind = ppr_tvar tv
 -	     | otherwise	     = parens (ppr_tvar tv <+> dcolon <+> pprKind kind)
++pprTvBndr tv 
++  | isLiftedTypeKind kind = ppr_tvar tv
++  | otherwise	          = parens (ppr_tvar tv <+> dcolon <+> pprKind kind)
+ 	     where
+ 	       kind = tyVarKind tv
  \end{code}
  
  Note [Infix type variables]