From c3bfc63d94272ba6be722c540d7c7f19f8bf5414 Mon Sep 17 00:00:00 2001
From: "Dr. ERDI Gergo" <gergo@erdi.hu>
Date: Sat, 21 Jun 2014 22:37:50 +0800
Subject: [PATCH] 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)
(cherry picked from commit aa3166f42361cb605e046f4a063be3f9e1f48015)
---
compiler/typecheck/TcBinds.lhs | 23 +++++++++++++------
compiler/typecheck/TcHsType.lhs | 1 -
testsuite/tests/patsyn/should_fail/T9161-1.hs | 7 ++++++
.../tests/patsyn/should_fail/T9161-1.stderr | 4 ++++
testsuite/tests/patsyn/should_fail/T9161-2.hs | 9 ++++++++
.../tests/patsyn/should_fail/T9161-2.stderr | 5 ++++
testsuite/tests/patsyn/should_fail/all.T | 2 ++
7 files changed, 43 insertions(+), 8 deletions(-)
create mode 100644 testsuite/tests/patsyn/should_fail/T9161-1.hs
create mode 100644 testsuite/tests/patsyn/should_fail/T9161-1.stderr
create mode 100644 testsuite/tests/patsyn/should_fail/T9161-2.hs
create mode 100644 testsuite/tests/patsyn/should_fail/T9161-2.stderr
diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index a15d52040b56..65ad0011aaa6 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -277,19 +277,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 e4a34d966dc4..8e1f361ad32b 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -618,7 +618,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 000000000000..c14eb542cc33
--- /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 000000000000..1f05196ebb21
--- /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 000000000000..941d23e35fb0
--- /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 000000000000..8d21be5906b9
--- /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 897808ef1d0a..bff6bdf8c247 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, [''])
--
GitLab