aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/HaddockHtml.hs147
-rw-r--r--src/HaddockLex.hs2
-rw-r--r--src/HaddockParse.y3
-rw-r--r--src/HaddockTypes.hs8
4 files changed, 92 insertions, 68 deletions
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index 461b698a..ea6d3f73 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -11,7 +11,7 @@ import HaddockVersion
import HaddockTypes
import HsSyn
-import Maybe ( fromJust, isJust )
+import Maybe ( fromJust, isNothing )
import FiniteMap
import List ( sortBy )
import Char ( toUpper, toLower )
@@ -253,8 +253,6 @@ ppHtmlIndex title ifaces = do
else
anchor ! [href (linkId mod nm)] << toHtml mod
| (Module mod, defining) <- entries ])
- where
- defining_mods = [ m | (Module m, True) <- entries ]
nameBeginsWith (HsTyClsName id) c = idBeginsWith id c
nameBeginsWith (HsVarName id) c = idBeginsWith id c
@@ -379,47 +377,46 @@ keepDecl _ = False
-- -----------------------------------------------------------------------------
-- Data & newtype declarations
--- First, the abstract case:
-
-ppHsDataDecl doc_map summary (HsDataDecl loc ctx nm args [] drv) =
- declWithDoc summary (lookupFM doc_map nm)
- (ppHsDataHeader summary nm args)
-
--- Second, the summary cases:
-
-ppHsDataDecl doc_map True (HsDataDecl loc ctx nm args [con] drv) =
+ppShortDataDecl doc_map summary (HsDataDecl loc ctx nm args [con] drv) =
declBox ( -- single constructor special case
- ppHsDataHeader True nm args
- <+> equals <+> ppHsSummaryConstr con
+ ppHsDataHeader summary nm args
+ <+> equals <+> ppShortConstr summary con
)
-ppHsDataDecl doc_map True (HsDataDecl loc ctx nm args cons drv) =
- td << (
- vanillaTable << (
+ppShortDataDecl doc_map summary (HsDataDecl loc ctx nm args cons drv) =
+ declBox << vanillaTable << (
aboves (
- (declBox (ppHsDataHeader True nm args) :
+ (declBox (ppHsDataHeader summary nm args) :
zipWith do_constr ('=':repeat '|') cons
)
)
- ))
+ )
where do_constr c con = tda [theclass "condecl"] << (
- toHtml [c] <+> ppHsSummaryConstr con)
+ toHtml [c] <+> ppShortConstr summary con)
--- Now, the full expanded documented version:
+-- First, the abstract case:
-ppHsDataDecl doc_map False decl@(HsDataDecl loc ctx nm args cons drv) =
- td << (
- vanillaTable << (
- if isJust doc
- then aboves [header, datadoc, constrs]
- else aboves [header, constrs]
- )
- )
+ppHsDataDecl doc_map summary (HsDataDecl loc ctx nm args [] drv) =
+ declWithDoc summary (lookupFM doc_map nm)
+ (ppHsDataHeader summary nm args)
+
+-- The rest of the cases:
+
+ppHsDataDecl doc_map summary decl@(HsDataDecl loc ctx nm args cons drv)
+ | summary || (isNothing doc && all constr_has_no_doc cons)
+ = ppShortDataDecl doc_map summary decl
+
+ | otherwise
+ = td << vanillaTable << (header </> datadoc </> constrs)
where
header = declBox (ppHsDataHeader False nm args)
datadoc = docBox (markup htmlMarkup (fromJust doc))
+
constr_hdr = tda [ theclass "section4" ] << toHtml "Constructors"
- constrs = tda [theclass "databody"] << (
+ constrs
+ | null cons = Html.emptyTable
+ | otherwise =
+ tda [theclass "databody"] << (
table ! [width "100%", cellpadding 0, cellspacing 10] <<
aboves (constr_hdr : map do_constr cons)
)
@@ -429,13 +426,16 @@ ppHsDataDecl doc_map False decl@(HsDataDecl loc ctx nm args cons drv) =
Just c = declMainBinder decl
doc = lookupFM doc_map c
+ constr_has_no_doc (HsConDecl _ nm _ _)
+ = isNothing (lookupFM doc_map nm)
-ppHsSummaryConstr :: HsConDecl -> Html
-ppHsSummaryConstr (HsConDecl pos nm typeList _maybe_doc) =
- hsep (ppHsBinder True nm : map ppHsBangType typeList)
-ppHsSummaryConstr (HsRecDecl pos nm fields maybe_doc) =
- ppHsBinder True nm +++
- braces (vanillaTable << aboves (map ppSummaryField fields))
+
+ppShortConstr :: Bool -> HsConDecl -> Html
+ppShortConstr summary (HsConDecl pos nm typeList _maybe_doc) =
+ hsep (ppHsBinder summary nm : map ppHsBangType typeList)
+ppShortConstr summary (HsRecDecl pos nm fields maybe_doc) =
+ ppHsBinder summary nm +++
+ braces (vanillaTable << aboves (map (ppShortField summary) fields))
ppHsFullConstr doc_map (HsConDecl pos nm typeList _maybe_doc) =
declWithDoc False doc (
@@ -461,9 +461,9 @@ ppHsFullConstr doc_map (HsRecDecl pos nm fields maybe_doc) =
doc = lookupFM doc_map nm
-ppSummaryField (HsFieldDecl ns ty _doc)
+ppShortField summary (HsFieldDecl ns ty _doc)
= tda [theclass "recfield"] << (
- hsep (punctuate comma (map (ppHsBinder True) ns))
+ hsep (punctuate comma (map (ppHsBinder summary) ns))
<+> toHtml "::" <+> ppHsBangType ty
)
@@ -487,40 +487,58 @@ ppHsBangType (HsUnBangedTy ty) = ppHsAType ty
ppClassHdr ty = keyword "class" <+> ppHsType ty
-ppHsClassDecl doc_map True (HsClassDecl loc ty decls) =
- if null decls
- then declBox (ppClassHdr ty)
+ppShortClassDecl doc_map summary decl@(HsClassDecl loc ty decls) =
+ if null decls
+ then declBox hdr
else td << (
vanillaTable << (
- declBox (ppClassHdr ty <+> keyword "where")
+ declBox (hdr <+> keyword "where")
</>
tda [theclass "cbody"] << (
vanillaTable << (
- aboves (map (doDecl doc_map True) (filter keepDecl decls))
+ aboves (map (doDecl doc_map summary) (filter keepDecl decls))
))
))
+ where
+ Just c = declMainBinder decl
+ hdr | not summary = linkTarget c +++ ppClassHdr ty
+ | otherwise = ppClassHdr ty
-ppHsClassDecl doc_map False decl@(HsClassDecl loc ty decls) =
- if null decls
- then declBox (linkTarget c +++ ppClassHdr ty)
- else td << (
- vanillaTable << (
- if isJust doc
- then aboves [header, classdoc, body]
- else aboves [header, body]
- ))
- where header = declBox (linkTarget c +++ ppClassHdr ty <+> keyword "where")
- classdoc = docBox (markup htmlMarkup (fromJust doc))
- meth_hdr = tda [ theclass "section4" ] << toHtml "Methods"
- body = td << (
- table ! [width "100%", cellpadding 0, cellspacing 8] << (
+ppHsClassDecl doc_map summary decl@(HsClassDecl loc ty decls)
+ | summary || (isNothing doc && all decl_has_no_doc kept_decls)
+ = ppShortClassDecl doc_map summary decl
+
+ | otherwise
+ = td << vanillaTable << (header </> classdoc </> body)
+
+ where
+ doc = lookupFM doc_map c
+ Just c = declMainBinder decl
+
+ header
+ | null decls = declBox (linkTarget c +++ ppClassHdr ty)
+ | otherwise = declBox (linkTarget c +++ ppClassHdr ty <+>
+ keyword "where")
+
+ classdoc
+ | Just d <- doc = docBox (markup htmlMarkup d)
+ | otherwise = Html.emptyTable
+
+ meth_hdr = tda [ theclass "section4" ] << toHtml "Methods"
+
+ body
+ | null decls = Html.emptyTable
+ | otherwise =
+ td << table ! [width "100%", cellpadding 0, cellspacing 8] << (
meth_hdr </>
- aboves (map (doDecl doc_map False)
- (filter keepDecl decls))
- ))
+ aboves (map (doDecl doc_map False) kept_decls)
+ )
+
+ kept_decls = filter keepDecl decls
- Just c = declMainBinder decl
- doc = lookupFM doc_map c
+ decl_has_no_doc decl
+ | Just b <- declMainBinder decl = isNothing (lookupFM doc_map b)
+ | otherwise = True
-- -----------------------------------------------------------------------------
-- Types and contexts
@@ -614,7 +632,8 @@ htmlMarkup = Markup {
markupMonospaced = tt . toHtml,
markupUnorderedList = ulist . concatHtml . map (li <<),
markupOrderedList = olist . concatHtml . map (li <<),
- markupCodeBlock = pre
+ markupCodeBlock = pre,
+ markupURL = \url -> anchor ! [href url] << toHtml url
}
-- -----------------------------------------------------------------------------
@@ -635,8 +654,6 @@ comma = char ','
char c = toHtml [c]
empty = toHtml ""
-quotes p = char '`' +++ p +++ char '\''
-doubleQuotes p = char '"' +++ p +++ char '"'
parens p = char '(' +++ p +++ char ')'
brackets p = char '[' +++ p +++ char ']'
braces p = char '{' +++ p +++ char '}'
diff --git a/src/HaddockLex.hs b/src/HaddockLex.hs
index 9b224455..8e721996 100644
--- a/src/HaddockLex.hs
+++ b/src/HaddockLex.hs
@@ -12,7 +12,7 @@ module HaddockLex (
import IOExts --tmp
import Char
-special = "\'\"/[]"
+special = "\'\"/[]<>"
data Token
= TokPara
diff --git a/src/HaddockParse.y b/src/HaddockParse.y
index 2402452c..9411ff44 100644
--- a/src/HaddockParse.y
+++ b/src/HaddockParse.y
@@ -12,6 +12,8 @@ import HaddockTypes
'/' { TokSpecial '/' }
'[' { TokSpecial '[' }
']' { TokSpecial ']' }
+ '<' { TokSpecial '<' }
+ '>' { TokSpecial '>' }
'*' { TokBullet }
'(n)' { TokNumber }
PARA { TokPara }
@@ -46,6 +48,7 @@ seq :: { ParsedDoc }
elem :: { ParsedDoc }
: STRING { DocString $1 }
| '/' STRING '/' { DocEmphasis (DocString $2) }
+ | '<' STRING '>' { DocURL $2 }
| SQUO STRING SQUO { DocIdentifier $2 }
| DQUO STRING DQUO { DocModule $2 }
| '[' seq ']' { DocMonospaced $2 }
diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs
index bd519319..e13fcb1a 100644
--- a/src/HaddockTypes.hs
+++ b/src/HaddockTypes.hs
@@ -158,6 +158,7 @@ data GenDoc id
| DocUnorderedList [GenDoc id]
| DocOrderedList [GenDoc id]
| DocCodeBlock (GenDoc id)
+ | DocURL String
type Doc = GenDoc HsQName
type ParsedDoc = GenDoc String
@@ -177,7 +178,8 @@ data DocMarkup id a = Markup {
markupMonospaced :: a -> a,
markupUnorderedList :: [a] -> a,
markupOrderedList :: [a] -> a,
- markupCodeBlock :: a -> a
+ markupCodeBlock :: a -> a,
+ markupURL :: String -> a
}
markup :: DocMarkup id a -> GenDoc id -> a
@@ -192,6 +194,7 @@ markup m (DocMonospaced d) = markupMonospaced m (markup m d)
markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds)
markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds)
markup m (DocCodeBlock d) = markupCodeBlock m (markup m d)
+markup m (DocURL url) = markupURL m url
-- | Since marking up is just a matter of mapping 'Doc' into some
-- other type, we can \'rename\' documentation by marking up 'Doc' into
@@ -207,7 +210,8 @@ mapIdent f = Markup {
markupMonospaced = DocMonospaced,
markupUnorderedList = DocUnorderedList,
markupOrderedList = DocOrderedList,
- markupCodeBlock = DocCodeBlock
+ markupCodeBlock = DocCodeBlock,
+ markupURL = DocURL
}
-- -----------------------------------------------------------------------------
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 12:23:22 +0000