Implement -XConstraintKind

Basically as documented in http://hackage.haskell.org/trac/ghc/wiki/KindFact,
this patch adds a new kind Constraint such that:

  Show :: * -> Constraint
  (?x::Int) :: Constraint
  (Int ~ a) :: Constraint

And you can write *any* type with kind Constraint to the left of (=>):
even if that type is a type synonym, type variable, indexed type or so on.

The following (somewhat related) changes are also made:
 1. We now box equality evidence. This is required because we want
    to give (Int ~ a) the *lifted* kind Constraint
 2. For similar reasons, implicit parameters can now only be of
    a lifted kind. (?x::Int#) => ty is now ruled out
 3. Implicit parameter constraints are now allowed in superclasses
    and instance contexts (this just falls out as OK with the new
    constraint solver)

Internally the following major changes were made:
 1. There is now no PredTy in the Type data type. Instead
    GHC checks the kind of a type to figure out if it is a predicate
 2. There is now no AClass TyThing: we represent classes as TyThings
    just as a ATyCon (classes had TyCons anyway)
 3. What used to be (~) is now pretty-printed as (~#). The box
    constructor EqBox :: (a ~# b) -> (a ~ b)
 4. The type LCoercion is used internally in the constraint solver
    and type checker to represent coercions with free variables
    of type (a ~ b) rather than (a ~# b)

6 files changed, 112 insertions, 104 deletions

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index f84776546a..afb6933e30 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -7,7 +7,7 @@ This module converts Template Haskell syntax into HsSyn
 
 \begin{code}
 module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
-                convertToHsType, convertToHsPred,
+                convertToHsType,
                 thRdrNameGuesses ) where
 
 import HsSyn as Hs
@@ -59,10 +59,6 @@ convertToHsType :: SrcSpan -> TH.Type -> Either Message (LHsType RdrName)
 convertToHsType loc t
   = initCvt loc $ wrapMsg "type" t $ cvtType t
 
-convertToHsPred :: SrcSpan -> TH.Pred -> Either Message (LHsPred RdrName)
-convertToHsPred loc t
-  = initCvt loc $ wrapMsg "type" t $ cvtPred t
-
 -------------------------------------------------------------------
 newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either Message a }
 	-- Push down the source location;
@@ -190,8 +186,8 @@ cvtDec (ClassD ctxt cl tvs fds decs)
 cvtDec (InstanceD ctxt ty decs)
   = do 	{ (binds', sigs', ats') <- cvt_ci_decs (ptext (sLit "an instance declaration")) decs
 	; ctxt' <- cvtContext ctxt
-	; L loc pred' <- cvtPredTy ty
-	; let inst_ty' = L loc $ mkImplicitHsForAllTy ctxt' $ L loc $ HsPredTy pred'
+	; L loc ty' <- cvtType ty
+	; let inst_ty' = L loc $ mkImplicitHsForAllTy ctxt' $ L loc ty'
 	; returnL $ InstD (InstDecl inst_ty' binds' sigs' ats') }
 
 cvtDec (ForeignD ford) 
@@ -356,7 +352,7 @@ cvtDerivs cs = do { cs' <- mapM cvt_one cs
 		  ; return (Just cs') }
 	where
 	  cvt_one c = do { c' <- tconName c
-			 ; returnL $ HsPredTy $ HsClassP c' [] }
+			 ; returnL $ HsTyVar c' }
 
 cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep RdrName))
 cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs; ys' <- mapM tName ys; returnL (xs', ys') }
@@ -783,27 +779,18 @@ cvt_tv (TH.KindedTV nm ki)
 cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
 
-cvtPred :: TH.Pred -> CvtM (LHsPred RdrName)
+cvtPred :: TH.Pred -> CvtM (LHsType RdrName)
 cvtPred (TH.ClassP cla tys)
   = do { cla' <- if isVarName cla then tName cla else tconName cla
        ; tys' <- mapM cvtType tys
-       ; returnL $ HsClassP cla' tys'
+       ; mk_apps (HsTyVar cla') tys'
        }
 cvtPred (TH.EqualP ty1 ty2)
   = do { ty1' <- cvtType ty1
        ; ty2' <- cvtType ty2
-       ; returnL $ HsEqualP ty1' ty2'
+       ; returnL $ HsEqTy ty1' ty2'
        }
 
-cvtPredTy :: TH.Type -> CvtM (LHsPred RdrName)
-cvtPredTy ty 
-  = do	{ (head, tys') <- split_ty_app ty
-	; case head of
-	    ConT tc -> do { tc' <- tconName tc; returnL $ HsClassP tc' tys' }
-	    VarT tv -> do { tv' <- tName tv;    returnL $ HsClassP tv' tys' }
-	    _       -> failWith (ptext (sLit "Malformed predicate") <+> 
-                       text (TH.pprint ty)) }
-
 cvtType :: TH.Type -> CvtM (LHsType RdrName)
 cvtType ty 
   = do { (head_ty, tys') <- split_ty_app ty
@@ -812,18 +799,18 @@ cvtType ty
              | length tys' == n 	-- Saturated
              -> if n==1 then return (head tys')	-- Singleton tuples treated 
                                                 -- like nothing (ie just parens)
-                        else returnL (HsTupleTy Boxed tys')
+                        else returnL (HsTupleTy (HsBoxyTuple liftedTypeKind) tys')
              | n == 1    
              -> failWith (ptext (sLit "Illegal 1-tuple type constructor"))
              | otherwise 
-             -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys'
+             -> mk_apps (HsTyVar (getRdrName (tupleTyCon BoxedTuple n))) tys'
            UnboxedTupleT n
              | length tys' == n 	-- Saturated
              -> if n==1 then return (head tys')	-- Singleton tuples treated
                                                 -- like nothing (ie just parens)
-                        else returnL (HsTupleTy Unboxed tys')
+                        else returnL (HsTupleTy HsUnboxedTuple tys')
              | otherwise
-             -> mk_apps (HsTyVar (getRdrName (tupleTyCon Unboxed n))) tys'
+             -> mk_apps (HsTyVar (getRdrName (tupleTyCon UnboxedTuple n))) tys'
            ArrowT 
              | [x',y'] <- tys' -> returnL (HsFunTy x' y')
              | otherwise       -> mk_apps (HsTyVar (getRdrName funTyCon)) tys'
@@ -848,10 +835,11 @@ cvtType ty
 
            _ -> failWith (ptext (sLit "Malformed type") <+> text (show ty))
     }
-  where
-    mk_apps head_ty []       = returnL head_ty
-    mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
-				  ; mk_apps (HsAppTy head_ty' ty) tys }
+
+mk_apps :: HsType RdrName -> [LHsType RdrName] -> CvtM (LHsType RdrName)
+mk_apps head_ty []       = returnL head_ty
+mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
+                              ; mk_apps (HsAppTy head_ty' ty) tys }
 
 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
 split_ty_app ty = go ty []
@@ -992,8 +980,8 @@ isBuiltInOcc ctxt_ns occ
     go_tuple _ _            = Nothing
 
     tup_name n 
-	| OccName.isTcClsNameSpace ctxt_ns = Name.getName (tupleTyCon Boxed n)
-	| otherwise 		           = Name.getName (tupleCon Boxed n)
+	| OccName.isTcClsNameSpace ctxt_ns = Name.getName (tupleTyCon BoxedTuple n)
+	| otherwise 		           = Name.getName (tupleCon BoxedTuple n)
 
 -- The packing and unpacking is rather turgid :-(
 mk_occ :: OccName.NameSpace -> String -> OccName.OccName
diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index 4a57727785..7bc74e295b 100644
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -432,9 +432,6 @@ instance (OutputableBndr id) => Outputable (IPBind id) where
 %************************************************************************
 
 \begin{code}
--- A HsWrapper is an expression with a hole in it
--- We need coercions to have concrete form so that we can zonk them
-
 data HsWrapper
   = WpHole			-- The identity coercion
 
@@ -444,8 +441,8 @@ data HsWrapper
        -- Hence  (\a. []) `WpCompose` (\b. []) = (\a b. [])
        -- But    ([] a)   `WpCompose` ([] b)   = ([] b a)
 
-  | WpCast Coercion		-- A cast:  [] `cast` co
-				-- Guaranteed not the identity coercion
+  | WpCast LCoercion          -- A cast:  [] `cast` co
+                              -- Guaranteed not the identity coercion
 
 	-- Evidence abstraction and application
         -- (both dictionaries and coercions)
@@ -502,24 +499,24 @@ data EvBind = EvBind EvVar EvTerm
 
 data EvTerm
   = EvId EvId                  -- Term-level variable-to-variable bindings 
-                               -- (no coercion variables! they come via EvCoercion)
+                               -- (no coercion variables! they come via EvCoercionBox)
 
-  | EvCoercion Coercion        -- Coercion bindings
+  | EvCoercionBox LCoercion    -- (Boxed) coercion bindings
 
-  | EvCast EvVar Coercion      -- d |> co
+  | EvCast EvVar LCoercion     -- d |> co
 
   | EvDFunApp DFunId           -- Dictionary instance application
-       [Type] [EvVar] 
+       [Type] [EvVar]
+
+  | EvTupleSel EvId  Int       -- n'th component of the tuple
+
+  | EvTupleMk [EvId]           -- tuple built from this stuff
 
   | EvSuperClass DictId Int    -- n'th superclass. Used for both equalities and
                                -- dictionaries, even though the former have no
 			       -- selector Id.  We count up from _0_ 
 			       
   deriving( Data, Typeable)
-
-evVarTerm :: EvVar -> EvTerm
-evVarTerm v | isCoVar v = EvCoercion (mkCoVarCo v)
-            | otherwise = EvId v
 \end{code}
 
 Note [EvBinds/EvTerm]
@@ -560,7 +557,7 @@ mkWpEvApps :: [EvTerm] -> HsWrapper
 mkWpEvApps args = mk_co_app_fn WpEvApp args
 
 mkWpEvVarApps :: [EvVar] -> HsWrapper
-mkWpEvVarApps vs = mkWpEvApps (map evVarTerm vs)
+mkWpEvVarApps vs = mkWpEvApps (map EvId vs)
 
 mkWpTyLams :: [TyVar] -> HsWrapper
 mkWpTyLams ids = mk_co_lam_fn WpTyLam ids
@@ -630,11 +627,14 @@ instance Outputable EvBindsVar where
 
 instance Outputable EvBind where
   ppr (EvBind v e)   = ppr v <+> equals <+> ppr e
+   -- We cheat a bit and pretend EqVars are CoVars for the purposes of pretty printing
 
 instance Outputable EvTerm where
   ppr (EvId v)        	 = ppr v
   ppr (EvCast v co)      = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendCo co
-  ppr (EvCoercion co)    = ptext (sLit "CO") <+> ppr co
+  ppr (EvCoercionBox co) = ptext (sLit "CO") <+> ppr co
+  ppr (EvTupleSel v n)   = ptext (sLit "tupsel") <> parens (ppr (v,n))
+  ppr (EvTupleMk vs)     = ptext (sLit "tupmk") <+> ppr vs
   ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n))
   ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ]
 \end{code}
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index 9d441b707d..995c66068c 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -425,7 +425,7 @@ ppr_expr (SectionR op expr)
     pp_infixly v = sep [pprHsInfix v, pp_expr]
 
 ppr_expr (ExplicitTuple exprs boxity)
-  = tupleParens boxity (fcat (ppr_tup_args exprs))
+  = tupleParens (boxityNormalTupleSort boxity) (fcat (ppr_tup_args exprs))
   where
     ppr_tup_args []               = []
     ppr_tup_args (Present e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es
diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs
index 71dfe1d969..5c404a6ae8 100644
--- a/compiler/hsSyn/HsPat.lhs
+++ b/compiler/hsSyn/HsPat.lhs
@@ -252,7 +252,7 @@ pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat]
 pprPat (ParPat pat)	    = parens (ppr pat)
 pprPat (ListPat pats _)     = brackets (interpp'SP pats)
 pprPat (PArrPat pats _)     = pabrackets (interpp'SP pats)
-pprPat (TuplePat pats bx _) = tupleParens bx (interpp'SP pats)
+pprPat (TuplePat pats bx _) = tupleParens (boxityNormalTupleSort bx) (interpp'SP pats)
 
 pprPat (ConPatIn con details) = pprUserCon con details
 pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts, 
diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index f8b7be47af..89a002b63c 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -11,9 +11,8 @@ HsTypes: Abstract syntax: user-defined types
 module HsTypes (
 	HsType(..), LHsType, 
 	HsTyVarBndr(..), LHsTyVarBndr,
-	HsExplicitFlag(..),
+	HsTupleSort(..), HsExplicitFlag(..),
 	HsContext, LHsContext,
-	HsPred(..), LHsPred,
 	HsQuasiQuote(..),
 
 	LBangType, BangType, HsBang(..), 
@@ -25,7 +24,10 @@ module HsTypes (
 	hsTyVarName, hsTyVarNames, replaceTyVarName, replaceLTyVarName,
 	hsTyVarKind, hsTyVarNameKind,
 	hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
-	splitHsInstDeclTy, splitHsFunType,
+	splitHsInstDeclTy_maybe, splitLHsInstDeclTy_maybe,
+        splitHsForAllTy, splitLHsForAllTy,
+        splitHsClassTy_maybe, splitLHsClassTy_maybe,
+        splitHsFunType,
 	splitHsAppTys, mkHsAppTys,
 	
 	-- Type place holder
@@ -37,7 +39,7 @@ module HsTypes (
 
 import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice )
 
-import NameSet( FreeVars )
+import NameSet ( FreeVars )
 import Type
 import HsDoc
 import BasicTypes
@@ -124,14 +126,7 @@ This is the syntax for types as seen in type signatures.
 \begin{code}
 type LHsContext name = Located (HsContext name)
 
-type HsContext name = [LHsPred name]
-
-type LHsPred name = Located (HsPred name)
-
-data HsPred name = HsClassP name [LHsType name]		 -- class constraint
-		 | HsEqualP (LHsType name) (LHsType name)-- equality constraint
-		 | HsIParam (IPName name) (LHsType name)
-		 deriving (Data, Typeable)
+type HsContext name = [LHsType name]
 
 type LHsType name = Located (HsType name)
 
@@ -156,7 +151,7 @@ data HsType name
 
   | HsPArrTy		(LHsType name)	-- Elem. type of parallel array: [:t:]
 
-  | HsTupleTy		Boxity
+  | HsTupleTy		HsTupleSort
 			[LHsType name]	-- Element types (length gives arity)
 
   | HsOpTy		(LHsType name) (Located name) (LHsType name)
@@ -165,12 +160,11 @@ data HsType name
 	-- Parenthesis preserved for the precedence re-arrangement in RnTypes
 	-- It's important that a * (b + c) doesn't get rearranged to (a*b) + c!
 
-  | HsPredTy		(HsPred name)	-- Only used in the type of an instance
-					-- declaration, eg.  Eq [a] -> Eq a
-					--			       ^^^^
-					--                            HsPredTy
-					-- Note no need for location info on the
-					-- Enclosed HsPred; the one on the type will do
+  | HsIParamTy		(IPName name)    -- (?x :: ty)
+                        (LHsType name)   -- Implicit parameters as they occur in contexts
+
+  | HsEqTy              (LHsType name)   -- ty1 ~ ty2
+                        (LHsType name)   -- Always allowed even without TypeOperators, and has special kinding rule
 
   | HsKindSig		(LHsType name)	-- (ty :: kind)
 			Kind		-- A type with a kind signature
@@ -191,6 +185,10 @@ data HsType name
 					 
   deriving (Data, Typeable)
 
+data HsTupleSort = HsUnboxedTuple
+                 | HsBoxyTuple Kind -- Either a Constraint or normal tuple: resolved during type checking
+                 deriving (Data, Typeable)
+
 data HsExplicitFlag = Explicit | Implicit deriving (Data, Typeable)
 
 data ConDeclField name	-- Record fields have Haddoc docs on them
@@ -223,7 +221,7 @@ mkHsForAllTy exp tvs ctxt ty = HsForAllTy exp tvs ctxt ty
 mk_forall_ty :: HsExplicitFlag -> [LHsTyVarBndr name] -> LHsType name -> HsType name
 mk_forall_ty exp  tvs  (L _ (HsParTy ty))		    = mk_forall_ty exp tvs ty
 mk_forall_ty exp1 tvs1 (L _ (HsForAllTy exp2 tvs2 ctxt ty)) = mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ tvs2) ctxt ty
-mk_forall_ty exp  tvs  ty			            = HsForAllTy exp tvs (L noSrcSpan []) ty
+mk_forall_ty exp  tvs  ty			            = HsForAllTy exp tvs (noLoc []) ty
 	-- Even if tvs is empty, we still make a HsForAll!
 	-- In the Implicit case, this signals the place to do implicit quantification
 	-- In the Explicit case, it prevents implicit quantification	
@@ -305,22 +303,53 @@ mkHsAppTys fun_ty (arg_ty:arg_tys)
        -- Add noLocs for inner nodes of the application; 
        -- they are never used 
 
-splitHsInstDeclTy 
-    :: OutputableBndr name
-    => LHsType name 
-    -> ([LHsTyVarBndr name], HsContext name, Located name, [LHsType name])
-	-- Split up an instance decl type, returning the pieces
+splitHsInstDeclTy_maybe :: HsType name 
+                        -> Maybe ([LHsTyVarBndr name], HsContext name, name, [LHsType name])
+splitHsInstDeclTy_maybe ty
+  = fmap (\(tvs, cxt, L _ n, tys) -> (tvs, cxt, n, tys)) $ splitLHsInstDeclTy_maybe (noLoc ty)
 
-splitHsInstDeclTy linst_ty@(L _ inst_ty)
-  = case inst_ty of
-	HsParTy ty       	-> splitHsInstDeclTy ty
-	HsForAllTy _ tvs cxt ty -> split_tau tvs (unLoc cxt) ty
-	_ 			-> split_tau []  []          linst_ty
-    -- The type vars should have been computed by now, even if they were implicit
+splitLHsInstDeclTy_maybe
+    :: LHsType name 
+    -> Maybe ([LHsTyVarBndr name], HsContext name, Located name, [LHsType name])
+	-- Split up an instance decl type, returning the pieces
+splitLHsInstDeclTy_maybe inst_ty = do
+    let (tvs, cxt, ty) = splitLHsForAllTy inst_ty
+    (cls, tys) <- splitLHsClassTy_maybe ty
+    return (tvs, cxt, cls, tys)
+
+splitHsForAllTy :: HsType name -> ([LHsTyVarBndr name], HsContext name, HsType name)
+splitHsForAllTy ty = case splitLHsForAllTy (noLoc ty) of (tvs, cxt, L _ ty) -> (tvs, cxt, ty)
+
+splitLHsForAllTy
+    :: LHsType name 
+    -> ([LHsTyVarBndr name], HsContext name, LHsType name)
+splitLHsForAllTy poly_ty
+  = case unLoc poly_ty of
+        HsParTy ty              -> splitLHsForAllTy ty
+        HsForAllTy _ tvs cxt ty -> (tvs, unLoc cxt, ty)
+        _                       -> ([], [], poly_ty)
+        -- The type vars should have been computed by now, even if they were implicit
+
+splitHsClassTy_maybe :: HsType name -> Maybe (name, [LHsType name])
+splitHsClassTy_maybe ty = fmap (\(L _ n, tys) -> (n, tys)) $ splitLHsClassTy_maybe (noLoc ty)
+
+splitLHsClassTy_maybe :: LHsType name -> Maybe (Located name, [LHsType name])
+--- Watch out.. in ...deriving( Show )... we use this on 
+--- the list of partially applied predicates in the deriving,
+--- so there can be zero args.
+
+-- In TcDeriv we also use this to figure out what data type is being
+-- mentioned in a deriving (Generic (Foo bar baz)) declaration (i.e. "Foo").
+splitLHsClassTy_maybe ty
+  = checkl ty []
   where
-    split_tau tvs cxt (L loc (HsPredTy (HsClassP cls tys))) = (tvs, cxt, L loc cls, tys)
-    split_tau tvs cxt (L _ (HsParTy ty))	            = split_tau tvs cxt ty
-    split_tau _ _ _ = pprPanic "splitHsInstDeclTy" (ppr inst_ty)
+    checkl (L l ty) args = case ty of
+        HsTyVar t      -> Just (L l t, args)
+        HsAppTy l r    -> checkl l (r:args)
+        HsOpTy l tc r  -> checkl (fmap HsTyVar tc) (l:r:args)
+        HsParTy t      -> checkl t args
+        HsKindSig ty _ -> checkl ty args
+        _              -> Nothing
 
 -- Splits HsType into the (init, last) parts
 -- Breaks up any parens in the result type: 
@@ -348,15 +377,6 @@ instance (Outputable name) => Outputable (HsTyVarBndr name) where
     ppr (UserTyVar name _)      = ppr name
     ppr (KindedTyVar name kind) = hsep [ppr name, dcolon, pprParendKind kind]
 
-instance OutputableBndr name => Outputable (HsPred name) where
-    ppr (HsClassP clas tys) = ppr clas <+> hsep (map pprLHsType tys)
-    ppr (HsEqualP t1 t2)    = hsep [pprLHsType t1, ptext (sLit "~"), 
-				    pprLHsType t2]
-    ppr (HsIParam n ty)     = hsep [ppr n, dcolon, ppr ty]
-
-pprLHsType :: OutputableBndr name => LHsType name -> SDoc
-pprLHsType = pprParendHsType . unLoc
-
 pprHsForAll :: OutputableBndr name => HsExplicitFlag -> [LHsTyVarBndr name] ->  LHsContext name -> SDoc
 pprHsForAll exp tvs cxt 
   | show_forall = forall_part <+> pprHsContext (unLoc cxt)
@@ -369,16 +389,9 @@ pprHsForAll exp tvs cxt
 
 pprHsContext :: (OutputableBndr name) => HsContext name -> SDoc
 pprHsContext []	        = empty
-pprHsContext [L _ pred] 
-   | noParenHsPred pred = ppr pred <+> darrow
+pprHsContext [L _ pred] = ppr pred <+> darrow
 pprHsContext cxt        = ppr_hs_context cxt <+> darrow
 
-noParenHsPred :: HsPred name -> Bool
--- c.f. TypeRep.noParenPred
-noParenHsPred (HsClassP {}) = True
-noParenHsPred (HsEqualP {}) = True
-noParenHsPred (HsIParam {}) = False
-
 ppr_hs_context :: (OutputableBndr name) => HsContext name -> SDoc
 ppr_hs_context []  = empty
 ppr_hs_context cxt = parens (interpp'SP cxt)
@@ -446,14 +459,21 @@ ppr_mono_ty _    (HsQuasiQuoteTy qq) = ppr qq
 ppr_mono_ty _    (HsRecTy flds)      = pprConDeclFields flds
 ppr_mono_ty _    (HsTyVar name)      = ppr name
 ppr_mono_ty prec (HsFunTy ty1 ty2)   = ppr_fun_ty prec ty1 ty2
-ppr_mono_ty _    (HsTupleTy con tys) = tupleParens con (interpp'SP tys)
+ppr_mono_ty _    (HsTupleTy con tys) = tupleParens std_con (interpp'SP tys)
+  where std_con = case con of
+                    HsUnboxedTuple -> UnboxedTuple
+                    HsBoxyTuple _  -> BoxedTuple
 ppr_mono_ty _    (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> pprKind kind)
 ppr_mono_ty _    (HsListTy ty)	     = brackets (ppr_mono_lty pREC_TOP ty)
 ppr_mono_ty _    (HsPArrTy ty)	     = pabrackets (ppr_mono_lty pREC_TOP ty)
-ppr_mono_ty _    (HsPredTy pred)     = ppr pred
+ppr_mono_ty prec (HsIParamTy n ty)   = maybeParen prec pREC_FUN (ppr n <+> dcolon <+> ppr_mono_lty pREC_TOP ty)
 ppr_mono_ty _    (HsSpliceTy s _ _)  = pprSplice s
 ppr_mono_ty _    (HsCoreTy ty)       = ppr ty
 
+ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2)
+  = maybeParen ctxt_prec pREC_OP $
+    ppr_mono_lty pREC_OP ty1 <+> char '~' <+> ppr_mono_lty pREC_OP ty2
+
 ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty)
   = maybeParen ctxt_prec pREC_CON $
     hsep [ppr_mono_lty pREC_FUN fun_ty, ppr_mono_lty pREC_CON arg_ty]
diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index cd95571964..3451e4ce6c 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -173,15 +173,15 @@ mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
 mkHsWrap co_fn e | isIdHsWrapper co_fn = e
 		 | otherwise	       = HsWrap co_fn e
 
-mkHsWrapCo :: Coercion -> HsExpr id -> HsExpr id
+mkHsWrapCo :: LCoercion -> HsExpr id -> HsExpr id
 mkHsWrapCo (Refl _) e = e
 mkHsWrapCo co       e = mkHsWrap (WpCast co) e
 
-mkLHsWrapCo :: Coercion -> LHsExpr id -> LHsExpr id
+mkLHsWrapCo :: LCoercion -> LHsExpr id -> LHsExpr id
 mkLHsWrapCo (Refl _) e         = e
 mkLHsWrapCo co       (L loc e) = L loc (mkHsWrap (WpCast co) e)
 
-coToHsWrapper :: Coercion -> HsWrapper
+coToHsWrapper :: LCoercion -> HsWrapper
 coToHsWrapper (Refl _) = idHsWrapper
 coToHsWrapper co       = WpCast co
 
@@ -189,7 +189,7 @@ mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
 mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
 		       | otherwise	     = CoPat co_fn p ty
 
-mkHsWrapPatCo :: Coercion -> Pat id -> Type -> Pat id
+mkHsWrapPatCo :: LCoercion -> Pat id -> Type -> Pat id
 mkHsWrapPatCo (Refl _) pat _  = pat
 mkHsWrapPatCo co       pat ty = CoPat (WpCast co) pat ty