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/GhcUtils.hs | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) (limited to 'haddock-api/src/Haddock/GhcUtils.hs') 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) -- 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/GhcUtils.hs') 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