[commit: ghc] ghc-8.0: Make okConIdOcc recognize unboxed tuples (422ed83)

[git at git.haskell.org]

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

On branch  : ghc-8.0
Link       : http://ghc.haskell.org/trac/ghc/changeset/422ed83c210e83acbd8f6b64ba725964d726f10a/ghc

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

commit 422ed83c210e83acbd8f6b64ba725964d726f10a
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date:   Mon Jul 18 13:51:53 2016 -0400

    Make okConIdOcc recognize unboxed tuples
    
    Summary:
    `okConIdOcc`, which validates that a type or constructor name is valid
    for splicing using Template Haskell, has a special case for tuples, but
    neglects to look for unboxed tuples, causing some sensible Template Haskell
    code involving unboxed tuples to be rejected.
    
    Fixes #12407.
    
    Test Plan: make test TEST=T12407
    
    Reviewers: austin, bgamari, hvr, goldfire
    
    Reviewed By: goldfire
    
    Subscribers: thomie
    
    Differential Revision: https://phabricator.haskell.org/D2410
    
    GHC Trac Issues: #12407
    
    (cherry picked from commit 1fc41d3274b5bf62f027aa6c7df57998db494938)


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

422ed83c210e83acbd8f6b64ba725964d726f10a
 compiler/basicTypes/Lexeme.hs | 21 +++++++++++++--------
 testsuite/tests/th/T12407.hs  | 17 +++++++++++++++++
 testsuite/tests/th/all.T      |  1 +
 3 files changed, 31 insertions(+), 8 deletions(-)

diff --git a/compiler/basicTypes/Lexeme.hs b/compiler/basicTypes/Lexeme.hs
index 4b1fe94..dec52cb 100644
--- a/compiler/basicTypes/Lexeme.hs
+++ b/compiler/basicTypes/Lexeme.hs
@@ -155,18 +155,23 @@ okVarSymOcc str = all okSymChar str &&
 -- starts with an acceptable letter?
 okConIdOcc :: String -> Bool
 okConIdOcc str = okIdOcc str ||
-                 is_tuple_name1 str
+                 is_tuple_name1 True  str ||
+                   -- Is it a boxed tuple...
+                 is_tuple_name1 False str
+                   -- ...or an unboxed tuple (Trac #12407)?
   where
     -- check for tuple name, starting at the beginning
-    is_tuple_name1 ('(' : rest) = is_tuple_name2 rest
-    is_tuple_name1 _            = False
+    is_tuple_name1 True  ('(' : rest)       = is_tuple_name2 True  rest
+    is_tuple_name1 False ('(' : '#' : rest) = is_tuple_name2 False rest
+    is_tuple_name1 _     _                  = False
 
     -- check for tuple tail
-    is_tuple_name2 ")"          = True
-    is_tuple_name2 (',' : rest) = is_tuple_name2 rest
-    is_tuple_name2 (ws  : rest)
-      | isSpace ws              = is_tuple_name2 rest
-    is_tuple_name2 _            = False
+    is_tuple_name2 True  ")"          = True
+    is_tuple_name2 False "#)"         = True
+    is_tuple_name2 boxed (',' : rest) = is_tuple_name2 boxed rest
+    is_tuple_name2 boxed (ws  : rest)
+      | isSpace ws                    = is_tuple_name2 boxed rest
+    is_tuple_name2 _     _            = False
 
 -- | Is this an acceptable symbolic constructor name, assuming it
 -- starts with an acceptable character?
diff --git a/testsuite/tests/th/T12407.hs b/testsuite/tests/th/T12407.hs
new file mode 100644
index 0000000..daa3e34
--- /dev/null
+++ b/testsuite/tests/th/T12407.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UnboxedTuples #-}
+module T12407 where
+
+import Language.Haskell.TH.Lib
+import Language.Haskell.TH.Syntax
+
+$(do let ubxTup = conT (unboxedTupleTypeName 2) `appT` conT ''Int
+                                                `appT` conT ''Int
+     x <- newName "x"
+     y <- newName "y"
+
+     [d| f :: $(ubxTup) -> $(ubxTup)
+         f $(conP (unboxedTupleDataName 2) [varP x, varP y])
+             = $(conE (unboxedTupleDataName 2) `appE` varE x
+                                               `appE` varE y)
+      |])
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index f502252..b43971e 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -411,3 +411,4 @@ test('T11941', normal, compile_fail, ['-v0'])
 test('T11484', normal, compile, ['-v0'])
 test('T12130', extra_clean(['T12130a.hi','T12130a.o']),
               multimod_compile, ['T12130', '-v0 ' + config.ghc_th_way_flags])
+test('T12407', omit_ways(['ghci']), compile, ['-v0'])