[commit: ghc] master: Add fake entries into the global kind environment for pattern synonyms. (aa3166f)

[git at git.haskell.org]

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

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

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

commit aa3166f42361cb605e046f4a063be3f9e1f48015
Author: Dr. ERDI Gergo <gergo at erdi.hu>
Date:   Sat Jun 21 22:37:50 2014 +0800

    Add fake entries into the global kind environment for pattern synonyms.
    
    This is needed to give meaningful error messages (instead of internal
    panics) when a program tries to lift a pattern synonym into a kind.
    (fixes T9161)


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

aa3166f42361cb605e046f4a063be3f9e1f48015
 compiler/typecheck/TcBinds.lhs                    | 23 ++++++++++++++++-------
 compiler/typecheck/TcHsType.lhs                   |  1 -
 testsuite/tests/patsyn/should_fail/T9161-1.hs     |  7 +++++++
 testsuite/tests/patsyn/should_fail/T9161-1.stderr |  4 ++++
 testsuite/tests/patsyn/should_fail/T9161-2.hs     |  9 +++++++++
 testsuite/tests/patsyn/should_fail/T9161-2.stderr |  5 +++++
 testsuite/tests/patsyn/should_fail/all.T          |  2 ++
 7 files changed, 43 insertions(+), 8 deletions(-)

diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index 516d4fc..273ef82 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -281,19 +281,28 @@ tcValBinds :: TopLevelFlag
            -> TcM ([(RecFlag, LHsBinds TcId)], thing) 
 
 tcValBinds top_lvl binds sigs thing_inside
-  = do  {       -- Typecheck the signature
-          (poly_ids, sig_fn) <- tcTySigs sigs
+  = do  {       -- Add fake entries for pattern synonyms so that
+                -- precise error messages can be generated when
+                -- trying to use a pattern synonym as a kind
+          traceTc "Fake lifted patsyns:" (vcat (map ppr patsyns))
+                -- Typecheck the signature
+        ; (poly_ids, sig_fn) <- tcExtendKindEnv2 [(patsyn, fakePatSynCon) | patsyn <- patsyns] $
+                                tcTySigs sigs
 
         ; let prag_fn = mkPragFun sigs (foldr (unionBags . snd) emptyBag binds)
 
                 -- Extend the envt right away with all 
                 -- the Ids declared with type signatures
                 -- Use tcExtendIdEnv2 to avoid extending the TcIdBinder stack
-        ; (binds', thing) <- tcExtendIdEnv2 [(idName id, id) | id <- poly_ids] $
-                             tcBindGroups top_lvl sig_fn prag_fn 
-                                          binds thing_inside
-
-        ; return (binds', thing) }
+        ; tcExtendIdEnv2 [(idName id, id) | id <- poly_ids] $
+            tcBindGroups top_lvl sig_fn prag_fn
+                         binds thing_inside }
+  where
+    patsyns = [ name
+              | (_, lbinds) <- binds
+              , L _ (PatSynBind{ patsyn_id = L _ name }) <- bagToList lbinds
+              ]
+    fakePatSynCon = AGlobal $ AConLike $ PatSynCon $ panic "fakePatSynCon"
 
 ------------------------
 tcBindGroups :: TopLevelFlag -> TcSigFun -> PragFun
diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index 59aafea..eb3dd32 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -625,7 +625,6 @@ tcTyVar :: Name -> TcM (TcType, TcKind)
 tcTyVar name         -- Could be a tyvar, a tycon, or a datacon
   = do { traceTc "lk1" (ppr name)
        ; thing <- tcLookup name
-       ; traceTc "lk2" (ppr name <+> ppr thing)
        ; case thing of
            ATyVar _ tv 
               | isKindVar tv
diff --git a/testsuite/tests/patsyn/should_fail/T9161-1.hs b/testsuite/tests/patsyn/should_fail/T9161-1.hs
new file mode 100644
index 0000000..c14eb54
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/T9161-1.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE DataKinds #-}
+
+pattern PATTERN = ()
+
+wrongLift :: PATTERN
+wrongLift = undefined
diff --git a/testsuite/tests/patsyn/should_fail/T9161-1.stderr b/testsuite/tests/patsyn/should_fail/T9161-1.stderr
new file mode 100644
index 0000000..1f05196
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/T9161-1.stderr
@@ -0,0 +1,4 @@
+
+T9161-1.hs:6:14:
+    Pattern synonym ‘PATTERN’ used as a type
+    In the type signature for ‘wrongLift’: wrongLift :: PATTERN
diff --git a/testsuite/tests/patsyn/should_fail/T9161-2.hs b/testsuite/tests/patsyn/should_fail/T9161-2.hs
new file mode 100644
index 0000000..941d23e
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/T9161-2.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE DataKinds, KindSignatures, PolyKinds #-}
+
+pattern PATTERN = ()
+
+data Proxy (tag :: k) (a :: *)
+
+wrongLift :: Proxy PATTERN ()
+wrongLift = undefined
diff --git a/testsuite/tests/patsyn/should_fail/T9161-2.stderr b/testsuite/tests/patsyn/should_fail/T9161-2.stderr
new file mode 100644
index 0000000..8d21be5
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/T9161-2.stderr
@@ -0,0 +1,5 @@
+
+T9161-2.hs:8:20:
+    Pattern synonym ‘PATTERN’ used as a type
+    In the type signature for ‘wrongLift’:
+      wrongLift :: Proxy PATTERN ()
diff --git a/testsuite/tests/patsyn/should_fail/all.T b/testsuite/tests/patsyn/should_fail/all.T
index 897808e..bff6bdf 100644
--- a/testsuite/tests/patsyn/should_fail/all.T
+++ b/testsuite/tests/patsyn/should_fail/all.T
@@ -4,3 +4,5 @@ test('unidir', normal, compile_fail, [''])
 test('local', normal, compile_fail, [''])
 test('T8961', normal, multimod_compile_fail, ['T8961',''])
 test('as-pattern', normal, compile_fail, [''])
+test('T9161-1', normal, compile_fail, [''])
+test('T9161-2', normal, compile_fail, [''])