Fix #20590 with another application of mkHsContextMaybe

We were always converting empty GADT contexts to `Just []` in `GHC.ThToHs`,
which caused the pretty-printer to always print them as `() => ...`. This is
easily fixed by using the `mkHsContextMaybe` function when converting GADT
contexts so that empty contexts are turned to `Nothing`. This is in the same
tradition established in commit 4c87a3d1d14f9e28c8aa0f6062e9c4201f469ad7.

In the process of fixing this, I discovered that the `Cxt` argument to
`mkHsContextMaybe` is completely unnecessary, as we can just as well check if
the `LHsContext GhcPs` argument is empty.

Fixes #20590.

1 files changed, 15 insertions, 17 deletions

diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 12b7e9fdbc..e923307f15 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -259,7 +259,7 @@ cvtDec (DataD ctxt tc tvs ksig constrs derivs)
         ; derivs' <- cvtDerivs derivs
         ; let defn = HsDataDefn { dd_ext = noExtField
                                 , dd_ND = DataType, dd_cType = Nothing
-                                , dd_ctxt = mkHsContextMaybe ctxt ctxt'
+                                , dd_ctxt = mkHsContextMaybe ctxt'
                                 , dd_kindSig = ksig'
                                 , dd_cons = cons', dd_derivs = derivs' }
         ; returnJustLA $ TyClD noExtField $
@@ -275,7 +275,7 @@ cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)
         ; derivs' <- cvtDerivs derivs
         ; let defn = HsDataDefn { dd_ext = noExtField
                                 , dd_ND = NewType, dd_cType = Nothing
-                                , dd_ctxt = mkHsContextMaybe ctxt ctxt'
+                                , dd_ctxt = mkHsContextMaybe ctxt'
                                 , dd_kindSig = ksig'
                                 , dd_cons = [con']
                                 , dd_derivs = derivs' }
@@ -295,7 +295,7 @@ cvtDec (ClassD ctxt cl tvs fds decs)
                    $$ (Outputable.ppr adts'))
         ; returnJustLA $ TyClD noExtField $
           ClassDecl { tcdCExt = (noAnn, NoAnnSortKey, NoLayoutInfo)
-                    , tcdCtxt = mkHsContextMaybe ctxt cxt', tcdLName = tc', tcdTyVars = tvs'
+                    , tcdCtxt = mkHsContextMaybe cxt', tcdLName = tc', tcdTyVars = tvs'
                     , tcdFixity = Prefix
                     , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'
                     , tcdMeths = binds'
@@ -346,7 +346,7 @@ cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs)
        ; derivs' <- cvtDerivs derivs
        ; let defn = HsDataDefn { dd_ext = noExtField
                                , dd_ND = DataType, dd_cType = Nothing
-                               , dd_ctxt = mkHsContextMaybe ctxt ctxt'
+                               , dd_ctxt = mkHsContextMaybe ctxt'
                                , dd_kindSig = ksig'
                                , dd_cons = cons', dd_derivs = derivs' }
 
@@ -367,7 +367,7 @@ cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs)
        ; derivs' <- cvtDerivs derivs
        ; let defn = HsDataDefn { dd_ext = noExtField
                                , dd_ND = NewType, dd_cType = Nothing
-                               , dd_ctxt = mkHsContextMaybe ctxt ctxt'
+                               , dd_ctxt = mkHsContextMaybe ctxt'
                                , dd_kindSig = ksig'
                                , dd_cons = [con'], dd_derivs = derivs' }
        ; returnJustLA $ InstD noExtField $ DataFamInstD
@@ -622,7 +622,7 @@ cvtConstr (ForallC tvs ctxt con)
         ; L _ con'  <- cvtConstr con
         ; returnLA $ add_forall tvs' ctxt' con' }
   where
-    add_cxt lcxt         Nothing           = Just lcxt
+    add_cxt lcxt         Nothing           = mkHsContextMaybe lcxt
     add_cxt (L loc cxt1) (Just (L _ cxt2))
       = Just (L loc (cxt1 ++ cxt2))
 
@@ -1924,21 +1924,19 @@ mkHsQualTy ctxt loc ctxt' ty
                                  , hst_ctxt  = ctxt'
                                  , hst_body  = ty }
 
--- | If passed an empty 'TH.Cxt', this returns 'Nothing'. Otherwise, this
--- returns @'Just' lc@, where @lc@ is the provided @'LHsContext' 'GhcPs'@
--- argument.
+-- | @'mkHsContextMaybe' lc@ returns 'Nothing' if @lc@ is empty and @'Just' lc@
+-- otherwise.
 --
 -- This is much like 'mkHsQualTy', except that it returns a
 -- @'Maybe' ('LHsContext' 'GhcPs')@. This is used specifically for constructing
--- superclasses and datatype contexts. We wish to avoid using 'Just' in the
--- case of an empty 'TH.Cxt', as the pretty-printer for superclasses/datatype
--- contexts always prints 'Just' contexts, even if they're empty. See #20011.
-mkHsContextMaybe :: TH.Cxt
-                 -> LHsContext GhcPs
-                 -> Maybe (LHsContext GhcPs)
-mkHsContextMaybe ctxt ctxt'
+-- superclasses, datatype contexts (#20011), and contexts in GADT constructor
+-- types (#20590). We wish to avoid using @'Just' []@ in the case of an empty
+-- contexts, as the pretty-printer always prints 'Just' contexts, even if
+-- they're empty.
+mkHsContextMaybe :: LHsContext GhcPs -> Maybe (LHsContext GhcPs)
+mkHsContextMaybe lctxt@(L _ ctxt)
   | null ctxt = Nothing
-  | otherwise = Just ctxt'
+  | otherwise = Just lctxt
 
 mkHsOuterFamEqnTyVarBndrs :: Maybe [LHsTyVarBndr () GhcPs] -> HsOuterFamEqnTyVarBndrs GhcPs
 mkHsOuterFamEqnTyVarBndrs = maybe mkHsOuterImplicit (mkHsOuterExplicit noAnn)