From 43f63a6b07b183490f17f37d88aa68d00bf49445 Mon Sep 17 00:00:00 2001
From: "HE, Tao" <sighingnow@gmail.com>
Date: Wed, 31 Jan 2018 21:40:03 -0500
Subject: [PATCH] UnboxedTuples can't be used as constraints
Fixes #14740.
Test Plan: make test TEST="14740"
Reviewers: bgamari, simonpj
Reviewed By: simonpj
Subscribers: simonpj, rwbarton, thomie, carter
GHC Trac Issues: #14740
Differential Revision: https://phabricator.haskell.org/D4359
(cherry picked from commit ced9fbd3913e1316498961bc389bfb1e141221a1)
---
compiler/parser/RdrHsSyn.hs | 13 ++++++++++++-
testsuite/tests/parser/should_fail/T14740.hs | 6 ++++++
testsuite/tests/parser/should_fail/T14740.stderr | 4 ++++
testsuite/tests/parser/should_fail/all.T | 1 +
4 files changed, 23 insertions(+), 1 deletion(-)
create mode 100644 testsuite/tests/parser/should_fail/T14740.hs
create mode 100644 testsuite/tests/parser/should_fail/T14740.stderr
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 119c5c6c8484..c71841a09d80 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -779,11 +779,22 @@ checkTyClHdr is_cls ty
= parseErrorSDoc l (text "Malformed head of type or class declaration:"
<+> ppr ty)
+-- | Validate the context constraints and break up a context into a list
+-- of predicates.
+--
+-- @
+-- (Eq a, Ord b) --> [Eq a, Ord b]
+-- Eq a --> [Eq a]
+-- (Eq a) --> [Eq a]
+-- (((Eq a))) --> [Eq a]
+-- @
checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs)
checkContext (L l orig_t)
= check [] (L l orig_t)
where
- check anns (L lp (HsTupleTy _ ts)) -- (Eq a, Ord b) shows up as a tuple type
+ check anns (L lp (HsTupleTy HsBoxedOrConstraintTuple ts))
+ -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can
+ -- be used as context constraints.
= return (anns ++ mkParensApiAnn lp,L l ts) -- Ditto ()
-- don't let HsAppsTy get in the way
diff --git a/testsuite/tests/parser/should_fail/T14740.hs b/testsuite/tests/parser/should_fail/T14740.hs
new file mode 100644
index 000000000000..b56687f05192
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T14740.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE UnboxedTuples #-}
+
+module T14740 where
+
+x :: ((##)) => ()
+x = ()
diff --git a/testsuite/tests/parser/should_fail/T14740.stderr b/testsuite/tests/parser/should_fail/T14740.stderr
new file mode 100644
index 000000000000..8827873e25ef
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T14740.stderr
@@ -0,0 +1,4 @@
+
+T14740.hs:5:7:
+ Expecting a lifted type, but ‘(# #)’ is unlifted
+ In the type signature: x :: ((# #)) => ()
diff --git a/testsuite/tests/parser/should_fail/all.T b/testsuite/tests/parser/should_fail/all.T
index 503cab3bcb60..28c586e804c0 100644
--- a/testsuite/tests/parser/should_fail/all.T
+++ b/testsuite/tests/parser/should_fail/all.T
@@ -103,3 +103,4 @@ test('T8501b', normal, compile_fail, [''])
test('T8501c', normal, compile_fail, [''])
test('T12610', normal, compile_fail, [''])
test('InfixAppPatErr', normal, compile_fail, [''])
+test('T14740', normal, compile_fail, [''])
--
GitLab