From 8241d9e700e043b86b609c334494c4632848389f Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Mon, 22 Feb 2021 20:04:24 +0000 Subject: Context becomes a Maybe in the GHC AST This prevents noLoc's appearing in the ParsedSource. Match the change in GHC. --- haddock-api/src/Haddock/Backends/Hoogle.hs | 2 +- haddock-api/src/Haddock/Backends/LaTeX.hs | 16 +++++++++------- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 24 +++++++++++++----------- 3 files changed, 23 insertions(+), 19 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 f7e1c77b..1a0cccf7 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -281,7 +281,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 -> noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty }) + Just theta -> noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = Just 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 df1f94e6..e2e16947 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -25,7 +25,7 @@ import GHC.Utils.Ppr hiding (Doc, quote) import qualified GHC.Utils.Ppr as Pretty import GHC.Types.Basic ( PromotionFlag(..) ) -import GHC +import GHC hiding (fromMaybeContext ) import GHC.Types.Name.Occurrence import GHC.Types.Name ( nameOccName ) import GHC.Types.Name.Reader ( rdrNameOcc ) @@ -597,12 +597,12 @@ rDoc = maybeDoc . fmap latexStripTrailingWhitespace ------------------------------------------------------------------------------- -ppClassHdr :: Bool -> Located [LHsType DocNameI] -> DocName +ppClassHdr :: Bool -> Maybe (Located [LHsType DocNameI]) -> DocName -> LHsQTyVars DocNameI -> [Located ([Located DocName], [Located DocName])] -> Bool -> LaTeX ppClassHdr summ lctxt n tvs fds unicode = keyword "class" - <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else empty) + <+> (if not (null $ fromMaybeContext lctxt) then ppLContext lctxt unicode else empty) <+> ppAppDocNameNames summ n (tyvarNames tvs) <+> ppFds fds unicode @@ -806,7 +806,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = , con_ex_tvs = tyVars , con_forall = L _ forall_ , con_mb_cxt = cxt - } -> let context = unLoc (fromMaybe (noLoc []) cxt) + } -> let context = fromMaybeContext cxt header_ = ppConstrHdr forall_ tyVars context unicode in case det of -- Prefix constructor, e.g. 'Just a' @@ -980,9 +980,11 @@ ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts) ------------------------------------------------------------------------------- -ppLContext, ppLContextNoArrow :: Located (HsContext DocNameI) -> Bool -> LaTeX -ppLContext = ppContext . unLoc -ppLContextNoArrow = ppContextNoArrow . unLoc +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 ppContextNoLocsMaybe :: [HsType DocNameI] -> Bool -> Maybe LaTeX ppContextNoLocsMaybe [] _ = Nothing diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index de37e42a..e48f9bdd 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -37,7 +37,7 @@ import Text.XHtml hiding ( name, title, p, quote ) import GHC.Core.Type ( Specificity(..) ) import GHC.Types.Basic (PromotionFlag(..), isPromoted) -import GHC hiding (LexicalFixity(..)) +import GHC hiding (LexicalFixity(..), fromMaybeContext) import GHC.Exts import GHC.Types.Name import GHC.Data.BooleanFormula @@ -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 (unLoc lctxt) + | null (fromMaybeContext lctxt) = do_largs n leader ltype | otherwise = (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, []) @@ -435,10 +435,12 @@ ppTypeApp n ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT ts) ------------------------------------------------------------------------------- -ppLContext, ppLContextNoArrow :: Located (HsContext DocNameI) -> Unicode +ppLContext, ppLContextNoArrow :: Maybe (LHsContext DocNameI) -> Unicode -> Qualification -> HideEmptyContexts -> Html -ppLContext = ppContext . unLoc -ppLContextNoArrow = ppContextNoArrow . unLoc +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 ppContextNoArrow :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html ppContextNoArrow cxt unicode qual emptyCtxts = fromMaybe noHtml $ @@ -472,12 +474,12 @@ ppHsContext cxt unicode qual = parenList (map (ppType unicode qual HideEmptyCont ------------------------------------------------------------------------------- -ppClassHdr :: Bool -> Located [LHsType DocNameI] -> DocName +ppClassHdr :: Bool -> Maybe (Located [LHsType DocNameI]) -> DocName -> LHsQTyVars DocNameI -> [Located ([Located DocName], [Located DocName])] -> Unicode -> Qualification -> Html ppClassHdr summ lctxt n tvs fds unicode qual = keyword "class" - <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual HideEmptyContexts else noHtml) + <+> (if not (null $ fromMaybeContext lctxt) then ppLContext lctxt unicode qual HideEmptyContexts else noHtml) <+> ppAppDocNameTyVarBndrs summ unicode qual n (hsQTvExplicit tvs) <+> ppFds fds unicode qual @@ -855,7 +857,7 @@ ppShortConstrParts summary dataInst con unicode qual , con_ex_tvs = tyVars , con_forall = L _ forall_ , con_mb_cxt = cxt - } -> let context = unLoc (fromMaybe (noLoc []) cxt) + } -> let context = fromMaybeContext cxt header_ = ppConstrHdr forall_ tyVars context unicode qual in case det of @@ -927,7 +929,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) , con_ex_tvs = tyVars , con_forall = L _ forall_ , con_mb_cxt = cxt - } -> let context = unLoc (fromMaybe (noLoc []) cxt) + } -> let context = fromMaybeContext cxt header_ = ppConstrHdr forall_ tyVars context unicode qual in case det of -- Prefix constructor, e.g. 'Just a' @@ -1181,13 +1183,13 @@ patSigContext sig_typ | hasNonEmptyContext typ && isFirstContextEmpty typ = Sho hasNonEmptyContext t = case unLoc t of HsForAllTy _ _ s -> hasNonEmptyContext s - HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True + HsQualTy _ cxt s -> if null (fromMaybeContext cxt) then hasNonEmptyContext s else True HsFunTy _ _ _ s -> hasNonEmptyContext s _ -> False isFirstContextEmpty t = case unLoc t of HsForAllTy _ _ s -> isFirstContextEmpty s - HsQualTy _ cxt _ -> null (unLoc cxt) + HsQualTy _ cxt _ -> null (fromMaybeContext cxt) HsFunTy _ _ _ s -> isFirstContextEmpty s _ -> False -- cgit v1.2.3