diff options
Diffstat (limited to 'compiler/GHC/ThToHs.hs')
| -rw-r--r-- | compiler/GHC/ThToHs.hs | 32 |
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) |