From 2fec1b44e0ee7e263286709aa528b4ecb99ac6c2 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Thu, 13 May 2021 19:04:33 +0100 Subject: EPA: match changes from GHC T19834 --- haddock-api/src/Haddock/Convert.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'haddock-api/src/Haddock/Convert.hs') diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index f8d85f88..3a7ef57d 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -209,7 +209,7 @@ synifyTyCon prr _coax tc , tcdFixity = synifyFixity tc - , tcdDataDefn = HsDataDefn { dd_ext = noAnn + , tcdDataDefn = HsDataDefn { dd_ext = noExtField , dd_ND = DataType -- arbitrary lie, they are neither -- algebraic data nor newtype: , dd_ctxt = Nothing @@ -300,7 +300,7 @@ synifyTyCon _prr coax tc cons = rights consRaw -- "deriving" doesn't affect the signature, no need to specify any. alg_deriv = [] - defn = HsDataDefn { dd_ext = noAnn + defn = HsDataDefn { dd_ext = noExtField , dd_ND = alg_nd , dd_ctxt = alg_ctx , dd_cType = Nothing -- cgit v1.2.3 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 +++++++++------- haddock-api/src/Haddock/Convert.hs | 10 +++++----- haddock-api/src/Haddock/GhcUtils.hs | 11 ++++------- haddock-api/src/Haddock/Interface/Create.hs | 4 ++-- haddock-api/src/Haddock/Interface/Rename.hs | 2 +- haddock-api/src/Haddock/Interface/Specialize.hs | 9 ++++----- 8 files changed, 33 insertions(+), 34 deletions(-) (limited to 'haddock-api/src/Haddock/Convert.hs') 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 _ _ diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 3a7ef57d..a2bdb1b9 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -124,7 +124,7 @@ tyThingToLHsDecl prr t = case t of vs = tyConVisibleTyVars (classTyCon cl) in withErrs (lefts atTyClDecls) . TyClD noExtField $ ClassDecl - { tcdCtxt = synifyCtx (classSCTheta cl) + { tcdCtxt = Just $ synifyCtx (classSCTheta cl) , tcdLName = synifyNameN cl , tcdTyVars = synifyTyVars vs , tcdFixity = synifyFixity cl @@ -302,7 +302,7 @@ synifyTyCon _prr coax tc alg_deriv = [] defn = HsDataDefn { dd_ext = noExtField , dd_ND = alg_nd - , dd_ctxt = alg_ctx + , dd_ctxt = Just alg_ctx , dd_cType = Nothing , dd_kindSig = kindSig , dd_cons = cons @@ -375,7 +375,7 @@ synifyDataCon use_gadt_syntax dc = -- skip any EqTheta, use 'orig'inal syntax ctx | null theta = Nothing - | otherwise = synifyCtx theta + | otherwise = Just $ synifyCtx theta linear_tys = zipWith (\ty bang -> @@ -462,8 +462,8 @@ synifyTcIdSig vs (i, dm) = mainSig t = synifySigType DeleteTopLevelQuantification vs t defSig t = synifySigType ImplicitizeForAll vs t -synifyCtx :: [PredType] -> Maybe (LHsContext GhcRn) -synifyCtx ts = Just (noLocA ( map (synifyType WithinType []) ts)) +synifyCtx :: [PredType] -> LHsContext GhcRn +synifyCtx ts = noLocA ( 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 1d6b8bc3..9353708a 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -171,7 +171,7 @@ getGADTConType (ConDeclGADT { con_bndrs = L _ outer_bndrs , sig_body = theta_ty }) where theta_ty | Just theta <- mcxt - = noLocA (HsQualTy { hst_xqual = noAnn, hst_ctxt = Just theta, hst_body = tau_ty }) + = noLocA (HsQualTy { hst_xqual = noAnn, hst_ctxt = theta, hst_body = tau_ty }) | otherwise = tau_ty @@ -226,12 +226,11 @@ 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 Nothing, hst_body = L loc ty }) + , hst_ctxt = add_ctxt (noLocA []), hst_body = L loc ty }) extra_pred = nlHsTyConApp Prefix cls (lHsQTyVarsToTypes tvs0) - add_ctxt Nothing = Just $ noLocA [extra_pred] - add_ctxt (Just (L loc preds)) = Just $ L loc (extra_pred : preds) + add_ctxt (L loc preds) = L loc (extra_pred : preds) addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine @@ -356,9 +355,7 @@ reparenTypePrec = go go p (HsQualTy x ctxt ty) = let p' [_] = PREC_CTX p' _ = PREC_TOP -- parens will get added anyways later... - ctxt' = case ctxt of - Nothing -> Nothing - Just c -> Just $ mapXRec @a (\xs -> map (goL (p' xs)) xs) c + ctxt' = mapXRec @a (\xs -> map (goL (p' xs)) xs) ctxt in paren p PREC_CTX $ HsQualTy x ctxt' (goL PREC_TOP ty) -- = paren p PREC_FUN $ HsQualTy x (fmap (mapXRec @a (map reparenLType)) ctxt) (reparenLType ty) go p (HsFunTy x w ty1 ty2) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index a280c0b2..4f689532 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -1146,9 +1146,9 @@ extractPatternSyn nm t tvs cons = typ = longArrow args (data_ty con) typ' = case con of - ConDeclH98 { con_mb_cxt = Just cxt } -> noLocA (HsQualTy noExtField (Just cxt) typ) + ConDeclH98 { con_mb_cxt = Just cxt } -> noLocA (HsQualTy noExtField cxt typ) _ -> typ - typ'' = noLocA (HsQualTy noExtField Nothing typ') + typ'' = noLocA (HsQualTy noExtField (noLocA []) typ') in PatSynSig noAnn [noLocA 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 2833df49..693a22ef 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' <- traverse renameLContext lcontext + lcontext' <- renameLContext lcontext ltype' <- renameLType ltype return (HsQualTy { hst_xqual = noAnn, hst_ctxt = lcontext', hst_body = ltype' }) diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 16f00fda..657da7ae 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -283,7 +283,7 @@ renameType (HsForAllTy x tele lt) = <*> renameLType lt renameType (HsQualTy x lctxt lt) = HsQualTy x - <$> renameMContext lctxt + <$> renameLContext lctxt <*> renameLType lt renameType (HsTyVar x ip name) = HsTyVar x ip <$> locatedN renameName name renameType t@(HsStarTy _ _) = pure t @@ -324,11 +324,10 @@ 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 +renameLContext :: LHsContext GhcRn -> Rename (IdP GhcRn) (LHsContext GhcRn) +renameLContext (L l ctxt) = do ctxt' <- renameContext ctxt - return (Just (L l ctxt')) + return (L l ctxt') renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn) renameContext = renameLTypes -- cgit v1.2.3