summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRyan Scott <rscott@galois.com>2021-06-18 09:32:24 -0400
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-06-19 22:59:08 -0400
commit4c87a3d1d14f9e28c8aa0f6062e9c4201f469ad7 (patch)
treed68347c0caee50b27dbc369856f781dda0bbe003
parent3f60a7e59dc5e067a3c764799478645dbc37700d (diff)
downloadhaskell-4c87a3d1d14f9e28c8aa0f6062e9c4201f469ad7.tar.gz
Simplify pprLHsContext
This removes an _ad hoc_ special case for empty `LHsContext`s in `pprLHsContext`, fixing #20011. To avoid regressions in pretty-printing data types and classes constructed via TH, we now apply a heuristic where we convert empty datatype contexts and superclasses to a `Nothing` (rather than `Just` an empty context). This will, for instance, avoid pretty-printing every TH-constructed data type as `data () => Blah ...`.
-rw-r--r--compiler/GHC/Hs/Type.hs4
-rw-r--r--compiler/GHC/ThToHs.hs26
2 files changed, 22 insertions, 8 deletions
diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs
index 3b67c8dd2e..399c89f93d 100644
--- a/compiler/GHC/Hs/Type.hs
+++ b/compiler/GHC/Hs/Type.hs
@@ -987,9 +987,7 @@ pprHsForAll tele cxt
pprLHsContext :: (OutputableBndrId p)
=> Maybe (LHsContext (GhcPass p)) -> SDoc
pprLHsContext Nothing = empty
-pprLHsContext (Just lctxt)
- | null (unLoc lctxt) = empty
- | otherwise = pprLHsContextAlways lctxt
+pprLHsContext (Just lctxt) = pprLHsContextAlways lctxt
-- For use in a HsQualTy, which always gets printed if it exists.
pprLHsContextAlways :: (OutputableBndrId p)
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index edd5301907..e452841f7a 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -255,7 +255,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 = Just ctxt'
+ , dd_ctxt = mkHsContextMaybe ctxt ctxt'
, dd_kindSig = ksig'
, dd_cons = cons', dd_derivs = derivs' }
; returnJustLA $ TyClD noExtField $
@@ -271,7 +271,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 = Just ctxt'
+ , dd_ctxt = mkHsContextMaybe ctxt ctxt'
, dd_kindSig = ksig'
, dd_cons = [con']
, dd_derivs = derivs' }
@@ -291,7 +291,7 @@ cvtDec (ClassD ctxt cl tvs fds decs)
$$ (Outputable.ppr adts'))
; returnJustLA $ TyClD noExtField $
ClassDecl { tcdCExt = (noAnn, NoAnnSortKey, NoLayoutInfo)
- , tcdCtxt = Just cxt', tcdLName = tc', tcdTyVars = tvs'
+ , tcdCtxt = mkHsContextMaybe ctxt cxt', tcdLName = tc', tcdTyVars = tvs'
, tcdFixity = Prefix
, tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'
, tcdMeths = binds'
@@ -342,7 +342,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 = Just ctxt'
+ , dd_ctxt = mkHsContextMaybe ctxt ctxt'
, dd_kindSig = ksig'
, dd_cons = cons', dd_derivs = derivs' }
@@ -363,7 +363,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 = Just ctxt'
+ , dd_ctxt = mkHsContextMaybe ctxt ctxt'
, dd_kindSig = ksig'
, dd_cons = [con'], dd_derivs = derivs' }
; returnJustLA $ InstD noExtField $ DataFamInstD
@@ -1913,6 +1913,22 @@ 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.
+--
+-- 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'
+ | null ctxt = Nothing
+ | otherwise = Just ctxt'
+
mkHsOuterFamEqnTyVarBndrs :: Maybe [LHsTyVarBndr () GhcPs] -> HsOuterFamEqnTyVarBndrs GhcPs
mkHsOuterFamEqnTyVarBndrs = maybe mkHsOuterImplicit (mkHsOuterExplicit noAnn)