[haddock @ 2002-04-04 16:23:43 by simonmar]

This is Haddock, my stab at a Haskell documentation tool.  It's not
quite ready for release yet, but I'm putting it in the repository so
others can take a look.

It uses a locally modified version of the hssource parser, extended
with support for GHC extensions and documentation annotations.

1 files changed, 567 insertions, 0 deletions

diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
new file mode 100644
index 00000000..4310a8dc
--- /dev/null
+++ b/src/HaddockHtml.hs
@@ -0,0 +1,567 @@
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- (c) Simon Marlow 2002
+--
+
+module HaddockHtml (ppHtml) where
+
+import Prelude hiding (div)
+import HaddockVersion
+import HaddockTypes
+import HsSyn
+
+import Maybe	( fromJust, isJust )
+import FiniteMap
+import Html	hiding (text)
+
+-- -----------------------------------------------------------------------------
+-- Generating HTML documentation
+
+ppHtml :: String -> Maybe String -> [(Module, Interface)] -> IO ()
+ppHtml title source_url ifaces =  do
+  ppHtmlIndex title source_url (map fst ifaces)
+  mapM_ (ppHtmlModule title source_url) ifaces
+
+moduleHtmlFile :: String -> FilePath
+moduleHtmlFile mod = mod ++ ".html" -- ToDo: Z-encode filename?
+
+indexHtmlFile = "index.html"
+styleSheetFile = "haddock.css"
+
+footer = 
+  td ! [theclass "botbar"] << 
+	( toHtml "Produced by" <+> 
+	  (anchor ! [href projectUrl] << toHtml projectName) <+>
+	  toHtml ("version " ++ projectVersion)
+	)
+   
+
+simpleHeader title = 
+  (td ! [theclass "topbar"] << 
+     vanillaTable << (
+       (td << 
+  	image ! [src "haskell_icon.gif", width "16", height 16, 
+  		 align "absmiddle"]
+       ) <->
+       (td ! [theclass "title", width "100%"] << toHtml title)
+   ))
+
+buttons1 source_url mod file
+  | Just u <- source_url = 
+	let src_url = if (last u == '/') then u ++ file else u ++ '/':file
+	in
+	(td ! [theclass "topbut", nowrap] <<
+  	   anchor ! [href src_url] << toHtml "Source code") <-> buttons2 mod
+  | otherwise =
+	buttons2 mod
+  
+
+buttons2 mod = 
+  case span (/= '.') (reverse mod) of
+   (m, '.':rest) -> 
+       (td ! [theclass "topbut", nowrap] <<
+  	 anchor ! [href (moduleHtmlFile (reverse rest))] << toHtml "Parent") <->
+	contentsButton
+   _ -> cell contentsButton
+
+contentsButton = (td ! [theclass "topbut", nowrap] <<
+  	 	    anchor ! [href indexHtmlFile] << toHtml "Contents")
+
+pageHeader mod iface title source_url =
+  (td ! [theclass "topbar"] << 
+    vanillaTable << (
+       (td << 
+  	image ! [src "haskell_icon.gif", width "16", height 16, 
+  		 align "absmiddle"]
+       ) <->
+       (td ! [theclass "title", width "100%"] << toHtml title) <->
+	buttons1 source_url mod (iface_filename iface)
+    )
+   ) </>
+   td ! [theclass "modulebar"] <<
+	(vanillaTable << (
+	  (td << font ! [size "6"] << toHtml mod) <->
+          (td ! [align "right"] <<
+             (table ! [width "300", border 0, cellspacing 0, cellpadding 0] << (
+        	  (td ! [width "50%"] << font ! [color "#ffffff"] <<
+        		bold << toHtml "Portability") <->
+        	  (td ! [width "50%"] << font ! [color "#ffffff"] <<
+        		toHtml (iface_portability iface)) </>
+        	  (td ! [width "50%"] << font ! [color "#ffffff"] <<
+        		bold << toHtml "Stability") <->
+        	  (td ! [width "50%"] << font ! [color "#ffffff"] <<
+        		toHtml (iface_stability iface)) </>
+        	  (td ! [width "50%"] << font ! [color "#ffffff"] <<
+        		bold << toHtml "Maintainer") <->
+        	  (td ! [width "50%"] << font ! [color "#ffffff"] <<
+        		toHtml (iface_maintainer iface))
+              ))
+	  ))
+    )
+
+-- ---------------------------------------------------------------------------
+-- Generate the module index
+
+ppHtmlIndex :: String -> Maybe String -> [Module] -> IO ()
+ppHtmlIndex title source_url mods = do
+  let tree = mkModuleTree mods  
+      html = 
+	header (thetitle (toHtml title)) +++
+	mylink ! [href styleSheetFile, 
+		  rel "stylesheet", thetype "text/css"] +++
+        body <<  
+	  table ! [width "100%", cellpadding 0, cellspacing 1] << (
+   	    simpleHeader title </>
+	    td << (ppModuleTree title tree) </>
+	    footer
+	  )
+  writeFile indexHtmlFile (Html.renderHtml html)
+
+ppModuleTree :: String -> [ModuleTree] -> Html
+ppModuleTree title ts = 
+  h1 << toHtml "Modules" +++
+  table ! [cellpadding 0, cellspacing 2] << aboves (map (mkNode []) ts)
+
+mkNode ss (Node s leaf []) =
+  td << mkLeaf s ss leaf
+mkNode ss (Node s leaf ts) = 
+  td << table ! [cellpadding 0, cellspacing 2] <<
+	  ((td << mkLeaf s ss leaf)
+	     </> indent <-> aboves (map (mkNode (s:ss)) ts))
+
+mkLeaf s ss False = toHtml s
+mkLeaf s ss True  = anchor ! [href (moduleHtmlFile mod)] << toHtml s
+  where mod = foldr (++) "" (s' : map ('.':) ss')
+	(s':ss') = reverse (s:ss)
+	 -- reconstruct the module name
+
+data ModuleTree = Node String Bool [ModuleTree]
+
+mkModuleTree :: [Module] -> [ModuleTree]
+mkModuleTree mods = foldr addToTrees [] (map splitModule mods)
+
+addToTrees :: [String] -> [ModuleTree] -> [ModuleTree]
+addToTrees [] ts = ts
+addToTrees ss [] = mkSubTree ss
+addToTrees (s1:ss) (t@(Node s2 leaf subs) : ts)
+  | s1 == s2  = Node s2 (leaf || null ss) (addToTrees ss subs) : ts
+  | otherwise = t : addToTrees (s1:ss) ts
+
+mkSubTree [] = []
+mkSubTree (s:ss) = [Node s (null ss) (mkSubTree ss)]
+
+splitModule :: Module -> [String]
+splitModule (Module mod) = split mod
+  where split mod = case break (== '.') mod of
+     			(s1, '.':s2) -> s1 : split s2
+     			(s1, _) -> [s1]
+
+-- ---------------------------------------------------------------------------
+-- Generate the HTML page for a module
+
+ppHtmlModule :: String -> Maybe String -> (Module,Interface) -> IO ()
+ppHtmlModule title source_url (Module mod,iface) = do
+  let html = 
+	header (thetitle (toHtml mod)) +++
+	mylink ! [href styleSheetFile, 
+		  rel "stylesheet", thetype "text/css"] +++
+        body <<  
+	  table ! [width "100%", cellpadding 0, cellspacing 1] << (
+	    pageHeader mod iface title source_url </>
+	    ifaceToHtml mod iface </>
+	    footer
+         )
+  writeFile (moduleHtmlFile mod) (Html.renderHtml html)
+
+ifaceToHtml :: String -> Interface -> Html
+ifaceToHtml mod iface
+  | null exports = noHtml
+  | otherwise =
+    td << table ! [width "100%", cellpadding 0, cellspacing 15] << body1
+ where exports = iface_exports iface
+       doc_map = iface_name_docs iface
+
+       body1
+         | Just doc <- iface_doc iface
+         = td ! [theclass "section1"] << toHtml "Description" </>
+	   docBox (markup htmlMarkup doc) </>
+	   body2
+	 | otherwise
+	 = body2
+
+       body2 =
+         (td ! [theclass "section1"] << toHtml "Synopsis") </>
+         (td ! [width "100%", theclass "synopsis"] << 
+  	   table ! [width "100%", cellpadding 0, cellspacing 8, border 0] << 
+  	     aboves (map (processExport doc_map True)  exports)) </>
+         td << hr </>
+           aboves (map (processExport doc_map False) exports)
+
+processExport :: FiniteMap HsName Doc -> Bool -> ExportItem -> Html
+processExport doc_map summary (ExportGroup lev doc)
+  | summary   = noHtml
+  | otherwise = ppDocGroup lev (markup htmlMarkup doc)
+processExport doc_map summary (ExportDecl decl)
+  = doDecl doc_map summary decl
+
+ppDocGroup lev doc
+  | lev == 1  = td ! [ theclass "section1" ] << doc
+  | lev == 2  = td ! [ theclass "section2" ] << doc
+  | lev == 3  = td ! [ theclass "section3" ] << doc
+  | otherwise = td ! [ theclass "section4" ] << doc
+
+-- -----------------------------------------------------------------------------
+-- Converting declarations to HTML
+
+declWithDoc :: Bool -> Maybe Doc -> Html -> Html
+declWithDoc True  doc        html_decl = declBox html_decl
+declWithDoc False Nothing    html_decl = declBox html_decl
+declWithDoc False (Just doc) html_decl = 
+	td ! [width "100%"] << 
+	    vanillaTable << 
+		(declBox html_decl </> docBox (markup htmlMarkup doc))
+
+doDecl :: FiniteMap HsName Doc -> Bool -> HsDecl -> Html
+doDecl doc_map summary decl = do_decl decl
+  where
+     doc | Just n <- declMainBinder decl  =  lookupFM doc_map n
+	 | otherwise = Nothing
+
+     do_decl (HsTypeSig _ [nm] ty) = 
+	declWithDoc summary doc (ppTypeSig summary nm ty)
+
+     do_decl (HsTypeSig _ nms ty) 
+	= declWithDoc summary doc (
+	    vanillaTable << aboves (map do_one nms))
+	where do_one nm = declBox (ppTypeSig summary nm ty)
+
+     do_decl (HsForeignImport _ _ _ _ n ty)
+	= declWithDoc summary doc (ppTypeSig summary n ty)
+
+     do_decl (HsTypeDecl _ nm args ty)
+	= declWithDoc summary doc (
+	      hsep ([keyword "type", ppHsBinder summary nm]
+		 ++ map ppHsName args) <+> equals <+> ppHsType ty)
+
+     do_decl (HsNewTypeDecl loc ctx nm args con drv)
+	= ppHsDataDecl doc_map summary (HsDataDecl loc ctx nm args [con] drv)
+	  -- print it as a single-constructor datatype
+
+     do_decl decl@(HsDataDecl loc ctx nm args cons drv) 
+	= ppHsDataDecl doc_map summary decl
+
+     do_decl decl@(HsClassDecl _ _ _)
+	= ppHsClassDecl doc_map summary decl
+
+     do_decl (HsDocGroup lev str) 
+	= if summary then noHtml else ppDocGroup lev str
+
+     do_decl _ = error (show decl)
+
+
+ppTypeSig summary nm ty = ppHsBinder summary nm <+> toHtml "::" <+> ppHsType ty
+
+
+keepDecl HsTypeSig{}     = True
+keepDecl HsTypeDecl{}    = True
+keepDecl HsNewTypeDecl{} = True
+keepDecl HsDataDecl{}    = True
+keepDecl HsClassDecl{}   = True
+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) = 
+   declBox (  -- single constructor special case
+      ppHsDataHeader True nm args      
+      <+> equals <+> ppHsSummaryConstr con
+   )
+ppHsDataDecl doc_map True (HsDataDecl loc ctx nm args cons drv) = 
+   td << (
+    vanillaTable << (
+     aboves (
+	(declBox (ppHsDataHeader True nm args) :
+ 	zipWith do_constr ('=':repeat '|') cons
+     )
+    )
+  ))
+  where do_constr c con = td ! [theclass "condecl"] << (
+				toHtml [c] <+> ppHsSummaryConstr con)
+
+-- Now, the full expanded documented version:
+
+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]
+     )
+    )
+  where
+	header = declBox (ppHsDataHeader False nm args)
+	datadoc = docBox (markup htmlMarkup (fromJust doc))
+	constr_hdr = td ! [ theclass "section4" ] << toHtml "Constructors"
+
+	constrs = td ! [theclass "databody"] << (
+	    	    table ! [width "100%", cellpadding 0, cellspacing 10] <<
+			aboves (constr_hdr : map do_constr cons)
+           	  )
+
+	do_constr con = ppHsFullConstr doc_map con
+
+	Just c = declMainBinder decl
+	doc = lookupFM doc_map c
+
+
+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 (td . ppSummaryField) fields))
+
+ppHsFullConstr doc_map (HsConDecl pos nm typeList _maybe_doc) = 
+     declWithDoc False doc (
+	hsep (ppHsBinder False nm : map ppHsBangType typeList)
+      )
+   where
+     doc = lookupFM doc_map nm
+ppHsFullConstr doc_map (HsRecDecl pos nm fields maybe_doc) =
+   td << vanillaTable << (
+     case doc of
+       Nothing  -> aboves [hdr, fields_html]
+       Just doc -> aboves [hdr, constr_doc, fields_html]
+   )
+
+  where hdr = declBox (ppHsBinder False nm)
+	constr_doc = docBox (markup htmlMarkup (fromJust doc))
+	fields_html = 
+	   td << 
+	      table ! [width "100%", cellpadding 0, cellspacing 8] << (
+		   aboves (map (ppFullField doc_map)
+				   (concat (map expandField fields)))
+		)
+        doc = lookupFM doc_map nm
+
+
+ppSummaryField (HsFieldDecl ns ty _doc) 
+  = td ! [theclass "recfield"] << (
+	  hsep (punctuate comma (map (ppHsBinder True) ns))
+	    <+> toHtml "::" <+> ppHsBangType ty
+   )
+
+ppFullField doc_map (HsFieldDecl [n] ty _doc) 
+  = declWithDoc False (lookupFM doc_map n) (
+	ppHsBinder False n <+> toHtml "::" <+> ppHsBangType ty
+    )
+ppFullField _ _ = error "ppFullField"
+
+expandField (HsFieldDecl ns ty doc) = [ HsFieldDecl [n] ty doc | n <- ns ]
+
+ppHsDataHeader summary nm args = 
+  keyword "data" <+> ppHsBinder summary nm <+> hsep (map ppHsName args)
+
+ppHsBangType :: HsBangType -> Html
+ppHsBangType (HsBangedTy ty) = char '!' +++ ppHsAType ty
+ppHsBangType (HsUnBangedTy ty) = ppHsAType ty
+
+-- -----------------------------------------------------------------------------
+-- Class declarations
+
+ppClassHdr ty = keyword "class" <+> ppHsType ty
+
+ppHsClassDecl doc_map True (HsClassDecl loc ty decls) =
+  if null decls 
+    then declBox (ppClassHdr ty)
+    else td << (
+	  vanillaTable << (
+           declBox (ppClassHdr ty <+> keyword "where")
+	    </> 
+           td ! [theclass "cbody"] << (
+	    vanillaTable << (
+	       aboves (map (doDecl doc_map True) (filter keepDecl decls))
+           ))
+         ))
+
+ppHsClassDecl doc_map False decl@(HsClassDecl loc ty decls) =
+  linkTarget c +++ 
+  if null decls
+    then declBox (ppClassHdr ty)
+    else td << (
+	   vanillaTable << (
+	     if isJust doc
+		then aboves [header, classdoc, body]
+		else aboves [header, body]
+        ))
+   where header = declBox (ppClassHdr ty <+> keyword "where")
+	 classdoc = docBox (markup htmlMarkup (fromJust doc))
+	 meth_hdr = td ! [ theclass "section4" ] << toHtml "Methods"
+	 body   = td << (
+	    	    table ! [width "100%", cellpadding 0, cellspacing 8] << (
+			meth_hdr </>
+	       		aboves (map (doDecl doc_map False) 
+					(filter keepDecl decls))
+           	  ))
+
+ 	 Just c = declMainBinder decl
+         doc = lookupFM doc_map c
+
+-- -----------------------------------------------------------------------------
+-- Types and contexts
+
+ppHsContext :: HsContext -> Html
+ppHsContext []      = empty
+ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+> 
+					 hsep (map ppHsAType b)) context)
+
+ppHsType :: HsType -> Html
+ppHsType (HsForAllType Nothing context htype) =
+     hsep [ ppHsContext context, toHtml "=>", ppHsType htype]
+ppHsType (HsForAllType (Just tvs) [] htype) =
+     hsep (keyword "forall" : map ppHsName tvs ++ toHtml "." : [ppHsType htype])
+ppHsType (HsForAllType (Just tvs) context htype) =
+     hsep (keyword "forall" : map ppHsName tvs ++ toHtml "." : 
+	   ppHsContext context : toHtml "=>" : [ppHsType htype])
+ppHsType (HsTyFun a b) = hsep [ppHsBType a, toHtml "->", ppHsType b]
+ppHsType t = ppHsBType t
+
+ppHsBType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b )
+  = brackets $ ppHsType b
+ppHsBType (HsTyApp a b) = ppHsBType a <+> ppHsAType b
+ppHsBType t = ppHsAType t
+
+-- -----------------------------------------------------------------------------
+-- Names
+
+linkTarget :: HsName -> Html
+linkTarget nm = anchor ! [name (hsNameStr nm)] << toHtml ""
+
+ppHsAType :: HsType -> Html
+ppHsAType (HsTyTuple True l)  = parenList . map ppHsType $ l
+ppHsAType (HsTyTuple False l) = ubxParenList . map ppHsType $ l
+ppHsAType (HsTyVar name) = ppHsName name
+ppHsAType (HsTyCon name) = ppHsQName name
+ppHsAType t = parens $ ppHsType t
+
+ppHsQName :: HsQName -> Html
+ppHsQName (UnQual str)			= ppHsName str
+ppHsQName n@(Qual (Module mod) str)
+  | n == unit_con_name	= ppHsName str
+  | isSpecial str	= ppHsName str
+  | otherwise		= anchor ! [href (linkId mod str)] << ppHsName str
+
+isSpecial (HsTyClsName id) | HsSpecial _ <- id = True
+isSpecial (HsVarName id) | HsSpecial _ <- id = True
+isSpecial _ = False
+
+ppHsName :: HsName -> Html
+ppHsName nm = toHtml (hsNameStr nm)
+
+hsNameStr :: HsName -> String
+hsNameStr (HsTyClsName id) = ppHsIdentifier id
+hsNameStr (HsVarName id)   = ppHsIdentifier id
+
+ppHsIdentifier :: HsIdentifier -> String
+ppHsIdentifier (HsIdent str)   =  str
+ppHsIdentifier (HsSymbol str)  =  str
+ppHsIdentifier (HsSpecial str) =  str
+
+ppHsBinder :: Bool -> HsName -> Html
+ppHsBinder True nm = anchor ! [href ('#':hsNameStr nm)] << ppHsBinder' nm
+ppHsBinder False nm = linkTarget nm +++ ppHsBinder' nm
+
+ppHsBinder' (HsTyClsName id) = ppHsBindIdent id
+ppHsBinder' (HsVarName id)   = ppHsBindIdent id
+
+ppHsBindIdent :: HsIdentifier -> Html
+ppHsBindIdent (HsIdent str)   =  toHtml str
+ppHsBindIdent (HsSymbol str)  =  parens (toHtml str)
+ppHsBindIdent (HsSpecial str) =  toHtml str
+
+linkId :: String -> HsName -> String
+linkId mod str = moduleHtmlFile mod ++ '#': hsNameStr str
+
+ppHsModule :: String -> Html
+ppHsModule mod = anchor ! [href (moduleHtmlFile mod)] << toHtml mod
+
+-- -----------------------------------------------------------------------------
+-- * Doc Markup
+
+htmlMarkup = Markup {
+  markupParagraph     = paragraph,
+  markupEmpty	      = toHtml "",
+  markupString        = toHtml,
+  markupAppend        = (+++),
+  markupIdentifier    = ppHsQName,
+  markupModule        = ppHsModule,
+  markupEmphasis      = emphasize . toHtml,
+  markupMonospaced    = tt . toHtml,
+  markupUnorderedList = ulist . concatHtml . map (li <<),
+  markupOrderedList   = olist . concatHtml . map (li <<),
+  markupCodeBlock     = pre
+  }
+
+-- -----------------------------------------------------------------------------
+-- * Misc
+
+hsep :: [Html] -> Html
+hsep [] = noHtml
+hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls
+
+infixr 8 <+>
+a <+> b = Html (getHtmlElements (toHtml a) ++ HtmlString " ": getHtmlElements (toHtml b))
+
+keyword s = bold << toHtml s
+
+equals = char '='
+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 '}'
+
+punctuate :: Html -> [Html] -> [Html]
+punctuate p []     = []
+punctuate p (d:ds) = go d ds
+                   where
+                     go d [] = [d]
+                     go d (e:es) = (d +++ p) : go e es
+
+parenList :: [Html] -> Html
+parenList = parens . hsep . punctuate comma
+
+ubxParenList :: [Html] -> Html
+ubxParenList = ubxparens . hsep . punctuate comma
+
+ubxparens p = toHtml "(#" +++ p +++ toHtml "#)"
+
+indent = td ! [width "10"] << ""
+
+text   = strAttr "TEXT"
+div    = tag "DIV"
+mylink = itag "LINK"
+
+declBox :: Html -> Html
+declBox html = td ! [theclass "decl"] << html
+
+docBox :: Html -> Html
+docBox html = td ! [theclass "doc"] << html
+
+vanillaTable = table ! [width "100%", cellpadding 0, cellspacing 0, border 0]
+