Fix pretty-printing of data declarations in splices
authorKrzysztof Gogolewski <krz.gogolewski@gmail.com>
Sun, 22 Jul 2018 16:58:33 +0000 (18:58 +0200)
committerBen Gamari <ben@smart-cactus.org>
Tue, 31 Jul 2018 19:53:19 +0000 (15:53 -0400)
Test Plan: validate

Reviewers: RyanGlScott, bgamari

Reviewed By: RyanGlScott

Subscribers: rwbarton, thomie, carter

GHC Trac Issues: #15365

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

(cherry picked from commit 3aa09cc5af9cacba91915c095f9652ee5ed31ec7)

compiler/hsSyn/HsDecls.hs
testsuite/tests/th/T15365.hs [new file with mode: 0644]
testsuite/tests/th/T15365.stderr [new file with mode: 0644]
testsuite/tests/th/all.T

index 12ebfad..277a6d3 100644 (file)
@@ -757,7 +757,7 @@ pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) fixity context
          , hsep (map (ppr.unLoc) varsr)]
       | otherwise = hsep [ pprPrefixOcc (unLoc thing)
                   , hsep (map (ppr.unLoc) (varl:varsr))]
-    pp_tyvars [] = ppr thing
+    pp_tyvars [] = pprPrefixOcc (unLoc thing)
 pp_vanilla_decl_head _ (XLHsQTyVars x) _ _ = ppr x
 
 pprTyClDeclFlavour :: TyClDecl (GhcPass p) -> SDoc
@@ -2325,7 +2325,7 @@ type instance XXRoleAnnotDecl (GhcPass _) = NoExt
 instance (p ~ GhcPass pass, OutputableBndr (IdP p))
        => Outputable (RoleAnnotDecl p) where
   ppr (RoleAnnotDecl _ ltycon roles)
-    = text "type role" <+> ppr ltycon <+>
+    = text "type role" <+> pprPrefixOcc (unLoc ltycon) <+>
       hsep (map (pp_role . unLoc) roles)
     where
       pp_role Nothing  = underscore
diff --git a/testsuite/tests/th/T15365.hs b/testsuite/tests/th/T15365.hs
new file mode 100644 (file)
index 0000000..00ff2e6
--- /dev/null
@@ -0,0 +1,31 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE RoleAnnotations #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+module T15365 where
+
+$([d| type (|||) = Either
+
+      (&&&) :: Bool -> Bool -> Bool
+      (&&&) = (&&)
+
+      type role (***)
+      data (***)
+
+      class (???)
+      instance (???)
+
+      data family ($$$)
+      data instance ($$$)
+
+      type family (^^^)
+      type instance (^^^) = Int
+
+      type family (###) where
+        (###) = Int
+
+      pattern (:!!!) :: Bool
+      pattern (:!!!) = True
+    |])
diff --git a/testsuite/tests/th/T15365.stderr b/testsuite/tests/th/T15365.stderr
new file mode 100644 (file)
index 0000000..3c85950
--- /dev/null
@@ -0,0 +1,33 @@
+T15365.hs:(9,3)-(31,6): Splicing declarations
+    [d| (&&&) :: Bool -> Bool -> Bool
+        (&&&) = (&&)
+        pattern (:!!!) :: Bool
+        pattern (:!!!) = True
+        
+        type (|||) = Either
+        data (***)
+        class (???)
+        data family ($$$)
+        type family (^^^)
+        type family (###) where
+          (###) = Int
+        
+        instance (???)
+        data instance ($$$)
+        type instance (^^^) = Int |]
+  ======>
+    type (|||) = Either
+    (&&&) :: Bool -> Bool -> Bool
+    (&&&) = (&&)
+    type role (***)
+    data (***)
+    class (???)
+    instance (???)
+    data family ($$$)
+    data instance ($$$)
+    type family (^^^)
+    type instance (^^^) = Int
+    type family (###) where
+      (###) = Int
+    pattern (:!!!) :: Bool
+    pattern (:!!!) = True
index b3d53ac..f6656c4 100644 (file)
@@ -418,3 +418,4 @@ test('T15243', normal, compile, ['-dsuppress-uniques'])
 test('T15331', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T15324', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T15321', normal, compile_fail, [''])
+test('T15365', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])