[commit: ghc] master: Fix #8807. (98b6756)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/98b6756b09194352aa2ccfbb624992150a7a3520/ghc

>---------------------------------------------------------------

commit 98b6756b09194352aa2ccfbb624992150a7a3520
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date:   Wed Feb 26 10:17:45 2014 -0500

    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.


>---------------------------------------------------------------

98b6756b09194352aa2ccfbb624992150a7a3520
 compiler/deSugar/DsMeta.hs  |   40 +++++++---------------------------------
 testsuite/tests/th/T8807.hs |    8 ++++++++
 testsuite/tests/th/all.T    |    1 +
 3 files changed, 16 insertions(+), 33 deletions(-)

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 7fe77c5..6df92af 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 0000000..3090123
--- /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 e57b394..e7db161 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -321,3 +321,4 @@ test('T8759', normal, compile_fail, ['-v0'])
 test('T8759a', normal, compile_fail, ['-v0'])
 test('T7021',
      extra_clean(['T7021a.hi', 'T7021a.o']), multimod_compile, ['T7021','-v0'])
+test('T8807', normal, compile, ['-v0'])