diff options
Diffstat (limited to 'haddock-api/src/Haddock/Backends/Xhtml')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 44 |
1 files changed, 23 insertions, 21 deletions
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 2c3da7a9..3dea1012 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 $ @@ -967,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 ] _ -> [] @@ -1025,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 @@ -1035,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 @@ -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 _ _ @@ -1248,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) @@ -1279,15 +1281,15 @@ ppr_mono_ty (HsAppKindTy _ fun_ty arg_ki) unicode qual _ = hsep [ppr_mono_lty fun_ty unicode qual HideEmptyContexts , atSign unicode <> ppr_mono_lty arg_ki unicode qual HideEmptyContexts] -ppr_mono_ty (HsOpTy _ ty1 op ty2) unicode qual _ - = ppr_mono_lty ty1 unicode qual HideEmptyContexts <+> ppr_op <+> ppr_mono_lty ty2 unicode qual HideEmptyContexts +ppr_mono_ty (HsOpTy _ prom ty1 op ty2) unicode qual _ + = ppr_mono_lty ty1 unicode qual HideEmptyContexts <+> ppr_op_prom <+> ppr_mono_lty ty2 unicode qual HideEmptyContexts where - -- `(:)` is valid in type signature only as constructor to promoted list - -- and needs to be quoted in code so we explicitly quote it here too. - ppr_op - | (getOccString . getName . unL) op == ":" = promoQuote ppr_op' - | otherwise = ppr_op' - ppr_op' = ppLDocName qual Infix op + ppr_op_prom + | isPromoted prom + = promoQuote ppr_op + | otherwise + = ppr_op + ppr_op = ppLDocName qual Infix op ppr_mono_ty (HsParTy _ ty) unicode qual emptyCtxts = parens (ppr_mono_lty ty unicode qual emptyCtxts) |