From 3fe1ccd2393837c4e8bc788368c18b40f7dac918 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sun, 16 May 2021 21:21:03 +0100 Subject: Remove Maybe from HsQualTy Match changes in GHC for #19845 --- haddock-api/src/Haddock/Backends/Hoogle.hs | 2 +- haddock-api/src/Haddock/Backends/LaTeX.hs | 13 +++++++------ haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 16 +++++++++------- 3 files changed, 17 insertions(+), 14 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index e70a705f..3f913e09 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -280,7 +280,7 @@ ppCtor dflags _dat subdocs (ConDeclGADT { con_names = names name = out dflags $ map unL names con_sig_ty = HsSig noExtField outer_bndrs theta_ty where theta_ty = case mcxt of - Just theta -> noLocA (HsQualTy { hst_xqual = noExtField, hst_ctxt = Just theta, hst_body = tau_ty }) + Just theta -> noLocA (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty }) Nothing -> tau_ty tau_ty = foldr mkFunTy res_ty $ case args of PrefixConGADT pos_args -> map hsScaledThing pos_args diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index abf882f0..fbae13a3 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -983,11 +983,12 @@ ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts) ------------------------------------------------------------------------------- -ppLContext, ppLContextNoArrow :: Maybe (LHsContext DocNameI) -> Bool -> LaTeX -ppLContext Nothing _ = empty -ppLContext (Just ctxt) unicode = ppContext (unLoc ctxt) unicode -ppLContextNoArrow Nothing _ = empty -ppLContextNoArrow (Just ctxt) unicode = ppContextNoArrow (unLoc ctxt) unicode +ppLContext :: Maybe (LHsContext DocNameI) -> Bool -> LaTeX +ppLContext Nothing _ = empty +ppLContext (Just ctxt) unicode = ppContext (unLoc ctxt) unicode + +ppLContextNoArrow :: LHsContext DocNameI -> Bool -> LaTeX +ppLContextNoArrow ctxt unicode = ppContextNoArrow (unLoc ctxt) unicode ppContextNoLocsMaybe :: [HsType DocNameI] -> Bool -> Maybe LaTeX ppContextNoLocsMaybe [] _ = Nothing @@ -1101,7 +1102,7 @@ ppr_mono_ty (HsForAllTy _ tele ty) unicode = sep [ ppHsForAllTelescope tele unicode , ppr_mono_lty ty unicode ] ppr_mono_ty (HsQualTy _ ctxt ty) unicode - = sep [ ppLContext ctxt unicode + = sep [ ppLContext (Just ctxt) unicode , ppr_mono_lty ty unicode ] ppr_mono_ty (HsFunTy _ mult ty1 ty2) u = sep [ ppr_mono_lty ty1 u diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 8de1b1b8..8ac1ac81 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -167,7 +167,7 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_sig_args 0 sep leader' = leader <+> ppForAllPart unicode qual tele do_args n leader (HsQualTy _ lctxt ltype) - | null (fromMaybeContext lctxt) + | null (unLoc lctxt) = do_largs n leader ltype | otherwise = (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, []) @@ -436,12 +436,14 @@ ppTypeApp n ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT ts) ------------------------------------------------------------------------------- -ppLContext, ppLContextNoArrow :: Maybe (LHsContext DocNameI) -> Unicode +ppLContext :: Maybe (LHsContext DocNameI) -> Unicode -> Qualification -> HideEmptyContexts -> Html ppLContext Nothing u q h = ppContext [] u q h ppLContext (Just c) u q h = ppContext (unLoc c) u q h -ppLContextNoArrow Nothing u q h = ppContextNoArrow [] u q h -ppLContextNoArrow (Just c) u q h = ppContextNoArrow (unLoc c) u q h + +ppLContextNoArrow :: LHsContext DocNameI -> Unicode + -> Qualification -> HideEmptyContexts -> Html +ppLContextNoArrow c u q h = ppContextNoArrow (unLoc c) u q h ppContextNoArrow :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html ppContextNoArrow cxt unicode qual emptyCtxts = fromMaybe noHtml $ @@ -1185,13 +1187,13 @@ patSigContext sig_typ | hasNonEmptyContext typ && isFirstContextEmpty typ = Sho hasNonEmptyContext t = case unLoc t of HsForAllTy _ _ s -> hasNonEmptyContext s - HsQualTy _ cxt s -> if null (fromMaybeContext cxt) then hasNonEmptyContext s else True + HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True HsFunTy _ _ _ s -> hasNonEmptyContext s _ -> False isFirstContextEmpty t = case unLoc t of HsForAllTy _ _ s -> isFirstContextEmpty s - HsQualTy _ cxt _ -> null (fromMaybeContext cxt) + HsQualTy _ cxt _ -> null (unLoc cxt) HsFunTy _ _ _ s -> isFirstContextEmpty s _ -> False @@ -1230,7 +1232,7 @@ ppr_mono_ty (HsForAllTy _ tele ty) unicode qual emptyCtxts = ppForAllPart unicode qual tele <+> ppr_mono_lty ty unicode qual emptyCtxts ppr_mono_ty (HsQualTy _ ctxt ty) unicode qual emptyCtxts - = ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty ty unicode qual emptyCtxts + = ppLContext (Just ctxt) unicode qual emptyCtxts <+> ppr_mono_lty ty unicode qual emptyCtxts -- UnicodeSyntax alternatives ppr_mono_ty (HsTyVar _ _ (L _ name)) True _ _ -- cgit v1.2.3 From 3b6a8774bdb543dad59b2618458b07feab8a55e9 Mon Sep 17 00:00:00 2001 From: Shayne Fletcher Date: Sat, 24 Apr 2021 14:31:41 -0400 Subject: FieldOcc: rename extFieldOcc to foExt --- haddock-api/src/Haddock/Backends/Hoogle.hs | 4 ++-- haddock-api/src/Haddock/Backends/LaTeX.hs | 4 ++-- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 6 +++--- haddock-api/src/Haddock/GhcUtils.hs | 4 ++-- haddock-api/src/Haddock/Interface/Create.hs | 4 ++-- 5 files changed, 11 insertions(+), 11 deletions(-) (limited to 'haddock-api/src/Haddock/Backends') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 3f913e09..38d378e2 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -247,8 +247,8 @@ ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' } f (PrefixCon _ args) = [typeSig name $ (map hsScaledThing args) ++ [resType]] f (InfixCon a1 a2) = f $ PrefixCon [] [a1,a2] f (RecCon (L _ recs)) = f (PrefixCon [] $ map (hsLinear . cd_fld_type . unLoc) recs) ++ concat - [(concatMap (lookupCon dflags subdocs . noLocA . extFieldOcc . unLoc) (cd_fld_names r)) ++ - [out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] + [(concatMap (lookupCon dflags subdocs . noLocA . foExt . unLoc) (cd_fld_names r)) ++ + [out dflags (map (foExt . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] funs = foldr1 (\x y -> reL $ HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) x y) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index fbae13a3..c7ba5a80 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -887,12 +887,12 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = -- | Pretty-print a record field ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocNameI -> LaTeX ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) = - decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) + decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . unLoc . foLabel . unLoc) names)) <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc where -- don't use cd_fld_doc for same reason we don't use con_doc above -- Where there is more than one name, they all have the same documentation - mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst + mbDoc = lookup (foExt $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst -- | Pretty-print a bundled pattern synonym diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 8ac1ac81..994b5d0d 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -1027,7 +1027,7 @@ ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) = ( hsep (punctuate comma [ ppBinder False (rdrNameOcc field) | L _ name <- names - , let field = (unLoc . rdrNameFieldOcc) name + , let field = (unLoc . foLabel) name ]) <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype @@ -1037,12 +1037,12 @@ ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) = where -- don't use cd_fld_doc for same reason we don't use con_doc above -- Where there is more than one name, they all have the same documentation - mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst + mbDoc = lookup (foExt $ unLoc $ head names) subdocs >>= combineDocumentation . fst ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html ppShortField summary unicode qual (ConDeclField _ names ltype _) - = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) + = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . foLabel . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 9353708a..fa567da8 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -290,7 +290,7 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] where field_avail :: LConDeclField GhcRn -> Bool field_avail (L _ (ConDeclField _ fs _ _)) - = all (\f -> extFieldOcc (unLoc f) `elem` names) fs + = all (\f -> foExt (unLoc f) `elem` names) fs field_types flds = [ hsUnrestricted t | L _ (ConDeclField _ _ t _) <- flds ] @@ -466,7 +466,7 @@ instance Parent (ConDecl GhcRn) where children con = case getRecConArgs_maybe con of Nothing -> [] - Just flds -> map (extFieldOcc . unLoc) $ concatMap (cd_fld_names . unLoc) (unLoc flds) + Just flds -> map (foExt . unLoc) $ concatMap (cd_fld_names . unLoc) (unLoc flds) instance Parent (TyClDecl GhcRn) where children d diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 4f689532..2d79bb97 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -1113,7 +1113,7 @@ extractDecl declMap name decl , Just rec <- map (getRecConArgs_maybe . unLoc) (dd_cons (feqn_rhs d)) , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) , L _ n <- ns - , extFieldOcc n == name + , foExt n == name ] in case matches of [d0] -> extractDecl declMap name (noLocA . InstD noExtField $ DataFamInstD noExtField d0) @@ -1174,7 +1174,7 @@ extractRecSel nm t tvs (L _ con : rest) = where matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)] matching_fields flds = [ (l,f) | f@(L _ (ConDeclField _ ns _ _)) <- flds - , L l n <- ns, extFieldOcc n == nm ] + , L l n <- ns, foExt n == nm ] data_ty -- ResTyGADT _ ty <- con_res con = ty | ConDeclGADT{} <- con = con_res_ty con -- cgit v1.2.3