Refactor previous commit on fixing #7021.

compiler/deSugar/DsMeta.hs

@@ -767,6 +767,7 @@ repPred (HsParTy ty)
   = repLPred ty
 repPred ty
   | Just (cls, tys) <- splitHsClassTy_maybe ty
+             -- works even when cls is not a class (ConstraintKinds)
   = do
       cls1 <- lookupOcc cls
       tyco <- repNamedTyCon cls1
@@ -776,14 +777,15 @@ repPred (HsEqTy tyleft tyright)
   = do
       tyleft1  <- repLTy tyleft
       tyright1 <- repLTy tyright
-      repTequality tyleft1 tyright1
+      eq       <- repTequality
+      repTapps eq [tyleft1, tyright1]
 repPred (HsTupleTy _ lps)
   = do
       tupTy <- repTupleTyCon size
-      foldM go tupTy lps
+      tys'  <- mapM repLTy lps
+      repTapps tupTy tys'
   where
     size = length lps
-    go ty' lp = repTapp ty' =<< repLPred lp
 repPred ty
   = notHandled "Exotic predicate type" (ppr ty)
 
@@ -1818,8 +1820,8 @@ 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]
+repTequality :: DsM (Core TH.TypeQ)
+repTequality = rep2 equalityTName []
 
 repTPromotedList :: [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
 repTPromotedList []     = repPromotedNilTyCon
@@ -2715,22 +2717,22 @@ arrowTIdKey         = mkPreludeMiscIdUnique 385
 listTIdKey          = mkPreludeMiscIdUnique 386
 appTIdKey           = mkPreludeMiscIdUnique 387
 sigTIdKey           = mkPreludeMiscIdUnique 388
-equalityTIdKey      = mkPreludeMiscIdUnique 362
-litTIdKey           = mkPreludeMiscIdUnique 389
-promotedTIdKey      = mkPreludeMiscIdUnique 390
-promotedTupleTIdKey = mkPreludeMiscIdUnique 391
-promotedNilTIdKey   = mkPreludeMiscIdUnique 392
-promotedConsTIdKey  = mkPreludeMiscIdUnique 393
+equalityTIdKey      = mkPreludeMiscIdUnique 389
+litTIdKey           = mkPreludeMiscIdUnique 390
+promotedTIdKey      = mkPreludeMiscIdUnique 391
+promotedTupleTIdKey = mkPreludeMiscIdUnique 392
+promotedNilTIdKey   = mkPreludeMiscIdUnique 393
+promotedConsTIdKey  = mkPreludeMiscIdUnique 394
 
 -- data TyLit = ...
 numTyLitIdKey, strTyLitIdKey :: Unique
-numTyLitIdKey = mkPreludeMiscIdUnique 394
-strTyLitIdKey = mkPreludeMiscIdUnique 395
+numTyLitIdKey = mkPreludeMiscIdUnique 395
+strTyLitIdKey = mkPreludeMiscIdUnique 396
 
 -- data TyVarBndr = ...
 plainTVIdKey, kindedTVIdKey :: Unique
-plainTVIdKey       = mkPreludeMiscIdUnique 396
-kindedTVIdKey      = mkPreludeMiscIdUnique 397
+plainTVIdKey       = mkPreludeMiscIdUnique 397
+kindedTVIdKey      = mkPreludeMiscIdUnique 398
 
 -- data Role = ...
 nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique

compiler/typecheck/TcSplice.lhs

@@ -1426,6 +1426,7 @@ reify_tc_app tc tys
          | tc `hasKey` listTyConKey   = TH.ListT
          | tc `hasKey` nilDataConKey  = TH.PromotedNilT
          | tc `hasKey` consDataConKey = TH.PromotedConsT
+         | tc `hasKey` eqTyConKey     = TH.EqualityT
          | otherwise                  = TH.ConT (reifyName tc)
     removeKinds :: Kind -> [TypeRep.Type] -> [TypeRep.Type]
     removeKinds (FunTy k1 k2) (h:t)
@@ -1441,38 +1442,7 @@ reifyPred ty
   -- We could reify the implicit paramter as a class but it seems
   -- nicer to support them properly...
   | isIPPred ty = noTH (sLit "implicit parameters") (ppr ty)
-  | otherwise
-   = case classifyPredType ty of
-  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.AppT (TH.AppT TH.EqualityT ty1') ty2'
-                          }
-  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)
-
+  | otherwise   = reifyType ty
 
 ------------------------------
 reifyName :: NamedThing n => n -> TH.Name

testsuite/tests/th/T8625.stdout

-[InstanceD [EqualP (VarT y_0) (AppT (AppT ArrowT (VarT t_1)) (VarT t_1))] (AppT (ConT Ghci1.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 Ghci1.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)) []]]

testsuite/tests/th/all.T

@@ -318,4 +318,6 @@ test('T8577',
 test('T8633', normal, compile_and_run, [''])
 test('T8625', normal, ghci_script, ['T8625.script'])
 test('T8759', normal, compile_fail, ['-v0'])
-test('T8759a', normal, compile_fail, ['-v0'])
\ No newline at end of file
+test('T8759a', normal, compile_fail, ['-v0'])
+test('T7021',
+     extra_clean(['T7021a.hi', 'T7021a.o']), multimod_compile, ['T7021','-v0'])
\ No newline at end of file