diff options
Diffstat (limited to 'haddock-api/src/Haddock/Backends/LaTeX.hs')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/LaTeX.hs | 103 |
1 files changed, 53 insertions, 50 deletions
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 024a6c51..df81fd6e 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -21,16 +21,17 @@ import Documentation.Haddock.Markup import Haddock.Types import Haddock.Utils import Haddock.GhcUtils -import Pretty hiding (Doc, quote) -import qualified Pretty +import GHC.Utils.Ppr hiding (Doc, quote) +import qualified GHC.Utils.Ppr as Pretty -import BasicTypes ( PromotionFlag(..) ) +import GHC.Types.Basic ( PromotionFlag(..) ) import GHC -import OccName -import Name ( nameOccName ) -import RdrName ( rdrNameOcc ) -import FastString ( unpackFS ) -import Outputable ( panic) +import GHC.Types.Name.Occurrence +import GHC.Types.Name ( nameOccName ) +import GHC.Types.Name.Reader ( rdrNameOcc ) +import GHC.Core.Type ( Specificity(..) ) +import GHC.Data.FastString ( unpackFS ) +import GHC.Utils.Outputable ( panic) import qualified Data.Map as Map import System.Directory @@ -356,8 +357,6 @@ ppFamDecl associated doc instances decl unicode = , equals , ppType unicode (unLoc rhs) ] - ppFamDeclEqn (XHsImplicitBndrs nec) = noExtCon nec - ppFamDeclEqn (HsIB { hsib_body = XFamEqn nec}) = noExtCon nec instancesBit = ppDocInstances unicode instances @@ -366,7 +365,6 @@ ppFamHeader :: FamilyDecl DocNameI -- ^ family header to print -> Bool -- ^ unicode -> Bool -- ^ is the family associated? -> LaTeX -ppFamHeader (XFamilyDecl nec) _ _ = noExtCon nec ppFamHeader (FamilyDecl { fdLName = L _ name , fdTyVars = tvs , fdInfo = info @@ -389,7 +387,6 @@ ppFamHeader (FamilyDecl { fdLName = L _ name NoSig _ -> empty KindSig _ kind -> dcolon unicode <+> ppLKind unicode kind TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode bndr - XFamilyResultSig nec -> noExtCon nec injAnn = case injectivity of Nothing -> empty @@ -486,9 +483,9 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs do_args :: Int -> LaTeX -> HsType DocNameI -> [(LaTeX, LaTeX)] - do_args _n leader (HsForAllTy _ fvf tvs ltype) + do_args _n leader (HsForAllTy _ tele ltype) = [ ( decltt leader - , decltt (ppForAllPart unicode tvs fvf) + , decltt (ppHsForAllTelescope tele unicode) <+> ppLType unicode ltype ) ] do_args n leader (HsQualTy _ lctxt ltype) @@ -496,13 +493,13 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ , decltt (ppLContextNoArrow lctxt unicode) <+> nl ) : do_largs n (darrow unicode) ltype - do_args n leader (HsFunTy _ (L _ (HsRecTy _ fields)) r) + do_args n leader (HsFunTy _ _w (L _ (HsRecTy _ fields)) r) = [ (decltt ldr, latex <+> nl) | (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma) , let latex = ppSideBySideField subdocs unicode field ] ++ do_largs (n+1) (gadtEnd <+> arrow unicode) r - do_args n leader (HsFunTy _ lt r) + do_args n leader (HsFunTy _ _w lt r) = (decltt leader, decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl) : do_largs (n+1) (arrow unicode) r do_args n leader t @@ -525,13 +522,20 @@ ppTypeSig nms ty unicode = <+> ppType unicode ty --- | Pretty-print type variables. -ppTyVars :: Bool -> [LHsTyVarBndr DocNameI] -> [LaTeX] -ppTyVars unicode = map (ppHsTyVarBndr unicode . unLoc) +ppHsForAllTelescope :: HsForAllTelescope DocNameI -> Bool -> LaTeX +ppHsForAllTelescope tele unicode = case tele of + HsForAllVis { hsf_vis_bndrs = bndrs } -> + hsep (forallSymbol unicode : ppTyVars bndrs) <> text "\\" <> arrow unicode + HsForAllInvis { hsf_invis_bndrs = bndrs } -> + hsep (forallSymbol unicode : ppTyVars bndrs) <> dot + + +ppTyVars :: [LHsTyVarBndr flag DocNameI] -> [LaTeX] +ppTyVars = map (ppSymName . getName . hsLTyVarNameI) tyvarNames :: LHsQTyVars DocNameI -> [Name] -tyvarNames = map (getName . hsTyVarBndrName . unLoc) . hsQTvExplicit +tyvarNames = map (getName . hsLTyVarNameI) . hsQTvExplicit declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX @@ -743,7 +747,7 @@ ppDataDecl pats instances subdocs doc dataDecl unicode = -- ppConstrHdr is for (non-GADT) existentials constructors' syntax ppConstrHdr :: Bool -- ^ print explicit foralls - -> [LHsTyVarBndr DocNameI] -- ^ type variables + -> [LHsTyVarBndr Specificity DocNameI] -- ^ type variables -> HsContext DocNameI -- ^ context -> Bool -- ^ unicode -> LaTeX @@ -751,7 +755,7 @@ ppConstrHdr forall_ tvs ctxt unicode = ppForall <> ppCtxt where ppForall | null tvs || not forall_ = empty - | otherwise = ppForAllPart unicode tvs ForallInvis + | otherwise = ppHsForAllTelescope (mkHsForAllInvisTeleI tvs) unicode ppCtxt | null ctxt = empty @@ -795,7 +799,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = | hasArgDocs -> header_ <+> ppOcc | otherwise -> hsep [ header_ , ppOcc - , hsep (map (ppLParendType unicode) args) + , hsep (map (ppLParendType unicode . hsScaledThing) args) ] -- Record constructor, e.g. 'Identity { runIdentity :: a }' @@ -805,9 +809,9 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = InfixCon arg1 arg2 | hasArgDocs -> header_ <+> ppOcc | otherwise -> hsep [ header_ - , ppLParendType unicode arg1 + , ppLParendType unicode (hsScaledThing arg1) , ppOccInfix - , ppLParendType unicode arg2 + , ppLParendType unicode (hsScaledThing arg2) ] ConDeclGADT{} @@ -817,9 +821,8 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = -- ++AZ++ make this prepend "{..}" when it is a record style GADT , ppLType unicode (getGADTConType con) ] - XConDecl nec -> noExtCon nec - fieldPart = case (con, getConArgs con) of + fieldPart = case (con, getConArgsI con) of -- Record style GADTs (ConDeclGADT{}, RecCon _) -> doConstrArgsWithDocs [] @@ -827,10 +830,10 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = (_, RecCon (L _ fields)) -> doRecordFields fields -- Any GADT or a regular H98 prefix data constructor - (_, PrefixCon args) | hasArgDocs -> doConstrArgsWithDocs args + (_, PrefixCon args) | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args) -- An infix H98 data constructor - (_, InfixCon arg1 arg2) | hasArgDocs -> doConstrArgsWithDocs [arg1,arg2] + (_, InfixCon arg1 arg2) | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing [arg1,arg2]) _ -> empty @@ -851,7 +854,6 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = [ l <+> text "\\enspace" <+> r | (l,r) <- ppSubSigLike unicode (unLoc (getGADTConType con)) argDocs subdocs (dcolon unicode) ] - XConDecl nec -> noExtCon nec -- don't use "con_doc con", in case it's reconstructed from a .hi file, @@ -871,7 +873,6 @@ ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) = -- 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 -ppSideBySideField _ _ (XConDeclField nec) = noExtCon nec -- | Pretty-print a bundled pattern synonym @@ -924,7 +925,8 @@ ppDataHeader _ _ = error "ppDataHeader: illegal argument" -- * Type applications -------------------------------------------------------------------------------- -ppAppDocNameTyVarBndrs :: Bool -> DocName -> [LHsTyVarBndr DocNameI] -> LaTeX +ppAppDocNameTyVarBndrs :: RenderableBndrFlag flag => + Bool -> DocName -> [LHsTyVarBndr flag DocNameI] -> LaTeX ppAppDocNameTyVarBndrs unicode n vs = ppTypeApp n vs ppDN (ppHsTyVarBndr unicode . unLoc) where @@ -1034,11 +1036,21 @@ ppLHsTypeArg unicode (HsTypeArg _ ki) = atSign unicode <> ppLParendType unicode ki ppLHsTypeArg _ (HsArgPar _) = text "" -ppHsTyVarBndr :: Bool -> HsTyVarBndr DocNameI -> LaTeX -ppHsTyVarBndr _ (UserTyVar _ (L _ name)) = ppDocName name -ppHsTyVarBndr unicode (KindedTyVar _ (L _ name) kind) = - parens (ppDocName name <+> dcolon unicode <+> ppLKind unicode kind) -ppHsTyVarBndr _ (XTyVarBndr nec) = noExtCon nec +class RenderableBndrFlag flag where + ppHsTyVarBndr :: Bool -> HsTyVarBndr flag DocNameI -> LaTeX + +instance RenderableBndrFlag () where + ppHsTyVarBndr _ (UserTyVar _ _ (L _ name)) = ppDocName name + ppHsTyVarBndr unicode (KindedTyVar _ _ (L _ name) kind) = + parens (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind + +instance RenderableBndrFlag Specificity where + ppHsTyVarBndr _ (UserTyVar _ SpecifiedSpec (L _ name)) = ppDocName name + ppHsTyVarBndr _ (UserTyVar _ InferredSpec (L _ name)) = braces $ ppDocName name + ppHsTyVarBndr unicode (KindedTyVar _ SpecifiedSpec (L _ name) kind) = + parens (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind + ppHsTyVarBndr unicode (KindedTyVar _ InferredSpec (L _ name) kind) = + braces (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind ppLKind :: Bool -> LHsKind DocNameI -> LaTeX ppLKind unicode y = ppKind unicode (unLoc y) @@ -1046,30 +1058,21 @@ ppLKind unicode y = ppKind unicode (unLoc y) ppKind :: Bool -> HsKind DocNameI -> LaTeX ppKind unicode ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode - -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell -ppForAllPart :: Bool -> [LHsTyVarBndr DocNameI] -> ForallVisFlag -> LaTeX -ppForAllPart unicode tvs fvf = hsep (forallSymbol unicode : tvs') <> fv - where - tvs' = ppTyVars unicode tvs - fv = case fvf of - ForallVis -> text "\\ " <> arrow unicode - ForallInvis -> dot - ppr_mono_lty :: LHsType DocNameI -> Bool -> LaTeX ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode ppr_mono_ty :: HsType DocNameI -> Bool -> LaTeX -ppr_mono_ty (HsForAllTy _ fvf tvs ty) unicode - = sep [ ppForAllPart unicode tvs fvf +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 , ppr_mono_lty ty unicode ] -ppr_mono_ty (HsFunTy _ ty1 ty2) u +ppr_mono_ty (HsFunTy _ _ ty1 ty2) u = sep [ ppr_mono_lty ty1 u , arrow u <+> ppr_mono_lty ty2 u ] @@ -1078,7 +1081,7 @@ ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name ppr_mono_ty (HsTyVar _ IsPromoted (L _ name)) _ = char '\'' <> ppDocName name ppr_mono_ty (HsTupleTy _ con tys) u = tupleParens con (map (ppLType u) tys) ppr_mono_ty (HsSumTy _ tys) u = sumParens (map (ppLType u) tys) -ppr_mono_ty (HsKindSig _ ty kind) u = ppr_mono_lty ty u <+> dcolon u <+> ppLKind u kind +ppr_mono_ty (HsKindSig _ ty kind) u = parens (ppr_mono_lty ty u <+> dcolon u <+> ppLKind u kind) ppr_mono_ty (HsListTy _ ty) u = brackets (ppr_mono_lty ty u) ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u ppr_mono_ty (HsSpliceTy v _) _ = absurd v |