aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock')
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs143
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs17
-rw-r--r--haddock-api/src/Haddock/Utils.hs2
3 files changed, 63 insertions, 99 deletions
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 68149b41..dfeb1428 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -213,9 +213,9 @@ processExports (e : es) =
isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName)
-isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames (L _ t) _))
+isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames t))
, expItemMbDoc = (Documentation Nothing Nothing, argDocs) }
- | Map.null argDocs = Just (map unLoc lnames, t)
+ | Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t))
isSimpleSig _ = Nothing
@@ -250,8 +250,8 @@ ppDocGroup lev doc = sec lev <> braces doc
declNames :: LHsDecl DocName -> [DocName]
declNames (L _ decl) = case decl of
TyClD d -> [tcdName d]
- SigD (TypeSig lnames _ _) -> map unLoc lnames
- SigD (PatSynSig lname _ _ _ _) -> [unLoc lname]
+ SigD (TypeSig lnames _ ) -> map unLoc lnames
+ SigD (PatSynSig lname _) -> [unLoc lname]
ForD (ForeignImport (L _ n) _ _ _) -> [n]
ForD (ForeignExport (L _ n) _ _ _) -> [n]
_ -> error "declaration not supported by declNames"
@@ -293,10 +293,11 @@ ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of
-- TyClD d@(TySynonym {})
-- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode
-- Family instances happen via FamInst now
- TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode
- SigD (TypeSig lnames (L _ t) _) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) t unicode
- SigD (PatSynSig lname qtvs prov req ty) ->
- ppLPatSig loc (doc, fnArgsDoc) lname qtvs prov req ty unicode
+ TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode
+ SigD (TypeSig lnames t) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames)
+ (hsSigWcType t) unicode
+ SigD (PatSynSig lname ty) ->
+ ppLPatSig loc (doc, fnArgsDoc) lname ty unicode
ForD d -> ppFor loc (doc, fnArgsDoc) d unicode
InstD _ -> empty
_ -> error "declaration not supported by ppDecl"
@@ -311,8 +312,8 @@ ppTyFam _ _ _ _ _ =
ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> LaTeX
-ppFor loc doc (ForeignImport (L _ name) (L _ typ) _ _) unicode =
- ppFunSig loc doc [name] typ unicode
+ppFor loc doc (ForeignImport (L _ name) typ _ _) unicode =
+ ppFunSig loc doc [name] (hsSigType typ) unicode
ppFor _ _ _ _ = error "ppFor error in Haddock.Backends.LaTeX"
-- error "foreign declarations are currently not supported by --latex"
@@ -329,7 +330,9 @@ ppTySyn loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars
, tcdRhs = ltype }) unicode
= ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode
where
- hdr = hsep (keyword "type" : ppDocBinder name : ppTyVars ltyvars)
+ hdr = hsep (keyword "type"
+ : ppDocBinder name
+ : map ppSymName (tyvarNames ltyvars))
full = hdr <+> char '=' <+> ppLType unicode ltype
ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn"
@@ -340,9 +343,9 @@ ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn"
-------------------------------------------------------------------------------
-ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> HsType DocName
+ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> LHsType DocName
-> Bool -> LaTeX
-ppFunSig loc doc docnames typ unicode =
+ppFunSig loc doc docnames (L _ typ) unicode =
ppTypeOrFunSig loc docnames typ doc
( ppTypeSig names typ False
, hsep . punctuate comma $ map ppSymName names
@@ -352,29 +355,17 @@ ppFunSig loc doc docnames typ unicode =
names = map getName docnames
ppLPatSig :: SrcSpan -> DocForDecl DocName -> Located DocName
- -> (HsExplicitFlag, LHsTyVarBndrs DocName)
- -> LHsContext DocName -> LHsContext DocName
- -> LHsType DocName
+ -> LHsSigType DocName
-> Bool -> LaTeX
-ppLPatSig _loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq (L _ ty) unicode
+ppLPatSig _loc (doc, _argDocs) (L _ name) ty unicode
= declWithDoc pref1 (documentationToLaTeX doc)
where
pref1 = hsep [ keyword "pattern"
, ppDocBinder name
, dcolon unicode
- , ppLTyVarBndrs expl qtvs unicode
- , ctx
- , ppType unicode ty
+ , ppLType unicode (hsSigType ty)
]
- ctx = case (ppLContextMaybe lprov unicode, ppLContextMaybe lreq unicode) of
- (Nothing, Nothing) -> empty
- (Nothing, Just req) -> parens empty <+> darr <+> req <+> darr
- (Just prov, Nothing) -> prov <+> darr
- (Just prov, Just req) -> prov <+> darr <+> req <+> darr
-
- darr = darrow unicode
-
ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName
-> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX)
-> Bool -> LaTeX
@@ -394,22 +385,14 @@ ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0)
arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs
do_args :: Int -> LaTeX -> (HsType DocName) -> LaTeX
- do_args n leader (HsForAllTy Explicit _ tvs lctxt ltype)
- = decltt leader <->
- decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+>
- ppLContextNoArrow lctxt unicode) <+> nl $$
- do_largs n (darrow unicode) ltype
-
- do_args n leader (HsForAllTy Qualified e a lctxt ltype)
- = do_args n leader (HsForAllTy Implicit e a lctxt ltype)
- do_args n leader (HsForAllTy Implicit _ _ lctxt ltype)
- | not (null (unLoc lctxt))
- = decltt leader <-> decltt (ppLContextNoArrow lctxt unicode) <+> nl $$
- do_largs n (darrow unicode) ltype
- -- if we're not showing any 'forall' or class constraints or
- -- anything, skip having an empty line for the context.
- | otherwise
- = do_largs n leader ltype
+ do_args _n leader (HsForAllTy tvs ltype)
+ = decltt leader
+ <-> decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]))
+ <+> ppLType unicode ltype
+ do_args n leader (HsQualTy lctxt ltype)
+ = decltt leader
+ <-> ppLContextNoArrow lctxt unicode <+> nl $$
+ do_largs n (darrow unicode) ltype
do_args n leader (HsFunTy lt r)
= decltt leader <-> decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl $$
do_largs (n+1) (arrow unicode) r
@@ -424,12 +407,12 @@ ppTypeSig nms ty unicode =
<+> ppType unicode ty
-ppTyVars :: LHsTyVarBndrs DocName -> [LaTeX]
-ppTyVars tvs = map ppSymName (tyvarNames tvs)
+ppTyVars :: [LHsTyVarBndr DocName] -> [LaTeX]
+ppTyVars = map (ppSymName . getName . hsLTyVarName)
-tyvarNames :: LHsTyVarBndrs DocName -> [Name]
-tyvarNames = map getName . hsLTyVarNames
+tyvarNames :: LHsQTyVars DocName -> [Name]
+tyvarNames = map (getName . hsLTyVarName) . hsQTvBndrs
declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX
@@ -478,12 +461,12 @@ rDoc = maybeDoc . fmap latexStripTrailingWhitespace
ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName
- -> LHsTyVarBndrs DocName -> [Located ([Located DocName], [Located DocName])]
+ -> LHsQTyVars DocName -> [Located ([Located DocName], [Located DocName])]
-> Bool -> LaTeX
ppClassHdr summ lctxt n tvs fds unicode =
keyword "class"
<+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else empty)
- <+> ppAppDocNameNames summ n (tyvarNames $ tvs)
+ <+> ppAppDocNameNames summ n (tyvarNames tvs)
<+> ppFds fds unicode
@@ -521,8 +504,8 @@ ppClassDecl instances loc doc subdocs
methodTable =
text "\\haddockpremethods{}\\textbf{Methods}" $$
- vcat [ ppFunSig loc doc names typ unicode
- | L _ (TypeSig lnames (L _ typ) _) <- lsigs
+ vcat [ ppFunSig loc doc names (hsSigWcType typ) unicode
+ | L _ (TypeSig lnames typ) <- lsigs
, let doc = lookupAnySubdoc (head names) subdocs
names = map unLoc lnames ]
-- FIXME: is taking just the first name ok? Is it possible that
@@ -613,21 +596,20 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode
-- ppConstrHdr is for (non-GADT) existentials constructors' syntax
-ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool -> LaTeX
+ppConstrHdr :: Bool -> [Name] -> HsContext DocName -> Bool -> LaTeX
ppConstrHdr forall tvs ctxt unicode
= (if null tvs then empty else ppForall)
<+>
(if null ctxt then empty else ppContextNoArrow ctxt unicode <+> darrow unicode <+> text " ")
where
ppForall = case forall of
- Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". "
- Qualified -> empty
- Implicit -> empty
+ True -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". "
+ False -> empty
ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX
-> LConDecl DocName -> LaTeX
-ppSideBySideConstr subdocs unicode leader (L _ con) =
+ppSideBySideConstr subdocs unicode leader (L loc con) =
leader <->
case con_res con of
ResTyH98 -> case con_details con of
@@ -661,13 +643,13 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
doRecordFields fields =
vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields))
- doGADTCon args resTy = decltt (ppOcc <+> dcolon unicode <+> hsep [
- ppForAll forall ltvs (con_cxt con) unicode,
- ppLType unicode (foldr mkFunTy resTy args) ]
+ doGADTCon args resTy = decltt (ppOcc <+> dcolon unicode <+>
+ ppLType unicode (mk_forall $ mk_phi $
+ foldr mkFunTy resTy args)
) <-> rDoc mbDoc
- header_ = ppConstrHdr forall tyVars context
+ header_ = ppConstrHdr (con_explicit con) tyVars context
occ = map (nameOccName . getName . unLoc) $ con_names con
ppOcc = case occ of
[one] -> ppBinder one
@@ -675,7 +657,12 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
ltvs = con_qvars con
tyVars = tyvarNames (con_qvars con)
context = unLoc (con_cxt con)
- forall = con_explicit con
+
+ mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvBndrs ltvs) ty)
+ | otherwise = ty
+ mk_phi ty | null context = ty
+ | otherwise = L loc (HsQualTy (con_cxt con) ty)
+
-- don't use "con_doc con", in case it's reconstructed from a .hi file,
-- or also because we want Haddock to do the doc-parsing, not GHC.
mbDoc = case con_names con of
@@ -791,9 +778,6 @@ ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> LaTeX
ppLContext = ppContext . unLoc
ppLContextNoArrow = ppContextNoArrow . unLoc
-ppLContextMaybe :: Located (HsContext DocName) -> Bool -> Maybe LaTeX
-ppLContextMaybe = ppContextNoLocsMaybe . map unLoc . unLoc
-
ppContextNoLocsMaybe :: [HsType DocName] -> Bool -> Maybe LaTeX
ppContextNoLocsMaybe [] _ = Nothing
ppContextNoLocsMaybe cxt unicode = Just $ pp_hs_context cxt unicode
@@ -879,34 +863,19 @@ ppKind unicode ki = ppr_mono_ty pREC_TOP ki unicode
-- Drop top-level for-all type variables in user style
-- since they are implicit in Haskell
-ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName
- -> Located (HsContext DocName) -> Bool -> LaTeX
-ppForAll expl tvs cxt unicode = ppLTyVarBndrs expl tvs unicode <+> ppLContext cxt unicode
-
-ppLTyVarBndrs :: HsExplicitFlag -> LHsTyVarBndrs DocName
- -> Bool -> LaTeX
-ppLTyVarBndrs expl tvs unicode
- | show_forall = hsep (forallSymbol unicode : ppTyVars tvs) <> dot
- | otherwise = empty
- where
- show_forall = not (null (hsQTvBndrs tvs)) && is_explicit
- is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False}
-
ppr_mono_lty :: Int -> LHsType DocName -> Bool -> LaTeX
ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode
ppr_mono_ty :: Int -> HsType DocName -> Bool -> LaTeX
-ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode
+ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode
= maybeParen ctxt_prec pREC_FUN $
- hsep [ppForAll expl tvs ctxt' unicode, ppr_mono_lty pREC_TOP ty unicode]
- where
- anonWC :: HsType DocName
- anonWC = HsWildCardTy (AnonWildCard (Undocumented underscore))
- underscore = mkUnboundName (mkRdrUnqual (mkTyVarOcc "_"))
- ctxt'
- | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt
- | otherwise = ctxt
+ sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> dot
+ , ppr_mono_lty pREC_TOP ty unicode ]
+ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode
+ = maybeParen ctxt_prec pREC_FUN $
+ sep [ ppLContext ctxt unicode
+ , ppr_mono_lty pREC_TOP ty unicode ]
ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty
ppr_mono_ty _ (HsTyVar name) _ = ppDocName name
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index f94daabf..7f1d7d07 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -50,8 +50,8 @@ ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs spl
TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual
TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual
SigD (TypeSig lnames lty _) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames lty fixities splice unicode qual
- SigD (PatSynSig lname qtvs prov req ty) ->
- ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname qtvs prov req ty fixities splice unicode qual
+ SigD (PatSynSig lname ty) ->
+ ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname ty fixities splice unicode qual
ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual
InstD _ -> noHtml
_ -> error "declaration not supported by ppDecl"
@@ -74,23 +74,18 @@ ppFunSig summary links loc doc docnames typ fixities splice unicode qual =
pp_typ = ppType unicode qual typ
ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
- Located DocName ->
- (HsExplicitFlag, LHsTyVarBndrs DocName) ->
- LHsContext DocName -> LHsContext DocName ->
- LHsType DocName ->
+ Located DocName -> LHsSigType DocName
[(DocName, Fixity)] ->
Splice -> Unicode -> Qualification -> Html
-ppLPatSig summary links loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq typ fixities splice unicode qual
+ppLPatSig summary links loc (doc, _argDocs) (L _ name) typ fixities splice unicode qual
| summary = pref1
| otherwise = topDeclElem links loc splice [name] (pref1 <+> ppFixities fixities qual)
+++ docSection Nothing qual doc
where
pref1 = hsep [ keyword "pattern"
- , ppBinder summary occname
+ , ppDocBinder name
, dcolon unicode
- , ppLTyVarBndrs expl qtvs unicode qual
- , cxt
- , ppLType unicode qual typ
+ , ppLType unicode (hsSigType ty)
]
cxt = case (ppLContextMaybe lprov unicode qual, ppLContextMaybe lreq unicode qual) of
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 6a499f64..f7a32dd3 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -132,7 +132,7 @@ mkEmptySigWcType ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs ty)
addClassContext :: Name -> LHsQTyVars Name -> LSig Name -> LSig Name
-- Add the class context to a class-op signature
-addClassContxt cls tvs0 (L pos (ClassOpSig _ lname ltype))
+addClassContext cls tvs0 (L pos (ClassOpSig _ lname ltype))
= L pos (TypeSig lname (mkEmptySigWcType (go (hsSigType ltype))))
-- The mkEmptySigWcType is suspicious
where
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 17:05:37 +0000