GHC issue #7021 patches

0001-Apply-changes-relative-to-TH.Pred-becoming-a-TH.Type.patch

From d8730a5b72f263754e82c5e18ee53abf0c002b46 Mon Sep 17 00:00:00 2001
From: YoEight <yo.eight@gmail.com>
Date: Sat, 11 Jan 2014 13:30:23 +0100
Subject: [PATCH] Apply changes relative to TH.Pred becoming a TH.Type's
 synonym (issue #7021)

---
 compiler/deSugar/DsMeta.hs      | 53 +++++++++++++++++++----------------------
 compiler/hsSyn/Convert.lhs      | 16 +++++--------
 compiler/typecheck/TcSplice.lhs | 41 +++++++++++++++++++++++--------
 3 files changed, 61 insertions(+), 49 deletions(-)

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 0ee963e..0d8c4b4 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -277,7 +277,7 @@ repFamilyDecl (L loc (FamilyDecl { fdInfo    = info,
                                    fdKindSig = opt_kind }))
   = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
        ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
-           case (opt_kind, info) of 
+           case (opt_kind, info) of
                   (Nothing, ClosedTypeFamily eqns) ->
                     do { eqns1 <- mapM repTyFamEqn eqns
                        ; eqns2 <- coreList tySynEqnQTyConName eqns1
@@ -286,13 +286,13 @@ repFamilyDecl (L loc (FamilyDecl { fdInfo    = info,
                     do { eqns1 <- mapM repTyFamEqn eqns
                        ; eqns2 <- coreList tySynEqnQTyConName eqns1
                        ; ki1 <- repLKind ki
-                       ; repClosedFamilyKind tc1 bndrs ki1 eqns2 }              
+                       ; repClosedFamilyKind tc1 bndrs ki1 eqns2 }
                   (Nothing, _) ->
                     do { info' <- repFamilyInfo info
                        ; repFamilyNoKind info' tc1 bndrs }
                   (Just ki, _) ->
                     do { info' <- repFamilyInfo info
-                       ; ki1 <- repLKind ki 
+                       ; ki1 <- repLKind ki
                        ; repFamilyKind info' tc1 bndrs ki1 }
        ; return (loc, dec)
        }
@@ -389,7 +389,7 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
 repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ)
 repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
   = do { let tc_name = tyFamInstDeclLName decl
-       ; tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]  
+       ; tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
        ; eqn1 <- repTyFamEqn eqn
        ; repTySynInst tc eqn1 }
 
@@ -763,19 +763,27 @@ repLPred :: LHsType Name -> DsM (Core TH.PredQ)
 repLPred (L _ p) = repPred p
 
 repPred :: HsType Name -> DsM (Core TH.PredQ)
-repPred (HsParTy ty) 
+repPred (HsParTy ty)
   = repLPred ty
 repPred ty
   | Just (cls, tys) <- splitHsClassTy_maybe ty
   = do
       cls1 <- lookupOcc cls
-      tys1 <- repList typeQTyConName repLTy tys
-      repClassP cls1 tys1
+      tyco <- repNamedTyCon cls1
+      tys' <- mapM repLTy tys
+      repTapps tyco tys'
 repPred (HsEqTy tyleft tyright)
   = do
       tyleft1  <- repLTy tyleft
       tyright1 <- repLTy tyright
-      repEqualP tyleft1 tyright1
+      repTequality tyleft1 tyright1
+repPred (HsTupleTy _ lps)
+  = do
+      tupTy <- repTupleTyCon size
+      foldM go tupTy lps
+  where
+    size = length lps
+    go ty' lp = repTapp ty' =<< repLPred lp
 repPred ty
   = notHandled "Exotic predicate type" (ppr ty)
 
@@ -1772,12 +1780,6 @@ repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
 repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)
 repCtxt (MkC tys) = rep2 cxtName [tys]
 
-repClassP :: Core TH.Name -> Core [TH.TypeQ] -> DsM (Core TH.PredQ)
-repClassP (MkC cla) (MkC tys) = rep2 classPName [cla, tys]
-
-repEqualP :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.PredQ)
-repEqualP (MkC ty1) (MkC ty2) = rep2 equalPName [ty1, ty2]
-
 repConstr :: Core TH.Name -> HsConDeclDetails Name
           -> DsM (Core TH.ConQ)
 repConstr con (PrefixCon ps)
@@ -1816,6 +1818,9 @@ repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
 repTSig :: Core TH.TypeQ -> Core TH.Kind -> DsM (Core TH.TypeQ)
 repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]
 
+repTequality :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
+repTequality (MkC t1) (MkC t2) = rep2 equalityTName [t1, t2]
+
 repTPromotedList :: [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
 repTPromotedList []     = repPromotedNilTyCon
 repTPromotedList (t:ts) = do  { tcon <- repPromotedConsTyCon
@@ -2069,8 +2074,6 @@ templateHaskellNames = [
     roleAnnotDName,
     -- Cxt
     cxtName,
-    -- Pred
-    classPName, equalPName,
     -- Strict
     isStrictName, notStrictName, unpackedName,
     -- Con
@@ -2080,7 +2083,7 @@ templateHaskellNames = [
     -- VarStrictType
     varStrictTypeName,
     -- Type
-    forallTName, varTName, conTName, appTName,
+    forallTName, varTName, conTName, appTName, equalityTName,
     tupleTName, unboxedTupleTName, arrowTName, listTName, sigTName, litTName,
     promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName,
     -- TyLit
@@ -2323,11 +2326,6 @@ roleAnnotDName    = libFun (fsLit "roleAnnotD")    roleAnnotDIdKey
 cxtName :: Name
 cxtName = libFun (fsLit "cxt") cxtIdKey
 
--- data Pred = ...
-classPName, equalPName :: Name
-classPName = libFun (fsLit "classP") classPIdKey
-equalPName = libFun (fsLit "equalP") equalPIdKey
-
 -- data Strict = ...
 isStrictName, notStrictName, unpackedName :: Name
 isStrictName      = libFun  (fsLit "isStrict")      isStrictKey
@@ -2351,7 +2349,7 @@ varStrictTypeName = libFun  (fsLit "varStrictType") varStrictTKey
 
 -- data Type = ...
 forallTName, varTName, conTName, tupleTName, unboxedTupleTName, arrowTName,
-    listTName, appTName, sigTName, litTName,
+    listTName, appTName, sigTName, equalityTName, litTName,
     promotedTName, promotedTupleTName,
     promotedNilTName, promotedConsTName :: Name
 forallTName         = libFun (fsLit "forallT")        forallTIdKey
@@ -2363,6 +2361,7 @@ arrowTName          = libFun (fsLit "arrowT")         arrowTIdKey
 listTName           = libFun (fsLit "listT")          listTIdKey
 appTName            = libFun (fsLit "appT")           appTIdKey
 sigTName            = libFun (fsLit "sigT")           sigTIdKey
+equalityTName       = libFun (fsLit "equalityT")      equalityTIdKey
 litTName            = libFun (fsLit "litT")           litTIdKey
 promotedTName       = libFun (fsLit "promotedT")      promotedTIdKey
 promotedTupleTName  = libFun (fsLit "promotedTupleT") promotedTupleTIdKey
@@ -2681,11 +2680,6 @@ roleAnnotDIdKey              = mkPreludeMiscIdUnique 352
 cxtIdKey :: Unique
 cxtIdKey            = mkPreludeMiscIdUnique 360
 
--- data Pred = ...
-classPIdKey, equalPIdKey :: Unique
-classPIdKey         = mkPreludeMiscIdUnique 361
-equalPIdKey         = mkPreludeMiscIdUnique 362
-
 -- data Strict = ...
 isStrictKey, notStrictKey, unpackedKey :: Unique
 isStrictKey         = mkPreludeMiscIdUnique 363
@@ -2709,7 +2703,7 @@ varStrictTKey     = mkPreludeMiscIdUnique 375
 
 -- data Type = ...
 forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey, arrowTIdKey,
-    listTIdKey, appTIdKey, sigTIdKey, litTIdKey,
+    listTIdKey, appTIdKey, sigTIdKey, equalityTIdKey, litTIdKey,
     promotedTIdKey, promotedTupleTIdKey,
     promotedNilTIdKey, promotedConsTIdKey :: Unique
 forallTIdKey        = mkPreludeMiscIdUnique 380
@@ -2721,6 +2715,7 @@ arrowTIdKey         = mkPreludeMiscIdUnique 385
 listTIdKey          = mkPreludeMiscIdUnique 386
 appTIdKey           = mkPreludeMiscIdUnique 387
 sigTIdKey           = mkPreludeMiscIdUnique 388
+equalityTIdKey      = mkPreludeMiscIdUnique 362
 litTIdKey           = mkPreludeMiscIdUnique 389
 promotedTIdKey      = mkPreludeMiscIdUnique 390
 promotedTupleTIdKey = mkPreludeMiscIdUnique 391
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 216ab22..b8f355f 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -22,6 +22,7 @@ import SrcLoc
 import Type
 import qualified Coercion ( Role(..) )
 import TysWiredIn
+import TysPrim (eqPrimTyCon)
 import BasicTypes as Hs
 import ForeignCall
 import Unique
@@ -890,16 +891,7 @@ cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
 
 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
-       ; mk_apps (HsTyVar cla') tys'
-       }
-cvtPred (TH.EqualP ty1 ty2)
-  = do { ty1' <- cvtType ty1
-       ; ty2' <- cvtType ty2
-       ; returnL $ HsEqTy ty1' ty2'
-       }
+cvtPred = cvtType
 
 cvtType :: TH.Type -> CvtM (LHsType RdrName)
 cvtType = cvtTypeKind "type"
@@ -979,6 +971,10 @@ cvtTypeKind ty_str ty
            ConstraintT
              -> returnL (HsTyVar (getRdrName constraintKindTyCon))
 
+           EqualityT
+             | [x',y'] <- tys' -> returnL (HsEqTy x' y')
+             | otherwise       -> mk_apps (HsTyVar (getRdrName eqPrimTyCon)) tys'
+
            _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))
     }
 
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 100ed34..eebe06d 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -341,7 +341,7 @@ tcTypedBracket brack@(TExpBr expr) res_ty
        -- Throw away the typechecked expression but return its type.
        -- We'll typecheck it again when we splice it in somewhere
        ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var)) $
-                                tcInferRhoNC expr 
+                                tcInferRhoNC expr
                                 -- NC for no context; tcBracket does that
 
        ; meta_ty <- tcTExpTy expr_ty
@@ -1014,7 +1014,7 @@ reifyInstances th_nm th_tys
                      ; let matches = lookupFamInstEnv inst_envs tc tys
                      ; traceTc "reifyInstances2" (ppr matches)
                      ; mapM (reifyFamilyInstance . fim_instance) matches }
-            _  -> bale_out (hang (ptext (sLit "reifyInstances:") <+> quotes (ppr ty)) 
+            _  -> bale_out (hang (ptext (sLit "reifyInstances:") <+> quotes (ppr ty))
                                2 (ptext (sLit "is not a class constraint or type family application"))) }
   where
     doc = ClassInstanceCtx
@@ -1302,7 +1302,7 @@ reifyClassInstance i
 
 ------------------------------
 reifyFamilyInstance :: FamInst -> TcM TH.Dec
-reifyFamilyInstance (FamInst { fi_flavor = flavor 
+reifyFamilyInstance (FamInst { fi_flavor = flavor
                              , fi_fam = fam
                              , fi_tys = lhs
                              , fi_rhs = rhs })
@@ -1392,7 +1392,7 @@ reifyFamFlavour tc
   | Just ax <- isClosedSynFamilyTyCon_maybe tc
   = do { eqns <- brListMapM reifyAxBranch $ coAxiomBranches ax
        ; return $ Right eqns }
-                   
+
   | otherwise
   = panic "TcSplice.reifyFamFlavour: not a type family"
 
@@ -1436,14 +1436,35 @@ reifyPred ty
   | isIPPred ty = noTH (sLit "implicit parameters") (ppr ty)
   | otherwise
    = case classifyPredType ty of
-  ClassPred cls tys -> do { tys' <- reifyTypes tys 
-                          ; return $ TH.ClassP (reifyName cls) tys' }
+  ClassPred cls tys -> do { tys' <- reifyTypes tys
+                          ; let { name = reifyName cls
+                                ; typ  = foldl TH.AppT (TH.ConT name) tys'
+                                }
+                          ; return typ
+                          }
   EqPred ty1 ty2    -> do { ty1' <- reifyType ty1
                           ; ty2' <- reifyType ty2
-                          ; return $ TH.EqualP ty1' ty2'
+                          ; return $ TH.AppT (TH.AppT TH.EqualityT ty1') ty2'
                           }
-  TuplePred _ -> noTH (sLit "tuple predicates") (ppr ty)
-  IrredPred _ -> noTH (sLit "irreducible predicates") (ppr ty)
+  TuplePred xs      -> do { xs' <- reifyTypes xs
+                          ; let { size = length xs'
+                                ; typ  = foldl TH.AppT (TH.TupleT size) xs'
+                                }
+                          ; return typ }
+  IrredPred _
+      | Just (ty1, ty2) <- splitAppTy_maybe ty
+        -> do { ty1' <- reifyType ty1
+              ; ty2' <- reifyType ty2
+              ; return $ TH.AppT ty1' ty2'
+              }
+      | Just (tyCon, tys) <- splitTyConApp_maybe ty
+        -> do { tys' <- reifyTypes tys
+              ; let { name = reifyName (tyConName tyCon)
+                    ; typ  = foldl TH.AppT (TH.ConT name) tys'
+                    }
+              ; return typ
+              }
+      | otherwise -> noTH (sLit "unsupported irreducible predicates") (ppr ty)
 
 
 ------------------------------
@@ -1558,4 +1579,4 @@ will appear in TH syntax like this
 
 \begin{code}
 #endif  /* GHCI */
-\end{code}
\ No newline at end of file
+\end{code}
-- 
1.8.5.3

0001-Fix-breaking-changes-due-to-issue-7021.patch

From b751cd21993de93b47285a6da80e26e341076b40 Mon Sep 17 00:00:00 2001
From: YoEight <yo.eight@gmail.com>
Date: Sat, 11 Jan 2014 13:38:18 +0100
Subject: [PATCH] Fix breaking changes due to issue #7021

---
 dph-lifted-copy/Data/Array/Parallel/Lifted/TH/Repr.hs | 19 +++++++++----------
 1 file changed, 9 insertions(+), 10 deletions(-)

diff --git a/dph-lifted-copy/Data/Array/Parallel/Lifted/TH/Repr.hs b/dph-lifted-copy/Data/Array/Parallel/Lifted/TH/Repr.hs
index 9229723..fb6b02b 100644
--- a/dph-lifted-copy/Data/Array/Parallel/Lifted/TH/Repr.hs
+++ b/dph-lifted-copy/Data/Array/Parallel/Lifted/TH/Repr.hs
@@ -88,7 +88,7 @@ normaliseTy ty
 
 
 substTy :: [(Name, Type)] -> Type -> Type
-substTy _ (ForallT _ _ _) 
+substTy _ (ForallT _ _ _)
         = error "DPH gen: can't substitute in forall ty"
 
 substTy env (VarT v)    = case lookup v env of
@@ -139,7 +139,7 @@ methodVals (ForallT (PlainTV vv : _) _ ty)
   where
     val v (VarT n) | v == n             = ScalarVal
 
-    val v (AppT (ConT c) (VarT n)) 
+    val v (AppT (ConT c) (VarT n))
         | c == ''PData && v == n        = PDataVal
         | c == ''[]    && v == n        = ListVal
 
@@ -182,7 +182,7 @@ recursiveMethod gen name avs res
     pat (PatSplit  p)     = p
     pat (CaseSplit p _ _) = p
 
-    split_arg (OtherVal,  g) 
+    split_arg (OtherVal,  g)
      = let v = mkName (g "")
        in  (PatSplit (varP v), OtherArg (varE v))
 
@@ -321,7 +321,7 @@ voidMethod void pvoid meth avs res
     result PDataVal     = varE pvoid
     result UnitVal      = conE '()
     result _            = error "DPH gen: voidMethod: no match"
-    
+
 -- --
 -- ()
 -- --
@@ -344,7 +344,7 @@ unitMethod punit meth avs res
     mkpat ScalarVal _   = (conP '() [], Nothing)
     mkpat PDataVal  _   = (conP punit [], Nothing)
 
-    mkpat ListVal   g 
+    mkpat ListVal   g
      = let xs = mkName (g "xs")
        in  (varP xs, Just $ \e -> varE 'foldr `appEs` [varE 'seq, e, varE xs])
 
@@ -367,14 +367,14 @@ wrapPRInstance :: Name -> Name -> Name -> Name -> Q [Dec]
 wrapPRInstance ty wrap unwrap pwrap
   = do
       methods <- genPR_methods (recursiveMethod (wrapGen wrap unwrap pwrap))
-      return [InstanceD [ClassP ''PA [a]]
+      return [InstanceD [ConT ''PA `AppT` a]
                         (ConT ''PR `AppT` (ConT ty `AppT` a))
                         methods]
   where
     a = VarT (mkName "a")
 
 wrapGen :: Name -> Name -> Name -> Gen
-wrapGen wrap unwrap pwrap 
+wrapGen wrap unwrap pwrap
  = Gen  { recursiveCalls = 1
         , recursiveName  = recursiveName'
         , split          = split'
@@ -437,7 +437,7 @@ instance_PR_tup :: Int -> DecQ
 instance_PR_tup arity
   = do
       methods <- genPR_methods (recursiveMethod (tupGen arity))
-      return $ InstanceD [ClassP ''PR [ty] | ty <- tys]
+      return $ InstanceD [ConT ''PR `AppT` ty | ty <- tys]
                          (ConT ''PR `AppT` (TupleT arity `mkAppTs` tys))
                          methods
   where
@@ -472,7 +472,7 @@ tupGen arity = Gen { recursiveCalls = arity
 
         mkunzip | arity == 2 = mkName "unzip"
                 | otherwise  = mkName ("unzip" ++ show arity)
-              
+
     split' _            = error "DPH Gen: tupGen/split: no match"
 
 
@@ -485,4 +485,3 @@ tupGen arity = Gen { recursiveCalls = arity
     pvs         = take arity [c : "s" | c <- ['a' ..]]
 
     tyname      = "(" ++ intercalate "," vs ++ ")"
-
-- 
1.8.5.2

0001-Fix-tests-due-to-issue-7021.patch

From 53c4cdcaaad6e52251a9c49b8006655730827a94 Mon Sep 17 00:00:00 2001
From: YoEight <yo.eight@gmail.com>
Date: Sat, 11 Jan 2014 13:47:24 +0100
Subject: [PATCH] Fix tests due to issue #7021

---
 tests/th/T7021.hs       |  7 +++++++
 tests/th/T7021a.hs      | 31 +++++++++++++++++++++++++++++++
 tests/th/T8625.stdout   |  4 ++--
 tests/th/TH_genExLib.hs |  4 ++--
 4 files changed, 42 insertions(+), 4 deletions(-)
 create mode 100644 tests/th/T7021.hs
 create mode 100644 tests/th/T7021a.hs

diff --git a/tests/th/T7021.hs b/tests/th/T7021.hs
new file mode 100644
index 0000000..31e1843
--- /dev/null
+++ b/tests/th/T7021.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE TemplateHaskell #-}
+module T7021 where
+
+import T7021a
+
+func :: a -> Int
+func = $(test)
diff --git a/tests/th/T7021a.hs b/tests/th/T7021a.hs
new file mode 100644
index 0000000..bd19133
--- /dev/null
+++ b/tests/th/T7021a.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE ConstraintKinds, TemplateHaskell, PolyKinds, TypeFamilies #-}
+
+module T7021a where
+
+import GHC.Prim
+import Language.Haskell.TH
+
+type IOable a = (Show a, Read a)
+type family ALittleSilly :: Constraint
+
+data Proxy a = Proxy
+
+foo :: IOable a => a
+foo = undefined
+
+baz :: a b => Proxy a -> b
+baz = undefined
+
+bar :: ALittleSilly  => a
+bar = undefined
+
+test :: Q Exp
+test = do
+    Just fooName <- lookupValueName "foo"
+    Just bazName <- lookupValueName "baz"
+    Just barName <- lookupValueName "bar"
+    reify fooName
+    reify bazName
+    reify barName
+    [t| (Show a, (Read a, Num a)) => a -> a |]
+    [| \_ -> 0 |]
diff --git a/tests/th/T8625.stdout b/tests/th/T8625.stdout
index a845a1e..b808abb 100644
--- a/tests/th/T8625.stdout
+++ b/tests/th/T8625.stdout
@@ -1,2 +1,2 @@
-[InstanceD [EqualP (VarT y_0) (AppT (AppT ArrowT (VarT t_1)) (VarT t_1))] (AppT (ConT :Interactive.Member) (ConT GHC.Types.Bool)) []]
-[SigD f_2 (ForallT [PlainTV y_3,PlainTV t_4] [EqualP (VarT y_3) (AppT (AppT ArrowT (VarT t_4)) (VarT t_4))] (AppT (AppT ArrowT (VarT y_3)) (VarT t_4))),FunD f_2 [Clause [VarP x_5] (NormalB (VarE x_5)) []]]
+[InstanceD [AppT (AppT EqualityT (VarT y_0)) (AppT (AppT ArrowT (VarT t_1)) (VarT t_1))] (AppT (ConT :Interactive.Member) (ConT GHC.Types.Bool)) []]
+[SigD f_2 (ForallT [PlainTV y_3,PlainTV t_4] [AppT (AppT EqualityT (VarT y_3)) (AppT (AppT ArrowT (VarT t_4)) (VarT t_4))] (AppT (AppT ArrowT (VarT y_3)) (VarT t_4))),FunD f_2 [Clause [VarP x_5] (NormalB (VarE x_5)) []]]
diff --git a/tests/th/TH_genExLib.hs b/tests/th/TH_genExLib.hs
index 02784ac..d439231 100644
--- a/tests/th/TH_genExLib.hs
+++ b/tests/th/TH_genExLib.hs
@@ -11,10 +11,10 @@ genAny decl = do { d <- decl
 	}
 
 genAnyClass :: Name -> [Dec] -> Dec
-genAnyClass name decls 
+genAnyClass name decls
   = DataD [] anyName [] [constructor] []
   where
     anyName = mkName ("Any" ++ nameBase name ++ "1111")
-    constructor = ForallC [PlainTV var_a] [ClassP name [VarT var_a]] $
+    constructor = ForallC [PlainTV var_a] [AppT (ConT name) (VarT var_a)] $
 		  NormalC anyName [(NotStrict, VarT var_a)]
     var_a = mkName "a"
-- 
1.8.5.3

0001-Make-Pred-a-type-synonym-of-Type-issue-7021.patch

From b1fb265637cbb826d213ea34d58c68f93c42ce73 Mon Sep 17 00:00:00 2001
From: YoEight <yo.eight@gmail.com>
Date: Fri, 10 Jan 2014 21:42:01 +0100
Subject: [PATCH] Make Pred a type synonym of Type (issue #7021)

In order to make any type as a Predicate in Template Haskell, as allowed by ConstraintKinds
---
 Language/Haskell/TH.hs        |  9 ++++-----
 Language/Haskell/TH/Lib.hs    | 21 ++++++++------------
 Language/Haskell/TH/Ppr.hs    | 46 ++++++++++++++++++++-----------------------
 Language/Haskell/TH/Syntax.hs | 10 ++++------
 4 files changed, 37 insertions(+), 49 deletions(-)

diff --git a/Language/Haskell/TH.hs b/Language/Haskell/TH.hs
index 2ab19bd..e9765a9 100644
--- a/Language/Haskell/TH.hs
+++ b/Language/Haskell/TH.hs
@@ -58,7 +58,7 @@ module Language.Haskell.TH(
     -- quotations (@[| |]@) and splices (@$( ... )@)
 
     -- ** Declarations
-	Dec(..), Con(..), Clause(..), 
+	Dec(..), Con(..), Clause(..),
 	Strict(..), Foreign(..), Callconv(..), Safety(..), Pragma(..),
 	Inline(..), RuleMatch(..), Phases(..), RuleBndr(..), AnnTarget(..),
 	FunDep(..), FamFlavour(..), TySynEqn(..),
@@ -68,7 +68,7 @@ module Language.Haskell.TH(
     -- ** Patterns
         Pat(..), FieldExp, FieldPat,
     -- ** Types
-        Type(..), TyVarBndr(..), TyLit(..), Kind, Cxt, Pred(..), Syntax.Role(..),
+        Type(..), TyVarBndr(..), TyLit(..), Kind, Cxt, Pred, Syntax.Role(..),
 
     -- * Library functions
     -- ** Abbreviations
@@ -105,14 +105,14 @@ module Language.Haskell.TH(
     bindS, letS, noBindS, parS,
 
     -- *** Types
-	forallT, varT, conT, appT, arrowT, listT, tupleT, sigT, litT,
+	forallT, varT, conT, appT, arrowT, equalityT, listT, tupleT, sigT, litT,
     promotedT, promotedTupleT, promotedNilT, promotedConsT,
     -- **** Type literals
     numTyLit, strTyLit,
     -- **** Strictness
 	isStrict, notStrict, strictType, varStrictType,
     -- **** Class Contexts
-    cxt, classP, equalP, normalC, recC, infixC, forallC,
+    cxt, normalC, recC, infixC, forallC,
 
     -- *** Kinds
   varK, conK, tupleK, arrowK, listK, appK, starK, constraintK,
@@ -146,4 +146,3 @@ module Language.Haskell.TH(
 import Language.Haskell.TH.Syntax as Syntax
 import Language.Haskell.TH.Lib
 import Language.Haskell.TH.Ppr
-
diff --git a/Language/Haskell/TH/Lib.hs b/Language/Haskell/TH/Lib.hs
index 2dfef30..a806f0d 100644
--- a/Language/Haskell/TH/Lib.hs
+++ b/Language/Haskell/TH/Lib.hs
@@ -464,19 +464,6 @@ tySynEqn lhs rhs =
 cxt :: [PredQ] -> CxtQ
 cxt = sequence
 
-classP :: Name -> [TypeQ] -> PredQ
-classP cla tys
-  = do
-      tys1 <- sequence tys
-      return (ClassP cla tys1)
-
-equalP :: TypeQ -> TypeQ -> PredQ
-equalP tleft tright
-  = do
-      tleft1  <- tleft
-      tright1 <- tright
-      return (EqualP tleft1 tright1)
-
 normalC :: Name -> [StrictTypeQ] -> ConQ
 normalC con strtys = liftM (NormalC con) $ sequence strtys
 
@@ -534,6 +521,14 @@ sigT t k
       t' <- t
       return $ SigT t' k
 
+equalityT :: TypeQ -> TypeQ -> TypeQ
+equalityT tleft tright
+  = do
+      tleft1  <- tleft
+      tright1 <- tright
+      let typ = AppT (AppT EqualityT tleft1) tright1
+      return typ
+
 promotedT :: Name -> TypeQ
 promotedT = return . PromotedT
 
diff --git a/Language/Haskell/TH/Ppr.hs b/Language/Haskell/TH/Ppr.hs
index 2023f3a..e237066 100644
--- a/Language/Haskell/TH/Ppr.hs
+++ b/Language/Haskell/TH/Ppr.hs
@@ -50,21 +50,21 @@ instance Ppr Info where
     ppr (TyConI d)     = ppr d
     ppr (ClassI d is)  = ppr d $$ vcat (map ppr is)
     ppr (FamilyI d is) = ppr d $$ vcat (map ppr is)
-    ppr (PrimTyConI name arity is_unlifted) 
+    ppr (PrimTyConI name arity is_unlifted)
       = text "Primitive"
 	<+> (if is_unlifted then text "unlifted" else empty)
 	<+> text "type constructor" <+> quotes (ppr name)
 	<+> parens (text "arity" <+> int arity)
-    ppr (ClassOpI v ty cls fix) 
+    ppr (ClassOpI v ty cls fix)
       = text "Class op from" <+> ppr cls <> colon <+>
         vcat [ppr_sig v ty, pprFixity v fix]
-    ppr (DataConI v ty tc fix) 
+    ppr (DataConI v ty tc fix)
       = text "Constructor from" <+> ppr tc <> colon <+>
         vcat [ppr_sig v ty, pprFixity v fix]
     ppr (TyVarI v ty)
       = text "Type variable" <+> ppr v <+> equals <+> ppr ty
-    ppr (VarI v ty mb_d fix) 
-      = vcat [ppr_sig v ty, pprFixity v fix, 
+    ppr (VarI v ty mb_d fix)
+      = vcat [ppr_sig v ty, pprFixity v fix,
               case mb_d of { Nothing -> empty; Just d -> ppr d }]
 
 ppr_sig :: Name -> Type -> Doc
@@ -95,9 +95,9 @@ pprPrefixOcc n = parensIf (isSymOcc n) (ppr n)
 
 isSymOcc :: Name -> Bool
 isSymOcc n
-  = case nameBase n of 
+  = case nameBase n of
       []    -> True  -- Empty name; weird
-      (c:_) -> isSymbolASCII c || (ord c > 0x7f && isSymbol c) 
+      (c:_) -> isSymbolASCII c || (ord c > 0x7f && isSymbol c)
                    -- c.f. OccName.startsVarSym in GHC itself
 
 isSymbolASCII :: Char -> Bool
@@ -158,7 +158,7 @@ pprExp i (DoE ss_) = parensIf (i > noPrec) $ text "do" <+> pprStms ss_
     pprStms []  = empty
     pprStms [s] = ppr s
     pprStms ss  = braces $ sep $ punctuate semi $ map ppr ss
-    
+
 pprExp _ (CompE []) = text "<<Empty CompExp>>"
 -- This will probably break with fixity declarations - would need a ';'
 pprExp _ (CompE ss) = text "[" <> ppr s
@@ -197,7 +197,7 @@ instance Ppr Match where
 pprGuarded :: Doc -> (Guard, Exp) -> Doc
 pprGuarded eqDoc (guard, expr) = case guard of
   NormalG guardExpr -> char '|' <+> ppr guardExpr <+> eqDoc <+> ppr expr
-  PatG    stmts     -> char '|' <+> vcat (punctuate comma $ map ppr stmts) $$ 
+  PatG    stmts     -> char '|' <+> vcat (punctuate comma $ map ppr stmts) $$
                          nest nestDepth (eqDoc <+> ppr expr)
 
 ------------------------------
@@ -222,14 +222,14 @@ pprLit _ (CharL c)       = text (show c)
 pprLit _ (StringL s)     = pprString s
 pprLit _ (StringPrimL s) = pprString (bytesToString s) <> char '#'
 pprLit i (RationalL rat) = parensIf (i > noPrec) $
-                           integer (numerator rat) <+> char '/' 
+                           integer (numerator rat) <+> char '/'
                               <+> integer (denominator rat)
 
 bytesToString :: [Word8] -> String
 bytesToString = map (chr . fromIntegral)
 
 pprString :: String -> Doc
--- Print newlines as newlines with Haskell string escape notation, 
+-- Print newlines as newlines with Haskell string escape notation,
 -- not as '\n'.  For other non-printables use regular escape notation.
 pprString s = vcat (map text (showMultiLineString s))
 
@@ -271,18 +271,18 @@ instance Ppr Dec where
     ppr = ppr_dec True
 
 ppr_dec :: Bool     -- declaration on the toplevel?
-        -> Dec 
+        -> Dec
         -> Doc
 ppr_dec _ (FunD f cs)   = vcat $ map (\c -> pprPrefixOcc f <+> ppr c) cs
 ppr_dec _ (ValD p r ds) = ppr p <+> pprBody True r
                           $$ where_clause ds
-ppr_dec _ (TySynD t xs rhs) 
+ppr_dec _ (TySynD t xs rhs)
   = ppr_tySyn empty t (hsep (map ppr xs)) rhs
-ppr_dec _ (DataD ctxt t xs cs decs) 
+ppr_dec _ (DataD ctxt t xs cs decs)
   = ppr_data empty ctxt t (hsep (map ppr xs)) cs decs
 ppr_dec _ (NewtypeD ctxt t xs c decs)
   = ppr_newtype empty ctxt t (sep (map ppr xs)) c decs
-ppr_dec _  (ClassD ctxt c xs fds ds) 
+ppr_dec _  (ClassD ctxt c xs fds ds)
   = text "class" <+> pprCxt ctxt <+> ppr c <+> hsep (map ppr xs) <+> ppr fds
     $$ where_clause ds
 ppr_dec _ (InstanceD ctxt i ds) = text "instance" <+> pprCxt ctxt <+> ppr i
@@ -291,7 +291,7 @@ ppr_dec _ (SigD f t)    = pprPrefixOcc f <+> text "::" <+> ppr t
 ppr_dec _ (ForeignD f)  = ppr f
 ppr_dec _ (InfixD fx n) = pprFixity n fx
 ppr_dec _ (PragmaD p)   = ppr p
-ppr_dec isTop (FamilyD flav tc tvs k) 
+ppr_dec isTop (FamilyD flav tc tvs k)
   = ppr flav <+> maybeFamily <+> ppr tc <+> hsep (map ppr tvs) <+> maybeKind
   where
     maybeFamily | isTop     = text "family"
@@ -299,12 +299,12 @@ ppr_dec isTop (FamilyD flav tc tvs k)
 
     maybeKind | (Just k') <- k = text "::" <+> ppr k'
               | otherwise      = empty
-ppr_dec isTop (DataInstD ctxt tc tys cs decs) 
+ppr_dec isTop (DataInstD ctxt tc tys cs decs)
   = ppr_data maybeInst ctxt tc (sep (map pprParendType tys)) cs decs
   where
     maybeInst | isTop     = text "instance"
               | otherwise = empty
-ppr_dec isTop (NewtypeInstD ctxt tc tys c decs) 
+ppr_dec isTop (NewtypeInstD ctxt tc tys c decs)
   = ppr_newtype maybeInst ctxt tc (sep (map pprParendType tys)) c decs
   where
     maybeInst | isTop     = text "instance"
@@ -338,7 +338,7 @@ ppr_data maybeInst ctxt t argsDoc cs decs
            else nest nestDepth
               $ text "deriving"
                 <+> parens (hsep $ punctuate comma $ map ppr decs)]
-  where 
+  where
     pref :: [Doc] -> [Doc]
     pref []     = []      -- No constructors; can't happen in H98
     pref (d:ds) = (char '=' <+> d):map (char '|' <+>) ds
@@ -496,6 +496,8 @@ instance Ppr Type where
 
 pprTyApp :: (Type, [Type]) -> Doc
 pprTyApp (ArrowT, [arg1,arg2]) = sep [pprFunArgType arg1 <+> text "->", ppr arg2]
+pprTyApp (EqualityT, [arg1, arg2]) =
+    sep [pprFunArgType arg1 <+> text "~", ppr arg2]
 pprTyApp (ListT, [arg]) = brackets (ppr arg)
 pprTyApp (TupleT n, args)
  | length args == n = parens (sep (punctuate comma (map ppr args)))
@@ -540,11 +542,6 @@ pprCxt [t] = ppr t <+> text "=>"
 pprCxt ts = parens (sep $ punctuate comma $ map ppr ts) <+> text "=>"
 
 ------------------------------
-instance Ppr Pred where
-  ppr (ClassP cla tys) = ppr cla <+> sep (map pprParendType tys)
-  ppr (EqualP ty1 ty2) = pprFunArgType ty1 <+> char '~' <+> pprFunArgType ty2
-
-------------------------------
 instance Ppr Range where
     ppr = brackets . pprRange
         where pprRange :: Range -> Doc
@@ -569,4 +566,3 @@ hashParens d = text "(# " <> d <> text " #)"
 
 quoteParens :: Doc -> Doc
 quoteParens d = text "'(" <> d <> text ")"
-
diff --git a/Language/Haskell/TH/Syntax.hs b/Language/Haskell/TH/Syntax.hs
index 3606f9d..17bb065 100644
--- a/Language/Haskell/TH/Syntax.hs
+++ b/Language/Haskell/TH/Syntax.hs
@@ -770,8 +770,8 @@ mkName str
 	-- This rather bizarre case actually happened; (.&.) is in Data.Bits
     split occ (c:rev)   = split (c:occ) rev
 
-    -- Recognises a reversed module name xA.yB.C, 
-    -- with at least one component, 
+    -- Recognises a reversed module name xA.yB.C,
+    -- with at least one component,
     -- and each component looks like a module name
     --   (i.e. non-empty, starts with capital, all alpha)
     is_rev_mod_name rev_mod_str
@@ -1346,9 +1346,7 @@ data AnnTarget = ModuleAnnotation
 
 type Cxt = [Pred]                 -- ^ @(Eq a, Ord b)@
 
-data Pred = ClassP Name [Type]    -- ^ @Eq (Int, a)@
-          | EqualP Type Type      -- ^ @F a ~ Bool@
-          deriving( Show, Eq, Data, Typeable )
+type Pred = Type
 
 data Strict = IsStrict | NotStrict | Unpacked
          deriving( Show, Eq, Data, Typeable )
@@ -1373,6 +1371,7 @@ data Type = ForallT [TyVarBndr] Cxt Type  -- ^ @forall \<vars\>. \<ctxt\> -> \<t
           | TupleT Int                    -- ^ @(,), (,,), etc.@
           | UnboxedTupleT Int             -- ^ @(#,#), (#,,#), etc.@
           | ArrowT                        -- ^ @->@
+          | EqualityT                     -- ^ @~@
           | ListT                         -- ^ @[]@
           | PromotedTupleT Int            -- ^ @'(), '(,), '(,,), etc.@
           | PromotedNilT                  -- ^ @'[]@
@@ -1453,4 +1452,3 @@ cmpEq _  = False
 thenCmp :: Ordering -> Ordering -> Ordering
 thenCmp EQ o2 = o2
 thenCmp o1 _  = o1
-
-- 
1.8.5.3