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

10 files changed, 130 insertions, 33 deletions

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 0d8df6f29b..f0f5f1b44d 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -1992,8 +1992,10 @@ repConstr (InfixCon st1 st2) Nothing [con]
          arg2 <- repBangTy st2
          rep2 infixCName [unC arg1, unC con, unC arg2]
 
-repConstr (InfixCon {}) (Just _) _ = panic "repConstr: infix GADT constructor?"
-repConstr _ _ _                    = panic "repConstr: invariant violated"
+repConstr (InfixCon {}) (Just _) _ =
+    panic "repConstr: infix GADT constructor should be in a PrefixCon"
+repConstr _ _ _ =
+    panic "repConstr: invariant violated"
 
 ------------ Types -------------------
 
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index d24de8bae0..86bdbde4e8 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -1412,7 +1412,10 @@ reifyDataCon isGadtDataCon tys dc
                   ; return $ TH.RecGadtC [name]
                                      (zip3 (map (reifyName . flSelector) fields)
                                       dcdBangs r_arg_tys) res_ty }
-              | dataConIsInfix dc ->
+                -- We need to check not isGadtDataCon here because GADT
+                -- constructors can be declared infix.
+                -- See Note [Infix GADT constructors] in TcTyClsDecls.
+              | dataConIsInfix dc && not isGadtDataCon ->
                   ASSERT( length arg_tys == 2 )
                   return $ TH.InfixC (s1,r_a1) name (s2,r_a2)
               | isGadtDataCon -> do
@@ -1805,10 +1808,28 @@ reifySelector id tc
       Nothing -> pprPanic "reifySelector: missing field" (ppr id $$ ppr tc)
 
 ------------------------------
-reifyFixity :: Name -> TcM TH.Fixity
+reifyFixity :: Name -> TcM (Maybe TH.Fixity)
 reifyFixity name
-  = do  { fix <- lookupFixityRn name
-        ; return (conv_fix fix) }
+  = do { -- Repeat much of lookupFixityRn, because if we don't find a
+         -- user-supplied fixity declaration, we want to return Nothing
+         -- instead of defaultFixity
+       ; env <- getFixityEnv
+       ; case lookupNameEnv env name of
+              Just (FixItem _ fix) -> return (Just (conv_fix fix))
+              Nothing ->
+                do { this_mod <- getModule
+                   ; if nameIsLocalOrFrom this_mod name
+                        then return Nothing
+                        else
+                          -- Do NOT use mi_fix_fn to look up the fixity,
+                          -- because if there is a cache miss, it will return
+                          -- defaultFixity, which we want to avoid
+                          do { let doc = ptext (sLit "Checking fixity for")
+                                           <+> ppr name
+                             ; iface <- loadInterfaceForName doc name
+                             ; return . fmap conv_fix
+                                      . lookup (nameOccName name)
+                                      $ mi_fixities iface } } }
     where
       conv_fix (BasicTypes.Fixity i d) = TH.Fixity i (conv_dir d)
       conv_dir BasicTypes.InfixR = TH.InfixR
diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs
index 4bc2d25b66..45b19514bc 100644
--- a/libraries/ghci/GHCi/Message.hs
+++ b/libraries/ghci/GHCi/Message.hs
@@ -179,7 +179,7 @@ data Message a where
   Report :: Bool -> String -> Message (THResult ())
   LookupName :: Bool -> String -> Message (THResult (Maybe TH.Name))
   Reify :: TH.Name -> Message (THResult TH.Info)
-  ReifyFixity :: TH.Name -> Message (THResult TH.Fixity)
+  ReifyFixity :: TH.Name -> Message (THResult (Maybe TH.Fixity))
   ReifyInstances :: TH.Name -> [TH.Type] -> Message (THResult [TH.Dec])
   ReifyRoles :: TH.Name -> Message (THResult [TH.Role])
   ReifyAnnotations :: TH.AnnLookup -> TypeRep -> Message (THResult [ByteString])
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index 899d27c38f..3f79920a0b 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -66,7 +66,7 @@ instance Ppr Info where
               case mb_d of { Nothing -> empty; Just d -> ppr d }]
 
 ppr_sig :: Name -> Type -> Doc
-ppr_sig v ty = ppr v <+> dcolon <+> ppr ty
+ppr_sig v ty = pprName' Applied v <+> dcolon <+> ppr ty
 
 pprFixity :: Name -> Fixity -> Doc
 pprFixity _ f | f == defaultFixity = empty
@@ -507,20 +507,24 @@ instance Ppr Con where
                          <+> pprBangType st2
 
     ppr (ForallC ns ctxt (GadtC c sts ty))
-        = commaSep c <+> dcolon <+> pprForall ns ctxt <+> pprGadtRHS sts ty
+        = commaSepApplied c <+> dcolon <+> pprForall ns ctxt
+      <+> pprGadtRHS sts ty
 
     ppr (ForallC ns ctxt (RecGadtC c vsts ty))
-        = commaSep c <+> dcolon <+> pprForall ns ctxt
+        = commaSepApplied c <+> dcolon <+> pprForall ns ctxt
       <+> pprRecFields vsts ty
 
     ppr (ForallC ns ctxt con)
         = pprForall ns ctxt <+> ppr con
 
     ppr (GadtC c sts ty)
-        = commaSep c <+> dcolon <+> pprGadtRHS sts ty
+        = commaSepApplied c <+> dcolon <+> pprGadtRHS sts ty
 
     ppr (RecGadtC c vsts ty)
-        = commaSep c <+> dcolon <+> pprRecFields vsts ty
+        = commaSepApplied c <+> dcolon <+> pprRecFields vsts ty
+
+commaSepApplied :: [Name] -> Doc
+commaSepApplied = commaSepWith (pprName' Applied)
 
 pprForall :: [TyVarBndr] -> Cxt -> Doc
 pprForall ns ctxt
@@ -731,7 +735,12 @@ instance Ppr Loc where
 -- Takes a list of printable things and prints them separated by commas followed
 -- by space.
 commaSep :: Ppr a => [a] -> Doc
-commaSep = sep . punctuate comma . map ppr
+commaSep = commaSepWith ppr
+
+-- Takes a list of things and prints them with the given pretty-printing
+-- function, separated by commas followed by space.
+commaSepWith :: (a -> Doc) -> [a] -> Doc
+commaSepWith pprFun = sep . punctuate comma . map pprFun
 
 -- Takes a list of printable things and prints them separated by semicolons
 -- followed by space.
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index f571d6b16f..a3284c53eb 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -67,7 +67,7 @@ class Monad m => Quasi m where
   qLookupName :: Bool -> String -> m (Maybe Name)
        -- True <=> type namespace, False <=> value namespace
   qReify          :: Name -> m Info
-  qReifyFixity    :: Name -> m Fixity
+  qReifyFixity    :: Name -> m (Maybe Fixity)
   qReifyInstances :: Name -> [Type] -> m [Dec]
        -- Is (n tys) an instance?
        -- Returns list of matching instance Decs
@@ -355,10 +355,13 @@ and to get information about @D@-the-type, use 'lookupTypeName'.
 reify :: Name -> Q Info
 reify v = Q (qReify v)
 
-{- | @reifyFixity nm@ returns the fixity of @nm@. If a fixity value cannot be
-found, 'defaultFixity' is returned.
+{- | @reifyFixity nm@ attempts to find a fixity declaration for @nm@. For
+example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then
+@reifyFixity 'foo@ would return @'Just' ('Fixity' 7 'InfixR')@. If the function
+@bar@ does not have a fixity declaration, then @reifyFixity 'bar@ returns
+'Nothing', so you may assume @bar@ has 'defaultFixity'.
 -}
-reifyFixity :: Name -> Q Fixity
+reifyFixity :: Name -> Q (Maybe Fixity)
 reifyFixity nm = Q (qReifyFixity nm)
 
 {- | @reifyInstances nm tys@ returns a list of visible instances of @nm tys@. That is,
diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md
index 9564e95678..1c0919a8a2 100644
--- a/libraries/template-haskell/changelog.md
+++ b/libraries/template-haskell/changelog.md
@@ -37,6 +37,12 @@
   * Add `reifyConStrictness` to query a data constructor's `DecidedStrictness`
     values for its fields (#10697)
 
+  * The `ClassOpI`, `DataConI`, and `VarI` constructors no longer have a
+    `Fixity` field. Instead, all `Fixity` information for a given `Name` is
+    now determined through the `reifyFixity` function, which returns `Just` the
+    fixity if there is an explicit fixity declaration for that `Name`, and
+    `Nothing` otherwise (#10704 and #11345)
+
   * TODO: document API changes and important bugfixes
 
 
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'])