Don't unnecessarily qualify TH-converted instances with empty contexts

Summary:
The addition of rigorous pretty-printer tests
(499e43824bda967546ebf95ee33ec1f84a114a7c) had the unfortunate
side-effect of revealing a bug in `hsSyn/Convert.hs` wherein instances are
_always_ qualified with an instance context, even if the context is empty. This
led to instances like this:

```
instance Foo Int
```

being pretty-printed like this!

```
instance () => Foo Int
```

We can prevent this by checking if the context is empty before adding an
HsQualTy to the type.

Also does some refactoring around HsForAllTys in `Convert` while I was in town.

Fixes #13183.

Test Plan: ./validate

Reviewers: goldfire, bgamari, austin, alanz

Reviewed By: alanz

Subscribers: mpickering, thomie

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

GHC Trac Issues: #13183

5 files changed, 55 insertions, 25 deletions

diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index a1ea110..ad4abf8 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -260,7 +260,7 @@ cvtDec (InstanceD o ctxt ty decs)
         ; unless (null fams') (failWith (mkBadDecMsg doc fams'))
         ; ctxt' <- cvtContext ctxt
         ; L loc ty' <- cvtType ty
-        ; let inst_ty' = L loc $ HsQualTy { hst_ctxt = ctxt', hst_body = L loc ty' }
+        ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ L loc ty'
         ; returnJustL $ InstD $ ClsInstD $
           ClsInstDecl { cid_poly_ty = mkLHsSigType inst_ty'
                       , cid_binds = binds'
@@ -346,7 +346,7 @@ cvtDec (TH.RoleAnnotD tc roles)
 cvtDec (TH.StandaloneDerivD ds cxt ty)
   = do { cxt' <- cvtContext cxt
        ; L loc ty'  <- cvtType ty
-       ; let inst_ty' = L loc $ HsQualTy { hst_ctxt = cxt', hst_body = L loc ty' }
+       ; let inst_ty' = mkHsQualTy cxt loc cxt' $ L loc ty'
        ; returnJustL $ DerivD $
          DerivDecl { deriv_strategy = fmap (L loc . cvtDerivStrategy) ds
                    , deriv_type = mkLHsSigType inst_ty'
@@ -510,16 +510,9 @@ cvtConstr (ForallC tvs ctxt con)
         ; L _ con'    <- cvtConstr con
         ; returnL $ case con' of
                 ConDeclGADT { con_type = conT } ->
-                  let hs_ty
-                        | null tvs = rho_ty
-                        | otherwise = noLoc $ HsForAllTy
-                                                { hst_bndrs = hsq_explicit tvs'
-                                                , hst_body  = rho_ty }
-                      rho_ty
-                        | null ctxt = hsib_body conT
-                        | otherwise = noLoc $ HsQualTy
-                                                { hst_ctxt = L loc ctxt'
-                                                , hst_body = hsib_body conT }
+                  let hs_ty  = mkHsForAllTy tvs noSrcSpan tvs' rho_ty
+                      rho_ty = mkHsQualTy ctxt noSrcSpan (L loc ctxt')
+                                                         (hsib_body conT)
                   in con' { con_type = HsIB PlaceHolder hs_ty }
                 ConDeclH98  {} ->
                   let qvars = case (tvs, con_qvars con') of
@@ -1221,12 +1214,8 @@ cvtTypeKind ty_str ty
                    ; cxt' <- cvtContext cxt
                    ; ty'  <- cvtType ty
                    ; loc <- getL
-                   ; let hs_ty | null tvs  = rho_ty
-                               | otherwise = L loc (HsForAllTy { hst_bndrs = hsQTvExplicit tvs'
-                                                               , hst_body  = rho_ty })
-                         rho_ty | null cxt  = ty'
-                                | otherwise = L loc (HsQualTy { hst_ctxt = cxt'
-                                                              , hst_body = ty' })
+                   ; let hs_ty  = mkHsForAllTy tvs loc tvs' rho_ty
+                         rho_ty = mkHsQualTy cxt loc cxt' ty'
 
                    ; return hs_ty }
 
@@ -1433,6 +1422,47 @@ unboxedSumChecks alt arity
     | otherwise
     = return ()
 
+-- | If passed an empty list of 'TH.TyVarBndr's, this simply returns the
+-- third argument (an 'LHsType'). Otherwise, return an 'HsForAllTy'
+-- using the provided 'LHsQTyVars' and 'LHsType'.
+mkHsForAllTy :: [TH.TyVarBndr]
+             -- ^ The original Template Haskell type variable binders
+             -> SrcSpan
+             -- ^ The location of the returned 'LHsType' if it needs an
+             --   explicit forall
+             -> LHsQTyVars name
+             -- ^ The converted type variable binders
+             -> LHsType name
+             -- ^ The converted rho type
+             -> LHsType name
+             -- ^ The complete type, quantified with a forall if necessary
+mkHsForAllTy tvs loc tvs' rho_ty
+  | null tvs  = rho_ty
+  | otherwise = L loc $ HsForAllTy { hst_bndrs = hsQTvExplicit tvs'
+                                   , hst_body = rho_ty }
+
+-- | If passed an empty 'TH.Cxt', this simply returns the third argument
+-- (an 'LHsType'). Otherwise, return an 'HsQualTy' using the provided
+-- 'LHsContext' and 'LHsType'.
+
+-- It's important that we don't build an HsQualTy if the context is empty,
+-- as the pretty-printer for HsType _always_ prints contexts, even if
+-- they're empty. See Trac #13183.
+mkHsQualTy :: TH.Cxt
+           -- ^ The original Template Haskell context
+           -> SrcSpan
+           -- ^ The location of the returned 'LHsType' if it needs an
+           --   explicit context
+           -> LHsContext name
+           -- ^ The converted context
+           -> LHsType name
+           -- ^ The converted tau type
+           -> LHsType name
+           -- ^ The complete type, qualified with a context if necessary
+mkHsQualTy ctxt loc ctxt' ty
+  | null ctxt = ty
+  | otherwise = L loc $ HsQualTy { hst_ctxt = ctxt', hst_body = ty }
+
 --------------------------------------------------------------------
 --      Turning Name back into RdrName
 --------------------------------------------------------------------
diff --git a/testsuite/tests/th/T10598_TH.stderr b/testsuite/tests/th/T10598_TH.stderr
index e149418..6471421 100644
--- a/testsuite/tests/th/T10598_TH.stderr
+++ b/testsuite/tests/th/T10598_TH.stderr
@@ -36,6 +36,6 @@ T10598_TH.hs:(27,3)-(42,50): Splicing declarations
       deriving stock Eq
       deriving anyclass C
       deriving newtype Read
-    deriving stock instance () => Ord Foo
-    deriving anyclass instance () => D Foo
-    deriving newtype instance () => Show Foo
+    deriving stock instance Ord Foo
+    deriving anyclass instance D Foo
+    deriving newtype instance Show Foo
diff --git a/testsuite/tests/th/T5700.stderr b/testsuite/tests/th/T5700.stderr
index f2f4288..729a366 100644
--- a/testsuite/tests/th/T5700.stderr
+++ b/testsuite/tests/th/T5700.stderr
@@ -1,6 +1,6 @@
 T5700.hs:8:3-9: Splicing declarations
     mkC ''D
   ======>
-    instance () => C D where
+    instance C D where
       {-# INLINE inlinable #-}
       inlinable _ = GHC.Tuple.()
diff --git a/testsuite/tests/th/T5883.stderr b/testsuite/tests/th/T5883.stderr
index b63ea2f..aa87a41 100644
--- a/testsuite/tests/th/T5883.stderr
+++ b/testsuite/tests/th/T5883.stderr
@@ -6,6 +6,6 @@ T5883.hs:(7,4)-(12,4): Splicing declarations
           {-# INLINE show #-} |]
   ======>
     data Unit = Unit
-    instance () => Show Unit where
+    instance Show Unit where
       {-# INLINE show #-}
       show _ = ""
diff --git a/testsuite/tests/th/T7532.stderr b/testsuite/tests/th/T7532.stderr
index 21b753b..baaf04f 100644
--- a/testsuite/tests/th/T7532.stderr
+++ b/testsuite/tests/th/T7532.stderr
@@ -6,10 +6,10 @@ instance C Bool where
 T7532.hs:11:3-7: Splicing declarations
     bang'
   ======>
-    instance () => C Int where
+    instance C Int where
       data D Int = T
 
 ==================== Renamer ====================
-instance () => C Int where
+instance C Int where
   data D Int = T7532.T