Fix #8807.

It turns out that the enhanced repPred function in DsMeta assumed
that the head of any constraint would be a tycon. This assumption
is false. Happily, the solution involved *deleting* code. I
just removed repPred in favor of repTy, and added the HsEqTy case
to repTy, where it should be anyway.

3 files changed, 17 insertions, 34 deletions

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 7fe77c5d2b..6df92af517 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -754,41 +754,9 @@ repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
 repLContext (L _ ctxt) = repContext ctxt
 
 repContext :: HsContext Name -> DsM (Core TH.CxtQ)
-repContext ctxt = do preds <- repList predQTyConName repLPred ctxt
+repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt
                      repCtxt preds
 
--- represent a type predicate
---
-repLPred :: LHsType Name -> DsM (Core TH.PredQ)
-repLPred (L _ p) = repPred p
-
-repPred :: HsType Name -> DsM (Core TH.PredQ)
-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
-      tys' <- mapM repLTy tys
-      repTapps tyco tys'
-repPred (HsEqTy tyleft tyright)
-  = do
-      tyleft1  <- repLTy tyleft
-      tyright1 <- repLTy tyright
-      eq       <- repTequality
-      repTapps eq [tyleft1, tyright1]
-repPred (HsTupleTy _ lps)
-  = do
-      tupTy <- repTupleTyCon size
-      tys'  <- mapM repLTy lps
-      repTapps tupTy tys'
-  where
-    size = length lps
-repPred ty
-  = notHandled "Exotic predicate type" (ppr ty)
-
 -- yield the representation of a list of types
 --
 repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
@@ -843,6 +811,11 @@ repTy (HsTupleTy _ tys)     = do tys1 <- repLTys tys
 repTy (HsOpTy ty1 (_, n) ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
                                    `nlHsAppTy` ty2)
 repTy (HsParTy t)           = repLTy t
+repTy (HsEqTy t1 t2) = do
+                         t1' <- repLTy t1
+                         t2' <- repLTy t2
+                         eq  <- repTequality
+                         repTapps eq [t1', t2']
 repTy (HsKindSig t k)       = do
                                 t1 <- repLTy t
                                 k1 <- repLKind k
@@ -858,6 +831,7 @@ repTy (HsExplicitTupleTy _ tys) = do
 repTy (HsTyLit lit) = do
                         lit' <- repTyLit lit
                         repTLit lit'
+                          
 repTy ty                      = notHandled "Exotic form of type" (ppr ty)
 
 repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)
diff --git a/testsuite/tests/th/T8807.hs b/testsuite/tests/th/T8807.hs
new file mode 100644
index 0000000000..3090123f95
--- /dev/null
+++ b/testsuite/tests/th/T8807.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE ConstraintKinds #-}
+
+module T8807 where
+
+import Data.Proxy
+
+foo :: $( [t| a b => Proxy a -> b -> b |] )
+foo = undefined
\ No newline at end of file
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index e57b394979..e7db161056 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -320,4 +320,5 @@ test('T8625', normal, ghci_script, ['T8625.script'])
 test('T8759', normal, compile_fail, ['-v0'])
 test('T8759a', normal, compile_fail, ['-v0'])
 test('T7021',
-     extra_clean(['T7021a.hi', 'T7021a.o']), multimod_compile, ['T7021','-v0'])
\ No newline at end of file
+     extra_clean(['T7021a.hi', 'T7021a.o']), multimod_compile, ['T7021','-v0'])
+test('T8807', normal, compile, ['-v0'])