[commit: ghc] master: Fix a name-space problem with promotion (c1b4b76)

[git at git.haskell.org]

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

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

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

commit c1b4b76931a58c59e5b269477e38db659cf7aea8
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Fri Nov 25 14:31:33 2016 +0000

    Fix a name-space problem with promotion
    
    Trac #12686 showed that we were allowing a term variable into
    a type, by promotion.  I chose to squash this in the renamer.


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

c1b4b76931a58c59e5b269477e38db659cf7aea8
 compiler/rename/RnEnv.hs                         | 26 +++++++++++++++++++++++-
 testsuite/tests/rename/should_fail/T12686.hs     | 13 ++++++++++++
 testsuite/tests/rename/should_fail/T12686.stderr |  4 ++++
 testsuite/tests/rename/should_fail/all.T         |  1 +
 4 files changed, 43 insertions(+), 1 deletion(-)

diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs
index 056f25c..801bc27 100644
--- a/compiler/rename/RnEnv.hs
+++ b/compiler/rename/RnEnv.hs
@@ -697,6 +697,9 @@ lookupOccRn rdr_name
 lookupKindOccRn :: RdrName -> RnM Name
 -- Looking up a name occurring in a kind
 lookupKindOccRn rdr_name
+  | isVarOcc (rdrNameOcc rdr_name)  -- See Note [Promoted variables in types]
+  = badVarInType rdr_name
+  | otherwise
   = do { typeintype <- xoptM LangExt.TypeInType
        ; if | typeintype           -> lookupTypeOccRn rdr_name
       -- With -XNoTypeInType, treat any usage of * in kinds as in scope
@@ -709,6 +712,9 @@ lookupKindOccRn rdr_name
 lookupTypeOccRn :: RdrName -> RnM Name
 -- see Note [Demotion]
 lookupTypeOccRn rdr_name
+  | isVarOcc (rdrNameOcc rdr_name)  -- See Note [Promoted variables in types]
+  = badVarInType rdr_name
+  | otherwise
   = do { mb_name <- lookupOccRn_maybe rdr_name
        ; case mb_name of {
              Just name -> return name ;
@@ -758,7 +764,25 @@ is_star, is_uni_star :: RdrName -> Bool
 is_star     = (fsLit "*" ==) . occNameFS . rdrNameOcc
 is_uni_star = (fsLit "★" ==) . occNameFS . rdrNameOcc
 
-{-
+badVarInType :: RdrName -> RnM Name
+badVarInType rdr_name
+  = do { addErr (text "Illegal promoted term variable in a type:"
+                 <+> ppr rdr_name)
+       ; return (mkUnboundNameRdr rdr_name) }
+
+{- Note [Promoted variables in types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this (Trac #12686):
+   x = True
+   data Bad = Bad 'x
+
+The parser treats the quote in 'x as saying "use the term
+namespace", so we'll get (Bad x{v}), with 'x' in the
+VarName namespace.  If we don't test for this, the renamer
+will happily rename it to the x bound at top level, and then
+the typecheck falls over because it doesn't have 'x' in scope
+when kind-checking.
+
 Note [Demotion]
 ~~~~~~~~~~~~~~~
 When the user writes:
diff --git a/testsuite/tests/rename/should_fail/T12686.hs b/testsuite/tests/rename/should_fail/T12686.hs
new file mode 100644
index 0000000..5d652f9
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/T12686.hs
@@ -0,0 +1,13 @@
+module T12686 where
+
+import Data.Proxy
+
+x = True
+
+data Bad = Bad 'x
+-- The 'x should be rejeted in a civilised way
+
+data AlsoBad = AlsoBad {
+  a :: Int,
+  b :: Either Int 'a }
+-- Ditto 'a here
diff --git a/testsuite/tests/rename/should_fail/T12686.stderr b/testsuite/tests/rename/should_fail/T12686.stderr
new file mode 100644
index 0000000..24acc9c
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/T12686.stderr
@@ -0,0 +1,4 @@
+
+T12686.hs:7:16: error: Illegal promoted term variable in a type: x
+
+T12686.hs:12:19: error: Illegal promoted term variable in a type: a
diff --git a/testsuite/tests/rename/should_fail/all.T b/testsuite/tests/rename/should_fail/all.T
index f956bde..b8c1ac5 100644
--- a/testsuite/tests/rename/should_fail/all.T
+++ b/testsuite/tests/rename/should_fail/all.T
@@ -141,3 +141,4 @@ test('T11071a', normal, compile_fail, [''])
 test('T11663', normal, compile_fail, [''])
 test('T12229', normal, compile, [''])
 test('T12681', normal, multimod_compile_fail, ['T12681','-v0'])
+test('T12686', normal, compile_fail, [''])