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/Interface/Create.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'haddock-api/src/Haddock/Interface/Create.hs') 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 -- 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/Interface/Create.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 From 0029f289bec7427032785f13cf3bcdebddf7b91f Mon Sep 17 00:00:00 2001 From: Vladislav Zavialov Date: Tue, 1 Jun 2021 10:31:12 +0300 Subject: HsToken in FunTy, RecConGADT --- haddock-api/src/Haddock/Backends/Hoogle.hs | 6 +++--- haddock-api/src/Haddock/Backends/LaTeX.hs | 6 +++--- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 6 +++--- haddock-api/src/Haddock/Convert.hs | 8 ++++---- haddock-api/src/Haddock/GhcUtils.hs | 6 +++--- haddock-api/src/Haddock/Interface/Create.hs | 6 +++--- haddock-api/src/Haddock/Interface/Rename.hs | 11 ++++++----- haddock-api/src/Haddock/Interface/Specialize.hs | 4 ++-- 8 files changed, 27 insertions(+), 26 deletions(-) (limited to 'haddock-api/src/Haddock/Interface/Create.hs') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 38d378e2..dfb167a3 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -251,7 +251,7 @@ ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' } [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) + funs = foldr1 (\x y -> reL $ HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) x y) apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y) typeSig nm flds = operator nm ++ " :: " ++ @@ -284,8 +284,8 @@ ppCtor dflags _dat subdocs (ConDeclGADT { con_names = names Nothing -> tau_ty tau_ty = foldr mkFunTy res_ty $ case args of PrefixConGADT pos_args -> map hsScaledThing pos_args - RecConGADT (L _ flds) -> map (cd_fld_type . unL) flds - mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) a b) + RecConGADT (L _ flds) _ -> map (cd_fld_type . unL) flds + mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) a b) ppFixity :: DynFlags -> (Name, Fixity) -> [String] ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLocA name] fixity) :: FixitySig GhcRn)] diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index c7ba5a80..eb524ec7 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -843,7 +843,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = fieldPart = case con of ConDeclGADT{con_g_args = con_args'} -> case con_args' of -- GADT record declarations - RecConGADT _ -> doConstrArgsWithDocs [] + RecConGADT _ _ -> doConstrArgsWithDocs [] -- GADT prefix data constructors PrefixConGADT args | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args) _ -> empty @@ -1108,9 +1108,9 @@ ppr_mono_ty (HsFunTy _ mult ty1 ty2) u = sep [ ppr_mono_lty ty1 u , arr <+> ppr_mono_lty ty2 u ] where arr = case mult of - HsLinearArrow _ _ -> lollipop u + HsLinearArrow _ -> lollipop u HsUnrestrictedArrow _ -> arrow u - HsExplicitMult _ _ m -> multAnnotation <> ppr_mono_lty m u <+> arrow u + HsExplicitMult _ m _ -> multAnnotation <> ppr_mono_lty m u <+> arrow u ppr_mono_ty (HsBangTy _ b ty) u = ppBang b <> ppLParendType u ty ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 994b5d0d..336f23ac 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -969,7 +969,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) fieldPart = case con of ConDeclGADT{con_g_args = con_args'} -> case con_args' of -- GADT record declarations - RecConGADT _ -> [ doConstrArgsWithDocs [] ] + RecConGADT _ _ -> [ doConstrArgsWithDocs [] ] -- GADT prefix data constructors PrefixConGADT args | hasArgDocs -> [ doConstrArgsWithDocs args ] _ -> [] @@ -1250,9 +1250,9 @@ ppr_mono_ty (HsFunTy _ mult ty1 ty2) u q e = , arr <+> ppr_mono_lty ty2 u q e ] where arr = case mult of - HsLinearArrow _ _ -> lollipop u + HsLinearArrow _ -> lollipop u HsUnrestrictedArrow _ -> arrow u - HsExplicitMult _ _ m -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u + HsExplicitMult _ m _ -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u ppr_mono_ty (HsTupleTy _ con tys) u q _ = tupleParens con (map (ppLType u q HideEmptyContexts) tys) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index a2bdb1b9..cf533c20 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -401,7 +401,7 @@ synifyDataCon use_gadt_syntax dc = mk_gadt_arg_tys :: HsConDeclGADTDetails GhcRn mk_gadt_arg_tys - | use_named_field_syntax = RecConGADT (noLocA field_tys) + | use_named_field_syntax = RecConGADT (noLocA field_tys) noHsUniTok | otherwise = PrefixConGADT (map hsUnrestricted linear_tys) -- finally we get synifyDataCon's result! @@ -797,9 +797,9 @@ noKindTyVars _ _ = emptyVarSet synifyMult :: [TyVar] -> Mult -> HsArrow GhcRn synifyMult vs t = case t of - One -> HsLinearArrow NormalSyntax Nothing - Many -> HsUnrestrictedArrow NormalSyntax - ty -> HsExplicitMult NormalSyntax Nothing (synifyType WithinType vs ty) + One -> HsLinearArrow (HsPct1 noHsTok noHsUniTok) + Many -> HsUnrestrictedArrow noHsUniTok + ty -> HsExplicitMult noHsTok (synifyType WithinType vs ty) noHsUniTok diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index fa567da8..599404a0 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -177,11 +177,11 @@ getGADTConType (ConDeclGADT { con_bndrs = L _ outer_bndrs -- tau_ty :: LHsType DocNameI tau_ty = case args of - RecConGADT flds -> mkFunTy (noLocA (HsRecTy noAnn (unLoc flds))) res_ty + RecConGADT flds _ -> mkFunTy (noLocA (HsRecTy noAnn (unLoc flds))) res_ty PrefixConGADT pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args) mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI - mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) a b) + mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) a b) getGADTConType (ConDeclH98 {}) = panic "getGADTConType" -- Should only be called on ConDeclGADT @@ -283,7 +283,7 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] ConDeclGADT { con_g_args = con_args' } -> case con_args' of PrefixConGADT {} -> Just d - RecConGADT fields + RecConGADT fields _ | all field_avail (unLoc fields) -> Just d | otherwise -> Just (d { con_g_args = PrefixConGADT (field_types $ unLoc fields) }) -- see above diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 2d79bb97..2782f711 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -1142,7 +1142,7 @@ extractPatternSyn nm t tvs cons = InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2] ConDeclGADT { con_g_args = con_args' } -> case con_args' of PrefixConGADT args' -> map hsScaledThing args' - RecConGADT (L _ fields) -> cd_fld_type . unLoc <$> fields + RecConGADT (L _ fields) _ -> cd_fld_type . unLoc <$> fields typ = longArrow args (data_ty con) typ' = case con of @@ -1152,7 +1152,7 @@ extractPatternSyn nm t tvs cons = in PatSynSig noAnn [noLocA nm] (mkEmptySigType typ'') longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn - longArrow inputs output = foldr (\x y -> noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) x y)) output inputs + longArrow inputs output = foldr (\x y -> noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) x y)) output inputs data_ty con | ConDeclGADT{} <- con = con_res_ty con @@ -1169,7 +1169,7 @@ extractRecSel _ _ _ [] = Left "extractRecSel: selector not found" extractRecSel nm t tvs (L _ con : rest) = case getRecConArgs_maybe con of Just (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields -> - pure (L (noAnnSrcSpan l) (TypeSig noAnn [noLocA nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty)))))) + pure (L (noAnnSrcSpan l) (TypeSig noAnn [noLocA nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) data_ty (getBangType ty)))))) _ -> extractRecSel nm t tvs rest where matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)] diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 693a22ef..98b3a6e6 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -245,9 +245,10 @@ renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn GhcRn) renameMaybeInjectivityAnn = traverse renameInjectivityAnn renameArrow :: HsArrow GhcRn -> RnM (HsArrow DocNameI) -renameArrow (HsUnrestrictedArrow u) = return (HsUnrestrictedArrow u) -renameArrow (HsLinearArrow u a) = return (HsLinearArrow u a) -renameArrow (HsExplicitMult u a p) = HsExplicitMult u a <$> renameLType p +renameArrow (HsUnrestrictedArrow arr) = return (HsUnrestrictedArrow arr) +renameArrow (HsLinearArrow (HsPct1 pct1 arr)) = return (HsLinearArrow (HsPct1 pct1 arr)) +renameArrow (HsLinearArrow (HsLolly arr)) = return (HsLinearArrow (HsLolly arr)) +renameArrow (HsExplicitMult pct p arr) = (\p' -> HsExplicitMult pct p' arr) <$> renameLType p renameType :: HsType GhcRn -> RnM (HsType DocNameI) renameType t = case t of @@ -548,9 +549,9 @@ renameH98Details (InfixCon a b) = do renameGADTDetails :: HsConDeclGADTDetails GhcRn -> RnM (HsConDeclGADTDetails DocNameI) -renameGADTDetails (RecConGADT (L l fields)) = do +renameGADTDetails (RecConGADT (L l fields) arr) = do fields' <- mapM renameConDeclFieldField fields - return (RecConGADT (L (locA l) fields')) + return (RecConGADT (L (locA l) fields') arr) renameGADTDetails (PrefixConGADT ps) = PrefixConGADT <$> mapM renameHsScaled ps renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI) diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 657da7ae..399e5d0d 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -134,7 +134,7 @@ sugarTuples typ = sugarOperators :: HsType GhcRn -> HsType GhcRn sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb) | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb - | unrestrictedFunTyConName == name' = HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) la lb + | unrestrictedFunTyConName == name' = HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) la lb where name' = getName name sugarOperators typ = typ @@ -311,7 +311,7 @@ renameType t@(HsTyLit _ _) = pure t renameType (HsWildCardTy wc) = pure (HsWildCardTy wc) renameHsArrow :: HsArrow GhcRn -> Rename (IdP GhcRn) (HsArrow GhcRn) -renameHsArrow (HsExplicitMult u a p) = HsExplicitMult u a <$> renameLType p +renameHsArrow (HsExplicitMult pct p arr) = (\p' -> HsExplicitMult pct p' arr) <$> renameLType p renameHsArrow mult = pure mult -- cgit v1.2.3 From d8b79d35ddd96c83f4a3a0303011defc209aa318 Mon Sep 17 00:00:00 2001 From: Sylvain Henry Date: Fri, 15 Oct 2021 22:20:10 +0200 Subject: Fix after PkgQual refactoring (#1429) --- haddock-api/src/Haddock/Interface/Create.hs | 17 +++++++---------- 1 file changed, 7 insertions(+), 10 deletions(-) (limited to 'haddock-api/src/Haddock/Interface/Create.hs') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 2782f711..75789a06 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -59,7 +59,6 @@ import GHC.Data.FastString (bytesFS, unpackFS) import GHC.Driver.Ppr (showSDoc) import GHC.HsToCore.Docs hiding (mkMaps) import GHC.IORef (readIORef) -import GHC.Parser.Annotation (IsUnicodeSyntax (..)) import GHC.Stack (HasCallStack) import GHC.Tc.Types hiding (IfM) import GHC.Tc.Utils.Monad (finalSafeMode) @@ -72,14 +71,13 @@ import GHC.Types.Name.Reader (GlobalRdrEnv, greMangledName, lookupGlobalRdrEnv) import GHC.Types.Name.Set (elemNameSet, mkNameSet) import GHC.Types.SourceFile (HscSource (..)) import GHC.Types.SourceText (SourceText (..), sl_fs) +import GHC.Unit.Types import qualified GHC.Types.SrcLoc as SrcLoc import qualified GHC.Unit.Module as Module import GHC.Unit.Module.ModSummary (msHsFilePath) -import GHC.Unit.Module.Warnings (WarningTxt (..), Warnings (..)) import GHC.Unit.State (PackageName (..), UnitState, lookupModuleInAllUnits) import qualified GHC.Utils.Outputable as O import GHC.Utils.Panic (pprPanic) -import GHC.HsToCore.Docs hiding (mkMaps) import GHC.Unit.Module.Warnings newtype IfEnv m = IfEnv @@ -351,8 +349,7 @@ mkAliasMap state impDecls = -- them to the user. We should reuse that information; -- or at least reuse the renamed imports, which know what -- they import! - (fmap Module.fsToUnit $ - fmap sl_fs $ ideclPkgQual impDecl) + (ideclPkgQual impDecl) (case ideclName impDecl of SrcLoc.L _ name -> name), alias)) impDecls @@ -395,11 +392,11 @@ unrestrictedModuleImports idecls = -- Similar to GHC.lookupModule -- ezyang: Not really... lookupModuleDyn :: - UnitState -> Maybe Unit -> ModuleName -> Module -lookupModuleDyn _ (Just pkgId) mdlName = - Module.mkModule pkgId mdlName -lookupModuleDyn state Nothing mdlName = - case lookupModuleInAllUnits state mdlName of + UnitState -> PkgQual -> ModuleName -> Module +lookupModuleDyn state pkg_qual mdlName = case pkg_qual of + OtherPkg uid -> Module.mkModule (RealUnit (Definite uid)) mdlName + ThisPkg uid -> Module.mkModule (RealUnit (Definite uid)) mdlName + NoPkgQual -> case lookupModuleInAllUnits state mdlName of (m,_):_ -> m [] -> Module.mkModule Module.mainUnit mdlName -- cgit v1.2.3 From 1ef24e617651955f07c4fb6f2d488806cc6785ec Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Thu, 28 Oct 2021 18:57:10 +0100 Subject: Update for changes in GHC for branch wip/az/no-srcspan-anno-instances --- haddock-api/src/Haddock/Convert.hs | 12 ++++++------ haddock-api/src/Haddock/Interface/Create.hs | 4 ++-- haddock-api/src/Haddock/Types.hs | 8 ++++---- 3 files changed, 12 insertions(+), 12 deletions(-) (limited to 'haddock-api/src/Haddock/Interface/Create.hs') diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index cf533c20..29e0957b 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -341,14 +341,14 @@ synifyInjectivityAnn Nothing _ _ = Nothing synifyInjectivityAnn _ _ NotInjective = Nothing synifyInjectivityAnn (Just lhs) tvs (Injective inj) = let rhs = map (noLocA . tyVarName) (filterByList inj tvs) - in Just $ noLoc $ InjectivityAnn noAnn (noLocA lhs) rhs + in Just $ noLocA $ InjectivityAnn noAnn (noLocA lhs) rhs synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn synifyFamilyResultSig Nothing kind - | isLiftedTypeKind kind = noLoc $ NoSig noExtField - | otherwise = noLoc $ KindSig noExtField (synifyKindSig kind) + | isLiftedTypeKind kind = noLocA $ NoSig noExtField + | otherwise = noLocA $ KindSig noExtField (synifyKindSig kind) synifyFamilyResultSig (Just name) kind = - noLoc $ TyVarSig noExtField (noLocA $ KindedTyVar noAnn () (noLocA name) (synifyKindSig kind)) + noLocA $ TyVarSig noExtField (noLocA $ KindedTyVar noAnn () (noLocA name) (synifyKindSig kind)) -- User beware: it is your responsibility to pass True (use_gadt_syntax) -- for any constructor that would be misrepresented by omitting its @@ -387,7 +387,7 @@ synifyDataCon use_gadt_syntax dc = field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys con_decl_field fl synTy = noLocA $ - ConDeclField noAnn [noLoc $ FieldOcc (flSelector fl) (noLocA $ mkVarUnqual $ flLabel fl)] synTy + ConDeclField noAnn [noLocA $ FieldOcc (flSelector fl) (noLocA $ mkVarUnqual $ flLabel fl)] synTy Nothing mk_h98_arg_tys :: Either ErrMsg (HsConDeclH98Details GhcRn) @@ -611,7 +611,7 @@ synifyType _ vs (TyConApp tc tys) | tc `hasKey` ipClassKey , [name, ty] <- tys , Just x <- isStrLitTy name - = noLocA $ HsIParamTy noAnn (noLoc $ HsIPName x) (synifyType WithinType vs ty) + = noLocA $ HsIParamTy noAnn (noLocA $ HsIPName x) (synifyType WithinType vs ty) -- and equalities | tc `hasKey` eqTyConKey , [ty1, ty2] <- tys diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 75789a06..4d746405 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -1170,8 +1170,8 @@ extractRecSel nm t tvs (L _ con : rest) = _ -> extractRecSel nm t tvs rest where matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)] - matching_fields flds = [ (l,f) | f@(L _ (ConDeclField _ ns _ _)) <- flds - , L l n <- ns, foExt n == nm ] + matching_fields flds = [ (locA l,f) | f@(L _ (ConDeclField _ ns _ _)) <- flds + , L l n <- ns, foExt n == nm ] data_ty -- ResTyGADT _ ty <- con_res con = ty | ConDeclGADT{} <- con = con_res_ty con diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 7c4aeb80..05375185 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -709,8 +709,8 @@ type instance Anno (HsTyVarBndr flag DocNameI) = SrcSpanAnnA type instance Anno [LocatedA (HsType DocNameI)] = SrcSpanAnnC type instance Anno (HsType DocNameI) = SrcSpanAnnA type instance Anno (DataFamInstDecl DocNameI) = SrcSpanAnnA -type instance Anno (DerivStrategy DocNameI) = SrcSpan -type instance Anno (FieldOcc DocNameI) = SrcSpan +type instance Anno (DerivStrategy DocNameI) = SrcAnn NoEpAnns +type instance Anno (FieldOcc DocNameI) = SrcAnn NoEpAnns type instance Anno (ConDeclField DocNameI) = SrcSpan type instance Anno (Located (ConDeclField DocNameI)) = SrcSpan type instance Anno [Located (ConDeclField DocNameI)] = SrcSpan @@ -720,9 +720,9 @@ type instance Anno (TyFamInstDecl DocNameI) = SrcSpanAnnA type instance Anno [LocatedA (TyFamInstDecl DocNameI)] = SrcSpanAnnL type instance Anno (FamilyDecl DocNameI) = SrcSpan type instance Anno (Sig DocNameI) = SrcSpan -type instance Anno (InjectivityAnn DocNameI) = SrcSpan +type instance Anno (InjectivityAnn DocNameI) = SrcAnn NoEpAnns type instance Anno (HsDecl DocNameI) = SrcSpanAnnA -type instance Anno (FamilyResultSig DocNameI) = SrcSpan +type instance Anno (FamilyResultSig DocNameI) = SrcAnn NoEpAnns type instance Anno (HsOuterTyVarBndrs Specificity DocNameI) = SrcSpanAnnA type instance Anno (HsSigType DocNameI) = SrcSpanAnnA -- cgit v1.2.3 From 02803910c1d040222f0bfc5b62411119c443f3a1 Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Wed, 9 Mar 2022 17:23:11 +0000 Subject: Minimum changes needed for compilation with hi-haddock With hi-haddock, of course there is a much large refactoring of haddock which could be achieved but that is left for a future patch which can implemented at any time independently of GHC. --- .../src/Haddock/Backends/Hyperlinker/Parser.hs | 5 +- haddock-api/src/Haddock/GhcUtils.hs | 4 +- haddock-api/src/Haddock/Interface.hs | 4 +- .../src/Haddock/Interface/AttachInstances.hs | 4 +- haddock-api/src/Haddock/Interface/Create.hs | 96 +++++++++++++--------- haddock-api/src/Haddock/Interface/LexParseRn.hs | 12 ++- haddock-api/src/Haddock/Interface/Rename.hs | 7 +- 7 files changed, 79 insertions(+), 53 deletions(-) (limited to 'haddock-api/src/Haddock/Interface/Create.hs') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 3929c286..a218b118 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -355,10 +355,7 @@ classify tok = ITeof -> TkUnknown ITlineComment {} -> TkComment - ITdocCommentNext {} -> TkComment - ITdocCommentPrev {} -> TkComment - ITdocCommentNamed {} -> TkComment - ITdocSection {} -> TkComment + ITdocComment {} -> TkComment ITdocOptions {} -> TkComment -- The lexer considers top-level pragmas as comments (see `pragState` in diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 3f97236a..9f9120fa 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -96,7 +96,7 @@ ifTrueJust True = Just ifTrueJust False = const Nothing sigName :: LSig GhcRn -> [IdP GhcRn] -sigName (L _ sig) = sigNameNoLoc sig +sigName (L _ sig) = sigNameNoLoc emptyOccEnv sig -- | Was this signature given by the user? isUserLSig :: forall p. UnXRec p => LSig p -> Bool @@ -193,7 +193,7 @@ getMainDeclBinderI (ValD _ d) = case collectHsBindBinders CollNoDictBinders d of [] -> [] (name:_) -> [name] -getMainDeclBinderI (SigD _ d) = sigNameNoLoc d +getMainDeclBinderI (SigD _ d) = sigNameNoLoc emptyOccEnv d getMainDeclBinderI (ForD _ (ForeignImport _ name _ _)) = [unLoc name] getMainDeclBinderI (ForD _ (ForeignExport _ _ _ _)) = [] getMainDeclBinderI _ = [] diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 804367c4..19113107 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -146,7 +146,7 @@ createIfaces verbosity modules flags instIfaceMap = do let installHaddockPlugin :: HscEnv -> HscEnv installHaddockPlugin hsc_env = - let + let old_plugins = hsc_plugins hsc_env new_plugins = old_plugins { staticPlugins = haddockPlugin : staticPlugins old_plugins } hsc_env' = hsc_env { hsc_plugins = new_plugins } @@ -362,7 +362,7 @@ processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env ] where formatName :: SrcSpan -> HsDecl GhcRn -> String - formatName loc n = p (getMainDeclBinder n) ++ case loc of + formatName loc n = p (getMainDeclBinder emptyOccEnv n) ++ case loc of RealSrcSpan rss _ -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++ show (srcSpanStartLine rss) ++ ")" _ -> "" diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index e8a79b2b..dc8afa31 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -136,12 +136,12 @@ attachToExportItem index expInfo getInstDoc getFixity export = , expItemSubDocs = subDocs } = e { expItemFixities = nubByName fst $ expItemFixities e ++ - [ (n',f) | n <- getMainDeclBinder d + [ (n',f) | n <- getMainDeclBinder emptyOccEnv d , n' <- n : (map fst subDocs ++ patsyn_names) , f <- maybeToList (getFixity n') ] } where - patsyn_names = concatMap (getMainDeclBinder . fst) patsyns + patsyn_names = concatMap (getMainDeclBinder emptyOccEnv . fst) patsyns attachFixities e = e -- spanName: attach the location to the name that is the same file as the instance location diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 4d746405..dbd4a9b2 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -35,7 +35,7 @@ import Documentation.Haddock.Doc (metaDocAppend) import Haddock.Convert (PrintRuntimeReps (..), tyThingToLHsDecl) import Haddock.GhcUtils (addClassContext, filterSigNames, lHsQTyVarsToTypes, mkEmptySigType, moduleString, parents, pretty, restrictTo, sigName, unL) -import Haddock.Interface.LexParseRn (processDocString, processDocStringParas, processDocStrings, processModuleHeader) +import Haddock.Interface.LexParseRn import Haddock.Options (Flag (..), modulePackageInfo) import Haddock.Types hiding (liftErrMsg) import Haddock.Utils (replace) @@ -57,7 +57,7 @@ import GHC.Core.Class (ClassMinimalDef, classMinimalDef) import GHC.Core.ConLike (ConLike (..)) import GHC.Data.FastString (bytesFS, unpackFS) import GHC.Driver.Ppr (showSDoc) -import GHC.HsToCore.Docs hiding (mkMaps) +import GHC.HsToCore.Docs hiding (mkMaps, unionArgMaps) import GHC.IORef (readIORef) import GHC.Stack (HasCallStack) import GHC.Tc.Types hiding (IfM) @@ -65,7 +65,7 @@ import GHC.Tc.Utils.Monad (finalSafeMode) import GHC.Types.Avail hiding (avail) import qualified GHC.Types.Avail as Avail import GHC.Types.Basic (PromotionFlag (..)) -import GHC.Types.Name (getOccString, getSrcSpan, isDataConName, isValName, nameIsLocalOrFrom, nameOccName) +import GHC.Types.Name (getOccString, getSrcSpan, isDataConName, isValName, nameIsLocalOrFrom, nameOccName, emptyOccEnv) import GHC.Types.Name.Env (lookupNameEnv) import GHC.Types.Name.Reader (GlobalRdrEnv, greMangledName, lookupGlobalRdrEnv) import GHC.Types.Name.Set (elemNameSet, mkNameSet) @@ -79,6 +79,7 @@ import GHC.Unit.State (PackageName (..), UnitState, lookupModuleInAllUnits) import qualified GHC.Utils.Outputable as O import GHC.Utils.Panic (pprPanic) import GHC.Unit.Module.Warnings +import GHC.Types.Unique.Map newtype IfEnv m = IfEnv { @@ -255,7 +256,7 @@ createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do -- Process the top-level module header documentation. (!info, header_doc) <- liftErrMsg $ processModuleHeader dflags pkg_name - tcg_rdr_env safety (thMbDocStr <|> (unLoc <$> tcg_doc_hdr)) + tcg_rdr_env safety (fmap hsDocString thMbDocStr <|> (hsDocString . unLoc <$> tcg_doc_hdr)) -- Warnings on declarations in this module decl_warnings <- liftErrMsg (mkWarningMap dflags tcg_warns tcg_rdr_env exported_names) @@ -405,7 +406,7 @@ lookupModuleDyn state pkg_qual mdlName = case pkg_qual of -- Warnings ------------------------------------------------------------------------------- -mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> ErrMsgM WarningMap +mkWarningMap :: DynFlags -> Warnings a -> GlobalRdrEnv -> [Name] -> ErrMsgM WarningMap mkWarningMap dflags warnings gre exps = case warnings of NoWarnings -> pure M.empty WarnAll _ -> pure M.empty @@ -416,18 +417,18 @@ mkWarningMap dflags warnings gre exps = case warnings of , let n = greMangledName elt, n `elem` exps ] in M.fromList <$> traverse (bitraverse pure (parseWarning dflags gre)) ws' -moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> ErrMsgM (Maybe (Doc Name)) +moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings a -> ErrMsgM (Maybe (Doc Name)) moduleWarning _ _ NoWarnings = pure Nothing moduleWarning _ _ (WarnSome _) = pure Nothing moduleWarning dflags gre (WarnAll w) = Just <$> parseWarning dflags gre w -parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Doc Name) +parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt a -> ErrMsgM (Doc Name) parseWarning dflags gre w = case w of - DeprecatedTxt _ msg -> format "Deprecated: " (foldMap (bytesFS . sl_fs . unLoc) msg) - WarningTxt _ msg -> format "Warning: " (foldMap (bytesFS . sl_fs . unLoc) msg) + DeprecatedTxt _ msg -> format "Deprecated: " (foldMap (unpackFS . sl_fs . hsDocString . unLoc) msg) + WarningTxt _ msg -> format "Warning: " (foldMap (unpackFS . sl_fs . hsDocString . unLoc) msg) where format x bs = DocWarning . DocParagraph . DocAppend (DocString x) - <$> processDocString dflags gre (mkHsDocStringUtf8ByteString bs) + <$> processDocStringFromString dflags gre bs ------------------------------------------------------------------------------- @@ -479,7 +480,7 @@ mkMaps :: DynFlags -> Maybe Package -- this package -> GlobalRdrEnv -> [Name] - -> [(LHsDecl GhcRn, [HsDocString])] + -> [(LHsDecl GhcRn, [HsDoc GhcRn])] -> ExtractedTHDocs -- ^ Template Haskell putDoc docs -> ErrMsgM Maps mkMaps dflags pkgName gre instances decls thDocs = do @@ -512,36 +513,40 @@ mkMaps dflags pkgName gre instances decls thDocs = do thMappings = do let ExtractedTHDocs _ - (DeclDocMap declDocs) - (ArgDocMap argDocs) - (DeclDocMap instDocs) = thDocs - ds2mdoc :: HsDocString -> ErrMsgM (MDoc Name) - ds2mdoc = processDocStringParas dflags pkgName gre - - declDocs' <- mapM ds2mdoc declDocs - argDocs' <- mapM (mapM ds2mdoc) argDocs - instDocs' <- mapM ds2mdoc instDocs + declDocs + argDocs + instDocs = thDocs + ds2mdoc :: (HsDoc GhcRn) -> ErrMsgM (MDoc Name) + ds2mdoc = processDocStringParas dflags pkgName gre . hsDocString + + let cvt = M.fromList . nonDetEltsUniqMap + + declDocs' <- mapM ds2mdoc (cvt declDocs) + argDocs' <- mapM (mapM ds2mdoc) (cvt argDocs) + instDocs' <- mapM ds2mdoc (cvt instDocs) return (declDocs' <> instDocs', argDocs') - mappings :: (LHsDecl GhcRn, [HsDocString]) + mappings :: (LHsDecl GhcRn, [HsDoc GhcRn]) -> ErrMsgM ( [(Name, MDoc Name)] , [(Name, IntMap (MDoc Name))] , [(Name, [LHsDecl GhcRn])] ) - mappings (ldecl@(L (SrcSpanAnn _ (RealSrcSpan l _)) decl), docStrs) = do - let declDoc :: [HsDocString] -> IntMap HsDocString + mappings (ldecl@(L (SrcSpanAnn _ (RealSrcSpan l _)) decl), hs_docStrs) = do + let docStrs = map hsDocString hs_docStrs + declDoc :: [HsDocString] -> IntMap HsDocString -> ErrMsgM (Maybe (MDoc Name), IntMap (MDoc Name)) declDoc strs m = do doc' <- processDocStrings dflags pkgName gre strs m' <- traverse (processDocStringParas dflags pkgName gre) m pure (doc', m') - (doc, args) <- declDoc docStrs (declTypeDocs decl) + (doc, args) <- declDoc docStrs (fmap hsDocString (declTypeDocs decl)) let subs :: [(Name, [HsDocString], IntMap HsDocString)] - subs = subordinates instanceMap decl + subs = map (\(n, ds, im) -> (n, map hsDocString ds, fmap hsDocString im)) + $ subordinates emptyOccEnv instanceMap decl (subDocs, subArgs) <- unzip <$> traverse (\(_, strs, m) -> declDoc strs m) subs @@ -572,7 +577,23 @@ mkMaps dflags pkgName gre instances decls thDocs = do TyFamInstD _ (TyFamInstDecl _ d') -> getLocA (feqn_tycon d') _ -> getInstLoc d names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2]. - names _ decl = getMainDeclBinder decl + names _ decl = getMainDeclBinder emptyOccEnv decl + +-- | Unions together two 'ArgDocMaps' (or ArgMaps in haddock-api), such that two +-- maps with values for the same key merge the inner map as well. +-- Left biased so @unionArgMaps a b@ prefers @a@ over @b@. + +unionArgMaps :: forall b . Map Name (IntMap b) + -> Map Name (IntMap b) + -> Map Name (IntMap b) +unionArgMaps a b = M.foldrWithKey go b a + where + go :: Name -> IntMap b + -> Map Name (IntMap b) -> Map Name (IntMap b) + go n newArgMap acc + | Just oldArgMap <- M.lookup n acc = + M.insert n (newArgMap `IM.union` oldArgMap) acc + | otherwise = M.insert n newArgMap acc -- Note [2]: ------------ @@ -634,11 +655,11 @@ mkExportItems Just exports -> liftM concat $ mapM lookupExport exports where lookupExport (IEGroup _ lev docStr, _) = liftErrMsg $ do - doc <- processDocString dflags gre docStr + doc <- processDocString dflags gre (hsDocString . unLoc $ docStr) return [ExportGroup lev "" doc] lookupExport (IEDoc _ docStr, _) = liftErrMsg $ do - doc <- processDocStringParas dflags pkgName gre docStr + doc <- processDocStringParas dflags pkgName gre (hsDocString . unLoc $ docStr) return [ExportDoc doc] lookupExport (IEDocNamed _ str, _) = liftErrMsg $ @@ -706,7 +727,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap return [export] (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds -> - let declNames = getMainDeclBinder (unL decl) + let declNames = getMainDeclBinder emptyOccEnv (unL decl) in case () of _ -- We should not show a subordinate by itself if any of its @@ -785,7 +806,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames let patSynNames = - concatMap (getMainDeclBinder . fst) bundledPatSyns + concatMap (getMainDeclBinder emptyOccEnv . fst) bundledPatSyns fixities = [ (n, f) @@ -1007,17 +1028,17 @@ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNam (concat . concat) `fmap` (for decls $ \decl -> do case decl of (L _ (DocD _ (DocGroup lev docStr))) -> do - doc <- liftErrMsg (processDocString dflags gre docStr) + doc <- liftErrMsg (processDocString dflags gre (hsDocString . unLoc $ docStr)) return [[ExportGroup lev "" doc]] (L _ (DocD _ (DocCommentNamed _ docStr))) -> do - doc <- liftErrMsg (processDocStringParas dflags pkgName gre docStr) + doc <- liftErrMsg (processDocStringParas dflags pkgName gre (hsDocString . unLoc $ docStr)) return [[ExportDoc doc]] (L _ (ValD _ valDecl)) | name:_ <- collectHsBindBinders CollNoDictBinders valDecl , Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap -> return [] _ -> - for (getMainDeclBinder (unLoc decl)) $ \nm -> do + for (getMainDeclBinder emptyOccEnv (unLoc decl)) $ \nm -> do case lookupNameEnv availEnv nm of Just avail -> availExportItem is_sig modMap thisMod @@ -1042,7 +1063,7 @@ extractDecl -> LHsDecl GhcRn -- ^ parent declaration -> Either ErrMsg (LHsDecl GhcRn) extractDecl declMap name decl - | name `elem` getMainDeclBinder (unLoc decl) = pure decl + | name `elem` getMainDeclBinder emptyOccEnv (unLoc decl) = pure decl | otherwise = case unLoc decl of TyClD _ d@ClassDecl { tcdLName = L _ clsNm @@ -1197,10 +1218,10 @@ mkVisibleNames (_, _, _, instMap) exports opts where exportName e@ExportDecl {} = name ++ subs ++ patsyns where subs = map fst (expItemSubDocs e) - patsyns = concatMap (getMainDeclBinder . fst) (expItemPats e) + patsyns = concatMap (getMainDeclBinder emptyOccEnv . fst) (expItemPats e) name = case unLoc $ expItemDecl e of InstD _ d -> maybeToList $ SrcLoc.lookupSrcSpan (getInstLoc d) instMap - decl -> getMainDeclBinder decl + decl -> getMainDeclBinder emptyOccEnv decl exportName ExportNoDecl {} = [] -- we don't count these as visible, since -- we don't want links to go to them. exportName _ = [] @@ -1217,6 +1238,7 @@ findNamedDoc name = search tell ["Cannot find documentation for: $" ++ name] return Nothing search (DocD _ (DocCommentNamed name' doc) : rest) - | name == name' = return (Just doc) + | name == name' = return (Just (hsDocString . unLoc $ doc)) + | otherwise = search rest search (_other_decl : rest) = search rest diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index a827cf66..f3b57792 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -15,6 +15,7 @@ ----------------------------------------------------------------------------- module Haddock.Interface.LexParseRn ( processDocString + , processDocStringFromString , processDocStringParas , processDocStrings , processModuleHeader @@ -38,6 +39,7 @@ import GHC.Parser.PostProcess import GHC.Driver.Ppr ( showPpr, showSDoc ) import GHC.Types.Name.Reader import GHC.Data.EnumSet as EnumSet +import GHC.Utils.Trace processDocStrings :: DynFlags -> Maybe Package -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (MDoc Name)) @@ -52,11 +54,15 @@ processDocStrings dflags pkg gre strs = do processDocStringParas :: DynFlags -> Maybe Package -> GlobalRdrEnv -> HsDocString -> ErrMsgM (MDoc Name) processDocStringParas dflags pkg gre hds = - overDocF (rename dflags gre) $ parseParas dflags pkg (unpackHDS hds) + overDocF (rename dflags gre) $ parseParas dflags pkg (renderHsDocString hds) processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Doc Name) processDocString dflags gre hds = - rename dflags gre $ parseString dflags (unpackHDS hds) + processDocStringFromString dflags gre (renderHsDocString hds) + +processDocStringFromString :: DynFlags -> GlobalRdrEnv -> String -> ErrMsgM (Doc Name) +processDocStringFromString dflags gre hds = + rename dflags gre $ parseString dflags hds processModuleHeader :: DynFlags -> Maybe Package -> GlobalRdrEnv -> SafeHaskellMode -> Maybe HsDocString -> ErrMsgM (HaddockModInfo Name, Maybe (MDoc Name)) @@ -65,7 +71,7 @@ processModuleHeader dflags pkgName gre safety mayStr = do case mayStr of Nothing -> return failure Just hds -> do - let str = unpackHDS hds + let str = renderHsDocString hds (hmi, doc) = parseModuleHeader dflags pkgName str !descr <- case hmi_description hmi of Just hmi_descr -> Just <$> rename dflags gre hmi_descr diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 98c39859..f2b3a9fa 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -191,8 +191,8 @@ renameDocumentation (Documentation mDoc mWarning) = Documentation <$> mapM renameDoc mDoc <*> mapM renameDoc mWarning -renameLDocHsSyn :: LHsDocString -> RnM LHsDocString -renameLDocHsSyn = return +renameLDocHsSyn :: Located (WithHsDocIdentifiers HsDocString a) -> RnM (Located (WithHsDocIdentifiers HsDocString b)) +renameLDocHsSyn (L l doc) = return (L l (WithHsDocIdentifiers (hsDocString doc) [])) renameDoc :: Traversable t => t (Wrap Name) -> RnM (t (Wrap DocName)) @@ -317,6 +317,7 @@ renameType t = case t of HsSpliceTy _ s -> renameHsSpliceTy s HsWildCardTy _ -> pure (HsWildCardTy noAnn) + renameSigType :: HsSigType GhcRn -> RnM (HsSigType DocNameI) renameSigType (HsSig { sig_bndrs = bndrs, sig_body = body }) = do bndrs' <- renameOuterTyVarBndrs bndrs @@ -511,7 +512,7 @@ renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars ltyvars' <- mapM renameLTyVarBndr ltyvars lcontext' <- traverse renameLContext lcontext details' <- renameH98Details details - mbldoc' <- mapM renameLDocHsSyn mbldoc + mbldoc' <- mapM (renameLDocHsSyn) mbldoc return (decl { con_ext = noExtField, con_name = lname', con_ex_tvs = ltyvars' , con_mb_cxt = lcontext' , con_forall = forall_ -- Remove when #18311 is fixed -- cgit v1.2.3 From 06b72bd9becf87e5396bb640289b63679a39ab3c Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Fri, 5 Aug 2022 19:07:23 -0400 Subject: Clean up build and testsuite for GHC 9.4 --- haddock-api/haddock-api.cabal | 14 +- haddock-api/src/Haddock.hs | 1 - haddock-api/src/Haddock/Backends/Hyperlinker.hs | 2 - haddock-api/src/Haddock/Interface.hs | 9 +- haddock-api/src/Haddock/Interface/Create.hs | 5 +- haddock-api/src/Haddock/Interface/LexParseRn.hs | 1 - haddock-api/src/Haddock/Interface/Specialize.hs | 1 - haddock-api/src/Haddock/InterfaceFile.hs | 13 -- html-test/ref/Bug1004.html | 200 ++++++------------------ html-test/ref/Bug310.html | 34 ---- html-test/ref/Bug548.html | 40 ++--- 11 files changed, 64 insertions(+), 256 deletions(-) (limited to 'haddock-api/src/Haddock/Interface/Create.hs') diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index be84f8ce..206b9aa2 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -1,10 +1,10 @@ -cabal-version: 2.0 +cabal-version: 3.0 name: haddock-api -version: 2.26.1 +version: 2.27.0 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries -license: BSD2 +license: BSD-2-Clause license-file: LICENSE author: Simon Marlow, David Waern maintainer: Alec Theriault , Alex Biehl , Simon Hengel , Mateusz Kowalczyk @@ -13,7 +13,7 @@ bug-reports: https://github.com/haskell/haddock/issues copyright: (c) Simon Marlow, David Waern category: Documentation build-type: Simple -tested-with: GHC==9.2.* +tested-with: GHC==9.4.* extra-source-files: CHANGES.md @@ -44,9 +44,9 @@ library -- this package typically supports only single major versions build-depends: base ^>= 4.16.0 - , ghc ^>= 9.3 + , ghc ^>= 9.4 , ghc-paths ^>= 0.1.0.9 - , haddock-library ^>= 1.10.0 + , haddock-library ^>= 1.10 , xhtml ^>= 3000.2.2 , parsec ^>= 3.1.13.0 @@ -180,7 +180,7 @@ test-suite spec Haddock.Backends.Hyperlinker.Parser Haddock.Backends.Hyperlinker.Types - build-depends: ghc ^>= 9.3 + build-depends: ghc ^>= 9.4 , ghc-paths ^>= 0.1.0.12 , haddock-library ^>= 1.10.0 , xhtml ^>= 3000.2.2 diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 989ca03f..ea664bcf 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -80,7 +80,6 @@ import GHC.Utils.Error import GHC.Utils.Logger import GHC.Types.Name.Cache import GHC.Unit -import GHC.Unit.State (lookupUnit) import GHC.Utils.Panic (handleGhcException) import GHC.Data.FastString diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 89828e30..9316da6d 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -26,8 +26,6 @@ import GHC.Types.SrcLoc ( realSrcLocSpan, mkRealSrcLoc, srcSpanFile ) import Data.Map as M import GHC.Data.FastString ( mkFastString ) import GHC.Unit.Module ( Module, moduleName ) -import GHC.Types.Name.Cache ( initNameCache ) -import GHC.Types.Unique.Supply ( mkSplitUniqSupply ) -- | Generate hyperlinked source for given interfaces. diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 19113107..92b727ac 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -46,7 +46,7 @@ import Haddock.Types (DocOption (..), Documentation (..), ExportItem (..), Iface import Haddock.Utils (Verbosity (..), normal, out, verbose) import Control.Monad (unless, when) -import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.IO.Class (MonadIO) import Data.IORef (atomicModifyIORef', newIORef, readIORef) import Data.List (foldl', isPrefixOf, nub) import Text.Printf (printf) @@ -54,7 +54,6 @@ import qualified Data.Map as Map import qualified Data.Set as Set import GHC hiding (verbosity) -import GHC.Data.FastString (unpackFS) import GHC.Data.Graph.Directed import GHC.Driver.Env import GHC.Driver.Monad (modifySession, withTimingM) @@ -64,13 +63,7 @@ import GHC.Plugins import GHC.Tc.Types (TcGblEnv (..), TcM) import GHC.Tc.Utils.Env (tcLookupGlobal) import GHC.Tc.Utils.Monad (getTopEnv, setGblEnv) -import GHC.Types.Name (nameIsFromExternalPackage, nameOccName) -import GHC.Types.Name.Occurrence (isTcOcc) -import GHC.Types.Name.Reader (globalRdrEnvElts, greMangledName, unQualOK) -import GHC.Unit.Module.Env (ModuleSet, emptyModuleSet, mkModuleSet, unionModuleSet) import GHC.Unit.Module.Graph -import GHC.Unit.Module.ModSummary (isBootSummary) -import GHC.Unit.Types (IsBootInterface (..)) import GHC.Utils.Error (withTiming) #if defined(mingw32_HOST_OS) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index b832128f..e3c4a529 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -54,7 +54,7 @@ import Data.Traversable (for) import GHC hiding (lookupName) import GHC.Core.Class (ClassMinimalDef, classMinimalDef) import GHC.Core.ConLike (ConLike (..)) -import GHC.Data.FastString (bytesFS, unpackFS) +import GHC.Data.FastString (unpackFS) import GHC.Driver.Ppr (showSDoc) import GHC.HsToCore.Docs hiding (mkMaps, unionArgMaps) import GHC.IORef (readIORef) @@ -1137,8 +1137,7 @@ extractDecl declMap name decl _ -> Left "internal: extractDecl (ClsInstD)" _ -> Left ("extractDecl: Unhandled decl for " ++ getOccString name) -extractPatternSyn :: HasCallStack - => Name -> Name +extractPatternSyn :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> Either ErrMsg (LSig GhcRn) extractPatternSyn nm t tvs cons = diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 4e1964af..455f3314 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -39,7 +39,6 @@ import GHC.Parser.PostProcess import GHC.Driver.Ppr ( showPpr, showSDoc ) import GHC.Types.Name.Reader import GHC.Data.EnumSet as EnumSet -import GHC.Utils.Trace processDocStrings :: DynFlags -> Maybe Package -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (MDoc Name)) diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index d1164858..ca6b9e74 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -16,7 +16,6 @@ import Haddock.Syb import Haddock.Types import GHC -import GHC.Types.Basic ( PromotionFlag(..) ) import GHC.Types.Name import GHC.Data.FastString import GHC.Builtin.Types ( listTyConName, unrestrictedFunTyConName ) diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index f9861708..e6db49c0 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -309,19 +309,6 @@ putInterfaceFile_ bh (InterfaceFile env info ifaces) = do put_ bh info put_ bh ifaces -getInterfaceFile :: BinHandle -> Word16 -> IO InterfaceFile -getInterfaceFile bh v | v <= 38 = do - env <- get bh - let info = PackageInfo (PackageName mempty) (makeVersion []) - ifaces <- get bh - return (InterfaceFile env info ifaces) -getInterfaceFile bh _ = do - env <- get bh - info <- get bh - ifaces <- get bh - return (InterfaceFile env info ifaces) - - instance Binary InstalledInterface where put_ bh (InstalledInterface modu is_sig info docMap argMap exps visExps opts fixMap) = do diff --git a/html-test/ref/Bug1004.html b/html-test/ref/Bug1004.html index 9fe6f84e..bbe2f599 100644 --- a/html-test/ref/Bug1004.html +++ b/html-test/ref/Bug1004.html @@ -48,26 +48,6 @@ >

Bug1004

Synopsis

Documentation

) (a :: k) #

Lifted product of functors.

Constructors

Product f g)

Since: base-4.9.0.0

 Product f g)

Since: base-4.9.0.0

 Product f g)

Since: base-4.9.0.0

 Product f g)

Since: base-4.9.0.0

 Product f g)

Since: base-4.9.0.0

 Product f g)

Since: base-4.9.0.0

 Product f g)

Since: base-4.9.0.0

 Product f g)

Since: base-4.9.0.0

 Product f g)

Since: base-4.9.0.0

 Product f g)

Since: base-4.9.0.0

 Product f g)

Since: base-4.9.0.0

 Product f g)

Since: base-4.9.0.0

 Product f g)

Since: base-4.9.0.0

 Product f g a)

Since: base-4.9.0.0

 Product f g a)

Since: base-4.16.0.0

 Product f g a)

Since: base-4.16.0.0

 Product f g a)

Since: base-4.9.0.0

 Product f g a)

Since: base-4.9.0.0

 Product f g a)

Since: base-4.9.0.0

 Product f g a)

Since: base-4.9.0.0

 Type)

Since: base-4.9.0.0

 Product f g a)

Since: base-4.9.0.0

 

Bug310

Synopsis

Documentation

Natural where ... infixl 6 #

Addition of type-level naturals.

Since: base-4.7.0.0

WrappedArrow a b)

Since: base-2.1

 WrappedArrow a b)

Since: base-2.1

 WrappedArrow a b)

Since: base-2.1

 Type)

Since: base-4.7.0.0

 WrappedArrow a b c)

Since: base-4.7.0.0