[haddock @ 2002-04-09 11:33:54 by simonmar]

- add the <...> syntax for marking up URLs in documentation

- Make the output for data & class declarations more compact when
  there aren't any documentation annotations on the individual
  methods or constructors respectively.

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
   }
 
 -- -----------------------------------------------------------------------------