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 +++++++++++++----------- haddock-api/src/Haddock/Convert.hs | 8 ++++---- haddock-api/src/Haddock/GhcUtils.hs | 16 +++++++++++----- haddock-api/src/Haddock/Interface/Create.hs | 4 ++-- haddock-api/src/Haddock/Interface/Rename.hs | 6 +++--- haddock-api/src/Haddock/Interface/Specialize.hs | 7 ++++++- 8 files changed, 49 insertions(+), 34 deletions(-) (limited to 'haddock-api/src') 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 diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 10e13152..83711414 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -215,7 +215,7 @@ synifyTyCon prr _coax tc , tcdDataDefn = HsDataDefn { dd_ext = noExtField , dd_ND = DataType -- arbitrary lie, they are neither -- algebraic data nor newtype: - , dd_ctxt = noLoc [] + , dd_ctxt = Nothing , dd_cType = Nothing , dd_kindSig = synifyDataTyConReturnKind tc -- we have their kind accurately: @@ -377,7 +377,7 @@ synifyDataCon use_gadt_syntax dc = -- skip any EqTheta, use 'orig'inal syntax ctx | null theta = Nothing - | otherwise = Just $ synifyCtx theta + | otherwise = synifyCtx theta linear_tys = zipWith (\ty bang -> @@ -461,8 +461,8 @@ synifyTcIdSig vs (i, dm) = mainSig t = synifySigType DeleteTopLevelQuantification vs t defSig t = synifySigType ImplicitizeForAll vs t -synifyCtx :: [PredType] -> LHsContext GhcRn -synifyCtx = noLoc . map (synifyType WithinType []) +synifyCtx :: [PredType] -> Maybe (LHsContext GhcRn) +synifyCtx ts = Just (noLoc ( map (synifyType WithinType []) ts)) synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 546e2941..6e21e094 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -24,7 +24,7 @@ module Haddock.GhcUtils where import Control.Arrow import Data.Char ( isSpace ) -import Data.Maybe ( mapMaybe ) +import Data.Maybe ( mapMaybe, fromMaybe ) import Haddock.Types( DocName, DocNameI ) @@ -172,7 +172,7 @@ getGADTConType (ConDeclGADT { con_bndrs = L _ outer_bndrs , sig_body = theta_ty }) where theta_ty | Just theta <- mcxt - = noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty }) + = noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = Just theta, hst_body = tau_ty }) | otherwise = tau_ty @@ -226,10 +226,12 @@ addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype)) , hst_ctxt = add_ctxt ctxt, hst_body = ty }) go_ty (L loc ty) = L loc (HsQualTy { hst_xqual = noExtField - , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty }) + , hst_ctxt = add_ctxt Nothing, hst_body = L loc ty }) extra_pred = nlHsTyConApp Prefix cls (lHsQTyVarsToTypes tvs0) - add_ctxt (L loc preds) = L loc (extra_pred : preds) + + add_ctxt Nothing = Just $ noLoc [extra_pred] + add_ctxt (Just (L loc preds)) = Just $ L loc (extra_pred : preds) addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine @@ -355,7 +357,9 @@ reparenTypePrec = go go p (HsQualTy x ctxt ty) = let p' [_] = PREC_CTX p' _ = PREC_TOP -- parens will get added anyways later... - ctxt' = mapXRec @a (\xs -> map (goL (p' xs)) xs) ctxt + ctxt' = case ctxt of + Nothing -> Nothing + Just c -> Just $ mapXRec @a (\xs -> map (goL (p' xs)) xs) c in paren p PREC_CTX $ HsQualTy x ctxt' (goL PREC_TOP ty) go p (HsFunTy x w ty1 ty2) = paren p PREC_FUN $ HsFunTy x w (goL PREC_FUN ty1) (goL PREC_TOP ty2) @@ -758,3 +762,5 @@ defaultRuntimeRepVars = go emptyVarEnv go _ ty@(LitTy {}) = ty go _ ty@(CoercionTy {}) = ty +fromMaybeContext :: Maybe (LHsContext DocNameI) -> HsContext DocNameI +fromMaybeContext mctxt = unLoc $ fromMaybe (noLoc []) mctxt diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 9a773b6c..4357cb79 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -1098,9 +1098,9 @@ extractPatternSyn nm t tvs cons = typ = longArrow args (data_ty con) typ' = case con of - ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy noExtField cxt typ) + ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy noExtField (Just cxt) typ) _ -> typ - typ'' = noLoc (HsQualTy noExtField (noLoc []) typ') + typ'' = noLoc (HsQualTy noExtField Nothing typ') in PatSynSig noExtField [noLoc nm] (mkEmptySigType typ'') longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index b212adce..b62f79ce 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -258,7 +258,7 @@ renameType t = case t of , hst_tele = tele', hst_body = ltype' }) HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do - lcontext' <- renameLContext lcontext + lcontext' <- traverse renameLContext lcontext ltype' <- renameLType ltype return (HsQualTy { hst_xqual = noExtField, hst_ctxt = lcontext', hst_body = ltype' }) @@ -432,7 +432,7 @@ renameTyClD d = case d of ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars, tcdFixity = fixity , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do - lcontext' <- renameLContext lcontext + lcontext' <- traverse renameLContext lcontext lname' <- renameL lname ltyvars' <- renameLHsQTyVars ltyvars lfundeps' <- mapM renameLFunDep lfundeps @@ -490,7 +490,7 @@ renameFamilyInfo (ClosedTypeFamily eqns) renameDataDefn :: HsDataDefn GhcRn -> RnM (HsDataDefn DocNameI) renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType , dd_kindSig = k, dd_cons = cons }) = do - lcontext' <- renameLContext lcontext + lcontext' <- traverse renameLContext lcontext k' <- renameMaybeLKind k cons' <- mapM (mapM renameCon) cons -- I don't think we need the derivings, so we return Nothing diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index f37e1da9..5ef5d92d 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -284,7 +284,7 @@ renameType (HsForAllTy x tele lt) = <*> renameLType lt renameType (HsQualTy x lctxt lt) = HsQualTy x - <$> located renameContext lctxt + <$> renameMContext lctxt <*> renameLType lt renameType (HsTyVar x ip name) = HsTyVar x ip <$> located renameName name renameType t@(HsStarTy _ _) = pure t @@ -325,6 +325,11 @@ renameLKind = renameLType renameLTypes :: [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn] renameLTypes = mapM renameLType +renameMContext :: Maybe (LHsContext GhcRn) -> Rename (IdP GhcRn) (Maybe (LHsContext GhcRn)) +renameMContext Nothing = return Nothing +renameMContext (Just (L l ctxt)) = do + ctxt' <- renameContext ctxt + return (Just (L l ctxt')) renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn) renameContext = renameLTypes -- cgit v1.2.3