Turn a TH Name for built-in syntax into an unqualified RdrName
authorChaitanya Koparkar <ckoparkar@gmail.com>
Mon, 19 Mar 2018 16:04:03 +0000 (12:04 -0400)
committerBen Gamari <ben@smart-cactus.org>
Mon, 19 Mar 2018 16:05:12 +0000 (12:05 -0400)
Previously, the Renamer would turn any fully qualified Template Haskell
name into a corresponding fully qualified `RdrName`. But this is not
what we want for built-in syntax, as it produces unnecessarily qualified
names (eg. GHC.Types.[], GHC.Tuple.(,) etc.).

Test Plan: ./validate

Reviewers: RyanGlScott, bgamari, goldfire

Reviewed By: RyanGlScott, bgamari

Subscribers: rwbarton, thomie, carter

GHC Trac Issues: #13776

Differential Revision: https://phabricator.haskell.org/D4506

compiler/hsSyn/Convert.hs
testsuite/tests/th/T13776.hs [new file with mode: 0644]
testsuite/tests/th/T13776.stderr [new file with mode: 0644]
testsuite/tests/th/T3319.stderr
testsuite/tests/th/T5700.stderr
testsuite/tests/th/TH_foreignInterruptible.stderr
testsuite/tests/th/all.T

index 531f146..6440758 100644 (file)
@@ -1625,8 +1625,14 @@ thRdrName loc ctxt_ns th_occ th_name
     occ :: OccName.OccName
     occ = mk_occ ctxt_ns th_occ
 
+-- Return an unqualified exact RdrName if we're dealing with built-in syntax.
+-- See Trac #13776.
 thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
-thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)
+thOrigRdrName occ th_ns pkg mod =
+  let occ' = mk_occ (mk_ghc_ns th_ns) occ
+  in case isBuiltInOcc_maybe occ' of
+       Just name -> nameRdrName name
+       Nothing   -> (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! occ'
 
 thRdrNameGuesses :: TH.Name -> [RdrName]
 thRdrNameGuesses (TH.Name occ flavour)
diff --git a/testsuite/tests/th/T13776.hs b/testsuite/tests/th/T13776.hs
new file mode 100644 (file)
index 0000000..6082825
--- /dev/null
@@ -0,0 +1,23 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module T13776 where
+
+import Language.Haskell.TH
+
+spliceTy1 :: $(conT ''(,) `appT` conT ''Int `appT` conT ''Int)
+spliceTy1 = (1,2)
+
+spliceTy2 :: $(conT ''[] `appT` conT ''Int)
+spliceTy2 = []
+
+spliceExp1 :: (Int, Int)
+spliceExp1 = $(conE '(,) `appE` litE (integerL 1) `appE` litE (integerL 1))
+
+spliceExp2 :: [Int]
+spliceExp2 = $(conE '[])
+
+splicePat1 :: (Int, Int) -> ()
+splicePat1 $(conP '(,) [litP (integerL 1), litP (integerL 1)]) = ()
+
+splicePat2 :: [Int] -> ()
+splicePat2 $(conP '[] []) = ()
diff --git a/testsuite/tests/th/T13776.stderr b/testsuite/tests/th/T13776.stderr
new file mode 100644 (file)
index 0000000..485dc64
--- /dev/null
@@ -0,0 +1,14 @@
+T13776.hs:10:16-42: Splicing type
+    conT ''[] `appT` conT ''Int ======> [] Int
+T13776.hs:7:16-61: Splicing type
+    conT ''(,) `appT` conT ''Int `appT` conT ''Int ======> (,) Int Int
+T13776.hs:14:16-74: Splicing expression
+    conE '(,) `appE` litE (integerL 1) `appE` litE (integerL 1)
+  ======>
+    ((,) 1) 1
+T13776.hs:17:16-23: Splicing expression
+    conE '[] ======> []
+T13776.hs:20:14-61: Splicing pattern
+    conP '(,) [litP (integerL 1), litP (integerL 1)] ======> (,) 1 1
+T13776.hs:23:14-24: Splicing pattern
+    conP '[] [] ======> []
index 44ec90f..b88b10f 100644 (file)
@@ -4,4 +4,4 @@ T3319.hs:8:3-93: Splicing declarations
          (ImportF
             CCall Unsafe "&" (mkName "foo") (AppT (ConT ''Ptr) (ConT ''())))]
   ======>
-    foreign import ccall unsafe "&" foo :: Ptr GHC.Tuple.()
+    foreign import ccall unsafe "&" foo :: Ptr ()
index 729a366..3564b8c 100644 (file)
@@ -3,4 +3,4 @@ T5700.hs:8:3-9: Splicing declarations
   ======>
     instance C D where
       {-# INLINE inlinable #-}
-      inlinable _ = GHC.Tuple.()
+      inlinable _ = ()
index 7131eee..4afc38a 100644 (file)
@@ -8,4 +8,4 @@ TH_foreignInterruptible.hs:8:3-100: Splicing declarations
             (mkName "foo")
             (AppT (ConT ''Ptr) (ConT ''())))]
   ======>
-    foreign import ccall interruptible "&" foo :: Ptr GHC.Tuple.()
+    foreign import ccall interruptible "&" foo :: Ptr ()
index e9f2838..b51059c 100644 (file)
@@ -403,5 +403,6 @@ test('T14838', [], multimod_compile,
      ['T14838.hs', '-v0 -Wincomplete-patterns ' + config.ghc_th_way_flags])
 test('T14817', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T14843', normal, compile, ['-v0'])
+test('T13776', normal, compile, ['-ddump-splices -v0'])
 test('T14888', normal, compile,
     ['-v0 -ddump-splices -dsuppress-uniques ' + config.ghc_th_way_flags])