Fix Template Haskell's handling of infix GADT constructors

This is the second (and hopefully last) fix needed to make TH handle
GADTs properly (after D1465). This Diff addresses some issues with infix
GADT constructors, specifically:

* Before, you could not determine if a GADT constructor was declared
  infix because TH did not give you the ability to determine if there is
  a //user-specified// fixity declaration for that constructor. The
  return type of `reifyFixity` was changed to `Maybe Fixity` so that it
  yields `Just` the fixity is there is a fixity declaration, and
  `Nothing` otherwise (indicating it has `defaultFixity`).
* `DsMeta`/`Convert` were changed so that infix GADT constructors are
  turned into `GadtC`, not `InfixC` (which should be reserved for
  Haskell98 datatype declarations).
* Some minor fixes to the TH pretty-printer so that infix GADT
  constructors will be parenthesized in GADT signatures.

Fixes #11345.

Test Plan: ./validate

Reviewers: goldfire, austin, bgamari, jstolarek

Reviewed By: jstolarek

Subscribers: thomie

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

GHC Trac Issues: #11345

4 files changed, 72 insertions, 16 deletions

diff --git a/testsuite/tests/th/T10704.stdout b/testsuite/tests/th/T10704.stdout
index 976c6a4faa..99b87e28a1 100644
--- a/testsuite/tests/th/T10704.stdout
+++ b/testsuite/tests/th/T10704.stdout
@@ -1,16 +1,16 @@
-Fixity 0 InfixR
-Fixity 9 InfixL
-Fixity 9 InfixL
-Fixity 6 InfixL
-Fixity 9 InfixL
-Fixity 9 InfixL
-Fixity 9 InfixL
-Fixity 9 InfixL
-Fixity 0 InfixR
-Fixity 0 InfixR
-Fixity 1 InfixL
-Fixity 2 InfixL
-Fixity 3 InfixN
-Fixity 4 InfixN
-Fixity 5 InfixR
-Fixity 6 InfixR
+Just (Fixity 0 InfixR)
+Nothing
+Nothing
+Just (Fixity 6 InfixL)
+Nothing
+Nothing
+Nothing
+Nothing
+Just (Fixity 0 InfixR)
+Just (Fixity 0 InfixR)
+Just (Fixity 1 InfixL)
+Just (Fixity 2 InfixL)
+Just (Fixity 3 InfixN)
+Just (Fixity 4 InfixN)
+Just (Fixity 5 InfixR)
+Just (Fixity 6 InfixR)
diff --git a/testsuite/tests/th/T11345.hs b/testsuite/tests/th/T11345.hs
new file mode 100644
index 0000000000..39dd8adc08
--- /dev/null
+++ b/testsuite/tests/th/T11345.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Main (main) where
+
+import Language.Haskell.TH
+
+infixr 7 :***:
+data GADT a where
+  Prefix  :: Int -> Int -> GADT Int
+  (:***:) :: Int -> Int -> GADT Int
+
+$(do gadtName   <- newName "GADT2"
+     prefixName <- newName "Prefix2"
+     infixName  <- newName ":****:"
+     a          <- newName "a"
+     return [ DataD [] gadtName [KindedTV a StarT] Nothing
+              [ GadtC [prefixName]
+                [ (Bang NoSourceUnpackedness NoSourceStrictness,ConT ''Int)
+                , (Bang NoSourceUnpackedness NoSourceStrictness,ConT ''Int)
+                ] (AppT (ConT gadtName) (ConT ''Int))
+              , GadtC [infixName]
+                [ (Bang NoSourceUnpackedness NoSourceStrictness,ConT ''Int)
+                , (Bang NoSourceUnpackedness NoSourceStrictness,ConT ''Int)
+                ] (AppT (ConT gadtName) (ConT ''Int))
+              ] []
+            , InfixD (Fixity 7 InfixR) infixName
+            ])
+
+$(return [])
+
+deriving instance Show (GADT2 a)
+
+main :: IO ()
+main = do
+  -- Verify that infix GADT constructors reify correctly
+  putStrLn $(reify ''GADT   >>= stringE . pprint)
+  putStrLn $(reify '(:***:) >>= stringE . pprint)
+  -- Verify that reifyFixity returns something with (:***:)
+  -- (but not with Prefix, since it has no fixity declaration)
+  putStrLn $(reifyFixity 'Prefix  >>= stringE . show)
+  putStrLn $(reifyFixity '(:***:) >>= stringE . show)
+  -- Verify that spliced-in GADT infix constructors are actually infix
+  print (1 :****: 4)
diff --git a/testsuite/tests/th/T11345.stdout b/testsuite/tests/th/T11345.stdout
new file mode 100644
index 0000000000..1230c63897
--- /dev/null
+++ b/testsuite/tests/th/T11345.stdout
@@ -0,0 +1,10 @@
+data Main.GADT (a_0 :: *) where
+    Main.Prefix :: GHC.Types.Int ->
+                   GHC.Types.Int -> Main.GADT GHC.Types.Int
+    (Main.:***:) :: GHC.Types.Int ->
+                    GHC.Types.Int -> Main.GADT GHC.Types.Int
+Constructor from Main.GADT: (Main.:***:) :: GHC.Types.Int ->
+                                            GHC.Types.Int -> Main.GADT GHC.Types.Int
+Nothing
+Just (Fixity 7 InfixR)
+1 :****: 4
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 55cbbee327..b007bb3b82 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -394,5 +394,6 @@ test('T10819',
      ['T10819.hs', '-v0 ' + config.ghc_th_way_flags])
 test('T10820', normal, compile_and_run, ['-v0'])
 test('T11341', normal, compile, ['-v0 -dsuppress-uniques'])
+test('T11345', normal, compile_and_run, ['-v0 -dsuppress-uniques'])
 
 test('TH_finalizer', normal, compile, ['-v0'])