module DocGen(htmlDoclet) where

import List
import Maybe
import Monad (when)
import Html

import HDoclet


displayBreakLength :: Int
displayBreakLength = 30

htmlFile :: ModuleDoc -> String
htmlFile md = moduleName md ++ ".html"

class CanAppear a => AnchorLink a where
    makeAnchor :: a -> Html -> Html
    makeLinkU  :: a -> [HtmlAttr] -> Html -> Html

makeLink :: AnchorLink a => a -> Html -> Html
makeLink d = makeLink' d []

makeLink' :: AnchorLink a => a -> [HtmlAttr] -> Html -> Html
makeLink' d a
    | appearsInOutput d  = makeLinkU d a
    | otherwise          = id

makeLinkUncond :: AnchorLink a => a -> Html -> Html
makeLinkUncond d = makeLinkU d []

instance AnchorLink ModuleDoc where
    makeAnchor _  l = l
    makeLinkU  md a = anchor ! (href (htmlFile md) : a)

instance AnchorLink FunctionDoc where
    makeAnchor fd   = anchor ! [name $ fanchor fd]
    makeLinkU  fd a = anchor ! (href (htmlFile (themodule fd) ++
					('#' : fanchor fd)) : a)

fanchor :: FunctionDoc -> String
fanchor (fd @ (FunctionDoc {funclass=Instance id})) =
    fullname fd ++ ('_' : ianchor id)
fanchor fd = fullname fd

instance AnchorLink ClassDoc where
    makeAnchor cd   = anchor ! [name $ fullname cd]
    makeLinkU  cd a = anchor ! (href (htmlFile (themodule cd) ++
				      ('#' : fullname cd)) : a)

instance AnchorLink DataDoc where
    makeAnchor dd   = anchor ! [name $ fullname dd]
    makeLinkU  dd a = anchor ! (href (htmlFile (themodule dd) ++
				      ('#' : fullname dd)) : a)

instance AnchorLink TypeDoc where
    makeAnchor td   = anchor ! [name $ fullname td]
    makeLinkU  td a = anchor ! (href (htmlFile (themodule td) ++
				      ('#' : fullname td)) : a)

instance AnchorLink InstanceDoc where
    makeAnchor id   = anchor ! [name $ ianchor id]
    makeLinkU  id a = anchor ! (href (htmlFile (themodule id) ++
				      ('#' : ianchor id)) : a)

instance AnchorLink HDR where
    makeLinkU (FunctionRef f) = makeLinkU f
    makeLinkU (TypeRef t)     = makeLinkU t
    makeLinkU (DataRef d)     = makeLinkU d
    makeLinkU (ClassRef c)    = makeLinkU c

    makeAnchor _ = error "makeAnchor should never be called for a HDR."


ianchor :: InstanceDoc -> String
ianchor id = type2text (typedef id)


type2html :: Type -> Html
type2html t = printType t htmlTyIdPrinter stringToHtml (+++) 

type2html_paren :: Type -> Html
type2html_paren t@(Simple _) = type2html t
type2html_paren t@(List _)   = type2html t
type2html_paren t@(Tuple _)  = type2html t
type2html_paren t            = "(" +++ type2html t +++ ")"

type2text :: Type -> String
type2text t = printType t textTyIdPrinter id (++)

htmlTyIdPrinter :: (HsQName, TypeId) -> Html
htmlTyIdPrinter (n, TyUnknown ) = stringToHtml (hsQNameToString n)
htmlTyIdPrinter (n, TyVar     ) = stringToHtml (hsQNameToString n)
htmlTyIdPrinter (n, TyType  td) = makeLink td << (hsQNameToString n)
htmlTyIdPrinter (n, TyData  dd) = makeLink dd << (hsQNameToString n)
htmlTyIdPrinter (n, TyClass cd) = makeLink cd << (hsQNameToString n)

textTyIdPrinter :: (HsQName, TypeId) -> String
textTyIdPrinter (n, _) = hsQNameToString n

printType :: Type -> ((HsQName,TypeId) -> a) -> (String -> a) ->
	     (a -> a -> a) -> a
printType ty printer strconv conc = pt' (-1) ty
    where
--  pt' :: Integer -> Type -> a  (where `a' is the a from printType...)
    pt' _ (Simple s)    = printer s
    pt' _ (Context c t) = pt' 0 c  `conc`  strconv " => "  `conc`  pt' 0 t
    pt' p (Con s ts)    = strconv oP  `conc`  printer s  `conc`  strconv " "
			  `conc`  foldl comp (strconv "") (map (pt' 2) ts)
			  `conc`  strconv cP
			  where
			  comp x y = x `conc` (strconv " ") `conc` y
			  (oP, cP) = if (p == 2)
				     then ("(", ")")
				     else ("", "")
    pt' _ (List t)      = strconv "["  `conc`  pt' 0 t  `conc`  strconv "]"
    pt' _ (Tuple ts)    = strconv "("  `conc`
			  genIntersp (strconv ", ") (strconv "") conc
					 (map (pt' 0) ts)
			  `conc`  strconv ")"
    pt' p (Fun t1 t2)   = strconv oP  `conc`  pt' 1 t1  `conc` strconv " -> "
			  `conc`  pt' 0 t2  `conc`  strconv cP
			  where
			  (oP, cP) = if (p >= 1)
				     then ("(", ")")
				     else ("", "")
    pt' p (Forall vs t) = strconv (oP ++ "forall" ++
				   concat [' ':v | v <- vs] ++ ". ")
			  `conc` pt' 0 t `conc` strconv cP
			  where
			  (oP, cP) = if p >= 0
				       then ("(", ")")
				       else ("", "")


typed2html' :: Integer -> Bool -> Typed -> Html
typed2html' p True  (Typed ty t) = oP +++ typed2html' 0 True ty +++
				   primHtml "&nbsp;::&nbsp;" +++
				   type2html t +++ cP
    where
    (oP, cP) = if p >= 1
	       then ("(", ")")
	       else ("" , "" )
typed2html' p False (Typed ty _) = typed2html' p False ty
typed2html' _ b (SimpleT s)      = stringToHtml s
typed2html' p b (ConT s ts)      = oP +++ s
				   +++ " " +++
				   intersp' " " (map (typed2html' 2 b) ts)
				   +++ cP
    where
    (oP, cP) = if p == 2
	       then ("(", ")")
	       else ("" , "" )
typed2html' _ b (ContextT t1 t2) = typed2html' 0 b t1 +++ " => " +++
				   typed2html' 0 b t2
typed2html' _ b (ListT ty)       = "[" +++ typed2html' 0 b ty +++ "]"
typed2html' _ b (TupleT tys)     = "(" +++
				   intersp' ", " (map (typed2html' 0 b) tys)
				   +++ ")"
typed2html' p b (FunT ty1 ty2)   = oP +++ typed2html' 1 b ty1 +++ " -> "
				   +++ typed2html' 0 b ty2 +++ cP
    where
    (oP, cP) = if (p >= 1)
	       then ("(", ")")
	       else ("" , "" )

-- ensure that parenthesis are put around the expression when if
-- there is no "(...)" or "[...]" around it and it is not a
-- single word
typed2html_paren :: Typed -> Html
typed2html_paren ty@(TupleT _)  = typed2html ty
typed2html_paren ty@(SimpleT _) = typed2html ty
typed2html_paren ty@(ListT _)   = typed2html ty
typed2html_paren ty             = "(" +++ typed2html ty +++ ")"

typed_wo_t :: Typed -> Html
typed_wo_t = typed2html' 0 False

typed2html = typed2html' 0 True


instance HTML HDocElement where
    toHtml = hde2html


hde2html (HdeText str)       = stringToHtml str
hde2html (HdeTag1 BrTag)     = br
hde2html (HdeTag2 t2 tas h)  = (case t2 of
				CodeTag -> thecode
				PreTag  -> pre
				EmTag   -> emphasize
				TTTag   -> tt
				ItalicsTag -> italics
				StrongTag  -> strong
				BoldTag    -> bold
				ParagraphTag -> paragraph
				AnchorTag    -> anchor
			       ) ! (mkAttrs tas) << h
hde2html (HdeUnicode u) = primHtml (unicodeHtml u)
hde2html HdeWhiteSpace  = stringToHtml " "
hde2html x              = error ("hdocText2html:\n  " ++ show x ++
				 "\nunimplemented")

mkAttrs :: [TagAttr] -> [HtmlAttr]
mkAttrs = map mkAttr
    where
    mkAttr :: TagAttr -> HtmlAttr
    mkAttr (TaHref  v) = href v
    mkAttr (TaClass v) = theclass v

moduleDoc2html :: ModuleDoc -> Html
moduleDoc2html md =
    makeAnchor md << h2 << ("module " ++ moduleName md) +++
    condH modBodyNotEmpty modBody
    where
    modBody = hr +++ "module " +++ (bold << moduleName md) +++
	      p << (description md) +++
	      condH (notnull auth) << p << (bold << "Author: " +++ auth) +++
	      condH (notnull ver ) << p << (bold << "Version: "+++ ver) +++
	      condH (notnull see)  << p << makeSeeAlso see
    auth = authorM md
    ver  = versionM md
    see  = seeTags md
    modBodyNotEmpty = any notnull [description md, auth, ver] ||
		      notnull see

funDoc2html :: FunctionDoc -> Html
funDoc2html fd =
    p << makeAnchor fd << fullsig +++
    condH (isJust $ retdescr fd) (p << thecode << callsig) +++ 
    dlist << (ddef << description fd +++
	      ddef << (dlist << ((if length (paramlist fd) > 0
			            then dterm << bold << "Arguments:" +++
			                 pardesc
			            else stringToHtml "") +++
				 (if isJust (retdescr fd)
			            then dterm (bold << "Returns:") +++
			                 ddef << retexpl
			            else stringToHtml "") +++
				 classdesc +++
				 condH (notnull $ seeTags fd)
				     (dterm << bold << "See Also:" +++
				      ddef  << makeSeeList (seeTags fd)))))
	where
	Just (retdef, retexpl, rettype) = retdescr fd
	pardesc = map mkP (paramlist fd)
	fullsig =
	    case signature fd of
 	       Nothing  -> oneLineTable [(headFont << bold << prefixname fd, [])]
	       Just sig ->
		   oneLineTable [(headFont << bold << prefixname fd, []),
				 (headFont << stringToHtml "::", []),
				 (headFont << type2html sig, [])]
	callsig = (if isJust (retdescr fd)
		   then (case (retdef, rettype) of
			 (Nothing, _)        -> stringToHtml ""
			 (Just d, Functional)-> typed2html_paren d +++ " = "
			 (Just d, Monadic)   -> typed2html_paren d +++" <- ")
		   else stringToHtml "") +++
		  stringToHtml (prefixname fd) +++ " " +++
		  intersp' " " (map (\(def,des) -> typed2html_paren def)
			        (paramlist fd)) 
	mkP (pdef, pdescr) =
	    ddef << (thecode << typed_wo_t pdef +++
		 condH (notnull pdescr) 
		       (primHtml "&nbsp;-&nbsp;" +++ pdescr))
	classdesc = case (funclass fd) of
		    NoClass     -> stringToHtml ""
		    Class cd    -> dterm << "Member of class: " +++
                                   makeLink cd << bold << thename cd
                    Instance id -> dterm << "Belongs to instance: " +++
                                   makeLink id << bold <<
				       (type2text $ typedef id)

dataDoc2html :: (DataDoc, [ConstructorDoc]) -> Html
dataDoc2html (dd, shownConstructors) =
    p << makeAnchor dd << headFont << type2html (typedef dd) +++
    miniTable dataCode +++
    (dlist << (ddef << description dd +++
	       condH (notnull shownConstructors)
	       (ddef (dlist << (dterm << bold << constructors +++
				consdesc +++
				condH (notnull $ seeTags dd)
				  (dterm << bold << "See Also:" +++
			           ddef  << makeSeeList (seeTags dd)))
		     )
	       )
	      )
    ) 
    where
    dataCode 
	| null shownConstructors =
	    [[(dataDef +++ condH (notnull $ derivedInstances dd) deriv,
	       nowrR)]]
	| length (type2text $ typedef dd) > displayBreakLength =
	    [(dataDef1 +++ aSpace, nowrR),
	     (dataDef2,[nowrap])]
	    : [[(a,[align "right"]),(b,[])]
	       | (a,b) <- zip (thecode << (fourSpaces +++ "=") :
			       repeat (thecode << (fourSpaces +++ "|")))
	                      constrColumn] ++
	    derivRow
	| otherwise =
	    [[(x,nowrR),(cons,[])] |
	      (x,cons) <- zip ((dataDef +++ thecode << " = ")
			       : repeat (thecode << ("| ")))
	                      constrColumn] ++
	    derivRow

    constrColumn = map mkCshort shownConstructors
    derivRow     = if null (derivedInstances dd)
		      then [] 
		      else [[(stringToHtml "", []), (deriv, [])]]
    deriv        = boldcode << " deriving" +++
		   thecode  << (" (" +++ derived +++ ")")
    dataDef  = dataDef1 +++ " " +++ dataDef2
    dataDef1 = boldcode << data_or_nt
    dataDef2 = thecode  << type2html (typedef dd)

    data_or_nt   = primHtml $
		   if isNewType dd then "&nbsp;newtype " else "&nbsp;data "
    constructors = if isNewType dd then "Constructor:" else "Constructors:"

    mkCshort (ConstructorDoc (Constructor n fas ctx _ ts) _) =
	thecode << (showFAS fas +++ showOptContext ctx +++
		    if ":" `isPrefixOf` n && length ts >= 2
		     then type2html_paren (head ts) +++ " " +++ n +++ " " +++
			  intersp' " " (map type2html_paren (tail ts))
		     else n +++ " " +++ intersp' " " (map type2html_paren ts)
		   )
    mkCshort (ConstructorDoc (Labelled  t tl) _)   =
	thecode << (t +++ " { " +++ intersp' ", " (map typed2html tl) +++ " }")

    consdesc = map mkC shownConstructors
    mkC (ConstructorDoc (Constructor n fas _ tt _) d) =
	ddef << (thecode << co +++
		 condH (notnull d) (primHtml "&nbsp;-&nbsp;" +++ d))
	where
	co = ({-showFAS fas +++-}
	      if ":" `isPrefixOf` n && length tt >= 2
	        then typed_wo_t (head tt) +++ " " +++ n +++ " " +++
		     intersp' " " (map typed_wo_t (tail tt))
		else n +++ " " +++ intersp' " " (map typed_wo_t tt)
	     )
    mkC (ConstructorDoc (Labelled c tl) d) =
	ddef << thecode << (c +++ " { " +++
			    intersp' ", " (map typed_wo_t tl) +++ " } " +++
			    condH (notnull d) (primHtml "&nbsp;-&nbsp;" +++ d))

    derived = intersp' ", " (map stringToHtml (derivedInstances dd)) 

typeDoc2html :: (TypeDoc, Maybe Type) -> Html
typeDoc2html (td, c) =
    p << makeAnchor td << headFont << type2html (typedef td) +++
    oneLineTable [(boldcode << (aSpace +++ "type "), nowrR),
		       (thecode << type2html (typedef td) +++ constr, [])] +++
    condH (hasDesc || hasSee)
	      (dlist << (condH hasDesc (ddef << description td) +++
	                 condH hasSee  (ddef << dlist <<
					(dterm << bold << "See Also:" +++
					 ddef  << makeSeeList (seeTags td)))))
    where
    hasDesc = notnull $ description td
    hasSee  = notnull $ seeTags td
    constr = case c of
		    Nothing -> stringToHtml ""
		    Just co -> "=" +++ aSpace +++
			       thecode << type2html co

classDoc2html :: (ClassDoc, [InstanceDoc]) -> Html
classDoc2html (cd, knownInsts) =
    p << makeAnchor cd << headFont << type2html (typedef cd ) +++
    p << description cd +++
    classInstTable "class " cd memberFunctions (functionalDeps cd) origSig +++
    condH (notnull knownInsts)
	      ("Known instances: " +++
	       (ulist ! [compact] << map ilink knownInsts)) +++
    condH (notnull $ seeTags cd)
	  (p << makeSeeAlso (seeTags cd))
    where
    ilink i = li << makeLink i << (type2text (typedef i))

classInstTable :: HasTypedef a =>
		  String -> a -> (a -> [FunctionDoc]) ->
		  [FunDep] ->
		  (FunctionDoc -> Maybe Type) -> Html
classInstTable classInst obj theFuncs fundeps signat =
    p << table << (topRow : [mkF f | f <- theFuncs obj])
    where
    topRow = tr << [td!(valign "top" : nowrR)    << boldcode << classInst,
		    td![valign "top", colspan 3] <<
		        (thecode  << (type2html (typedef obj) +++
				      fundepsStr) +++
			 boldcode << " where")]
    mkF f = tr << ([td << "", td ! [valign "top"] << 
		    makeLink f << thecode << prefixname f] ++
		   case signat f of
	                Nothing -> []
		        Just t  -> [td ! [valign "top"] << thecode << "::",
				    td ! [valign "top"] << thecode <<
				                               type2html t]
		  ) +++
	    condH (notnull $ description f)
		      (tr << ([td << "", td << "", td << "", td << summary f]))
    fundepsStr
	| null fundeps = ""
	| otherwise    =
	    " | " ++
	    concat (intersperse ", " [vlist vs1 ++ " -> " ++ vlist vs2
				     | (vs1,vs2) <- fundeps])
    vlist vs = concat (intersperse " " vs)

instanceDoc2html :: InstanceDoc -> Html
instanceDoc2html id =
    p << makeAnchor id << headFont << type2html (typedef id) +++
    p << description id +++
    classInstTable "instance " id instanceFunctions [] signature +++
    condH (notnull $ seeTags id)
	  (p << makeSeeAlso (seeTags id))

dataSummary :: [(DataDoc, [ConstructorDoc])] -> Html
dataSummary dds = stdTable "Data Type Summary" [[mkDS d] | d <- dds]
    where
    mkDS (dd, shownConstructors) =
        dataSum +++
	indentedDescriptionNoBr (summary dd)
	where
	dataSum = oneLineTable [(boldcodeSP << data_or_nt, nowrR),
				(thecode << (type2html (typedef dd) +++
					     conssum +++ deriv), [])]
	data_or_nt = if isNewType dd then "newtype " else "data "
	conssum = condH (notnull shownConstructors)
		      (" = " +++ conses)
	conses = intersp' " | " (map mkCons shownConstructors)
	deriv =
	    condH (notnull $ derivedInstances dd)
		      (bold << " deriving" +++ " (" +++ derived +++ ")")

	mkCons (ConstructorDoc (Constructor n fas ctx _ ts) _)
	    | ":" `isPrefixOf` n  &&  length ts >= 2  =
		showFAS fas +++ showOptContext ctx +++
		type2html_paren (head ts) +++ " " +++ n +++ " " +++
		intersp' " " (map type2html_paren (tail ts))
	    | otherwise  =
		showFAS fas +++ showOptContext ctx +++
		n +++ " " +++ intersp' " " (map type2html_paren ts)
	mkCons (ConstructorDoc (Labelled c tl) _)    =
	    c +++ " { " +++ intersp' ", " (map typed2html tl) +++ " }"
	derived = intersp' ", " (map stringToHtml (derivedInstances dd))

typesynSummary :: [(TypeDoc, Maybe Type)] -> Html
typesynSummary ts = stdTable "Type Synonyms Summary" [[mkTD t] | t <- ts]
    where
    mkTD (td,c) =
	oneLineTable [(boldcodeSP << "type ", nowrR),
		      (thecode (type2html (typedef td) +++ constr), [])] +++
	indentedDescriptionNoBr (summary td)
	where
	constr = case c of
			Nothing -> stringToHtml ""
			Just co -> " = " +++ type2html co

classSummary :: [(ClassDoc, [InstanceDoc])] -> Html
classSummary cs = stdTable "Class Summary" [[mkCS c] | c <- cs]
    where
    mkCS (c, _) =
	oneLineTable[(boldcodeSP << "class ", nowrR),
		     (thecode << type2html (typedef c), [])] +++
	indentedDescriptionNoBr (summary c)

instanceSummary :: [InstanceDoc] -> Html
instanceSummary is = stdTable "Instance Summary" [[mkIS i] | i <- is]
    where
    mkIS i =
	oneLineTable [(boldcodeSP << "instance ", nowrR),
		      (thecode << makeLink i << (type2text $ typedef i), [])]
	+++ indentedDescriptionNoBr (summary i)

funSummary :: [FunctionDoc] -> Html
funSummary dl = stdTable "Function Summary" [[mkFD d] | d <- dl]
    where
    mkFD :: FunctionDoc -> Html
    mkFD f  =
	oneLineTable ((thecode << (aSpace +++ makeLink f<<prefixname f),[nowrap])
		      : sig)
	+++ indentedDescriptionNoBr (summary f)
	where
	sig = case signature f of
	          Nothing -> []
		  Just s  -> [(thecode << "::", [nowrap]),
		              (thecode << type2html s, [])]

alsoAvailTs :: [(TypeDoc, Maybe Type)] -> Html
alsoAvailTs ts = alsoAvail "Type synonyms also available through this module"
		 nameLinkUC (map fst ts)

alsoAvailDs :: [(DataDoc, [ConstructorDoc])] -> Html
alsoAvailDs ds = alsoAvail "Datatypes also available through this module"
		 nameLinkUC (map fst ds)

alsoAvailCs :: [(ClassDoc, [InstanceDoc])] -> Html
alsoAvailCs cs = alsoAvail "Classes also available through this module"
		 nameLinkUC (map fst cs)

alsoAvailIs :: [InstanceDoc] -> Html
alsoAvailIs is = alsoAvail "Instances also available through this module"
		 iLink is
    where
    iLink i = makeLinkUncond i << type2text (typedef i) 

alsoAvailFs :: [FunctionDoc] -> Html
alsoAvailFs fs = alsoAvail "Functions also available through this module"
		 mkF fs
    where
    mkF f = makeLinkUncond f << prefixname f +++ info
	where
	info = case funclass f of
	       NoClass     -> stringToHtml ""
	       Class cd    -> font ! [size "-1"] << (" (" ++ thename cd ++ ")")
	       Instance id -> font ! [size "-1"] <<
		   (" (" ++ type2text (typedef id)++ ")")

alsoAvail :: String -> (a -> Html) -> [a] -> Html
alsoAvail tableTitle f objs = stdTable tableTitle [[enumObjs]]
    where
    enumObjs = intersp' ", " (map mk objs)
    mk o = thecode << f o

nameLinkUC :: (AnchorLink a, HasHDocName a) => a -> Html
nameLinkUC o = makeLinkUncond o << prefixname o

showFAS :: [String] -> Html
showFAS [] = stringToHtml ""
showFAS xs = stringToHtml ("forall" ++ concat [' ':x | x <- xs] ++ ". ")

showOptContext :: Maybe Type -> Html
showOptContext Nothing  = stringToHtml ""
showOptContext (Just t) = type2html t +++ " => "

css :: FilePath -> Html
css file = thelink ! [rel "stylesheet", thetype "text/css",
		      href file] << ""

makeDoc :: HDocSettings -> FilePath -> DocumentedModule -> Html
makeDoc hdSet styleSheetFile dm =
    header << (css styleSheetFile +++
	       thetitle << ("Module " ++ moduleName md)
	      )+++
    body <<
    (moduleDoc2html md +++ hr +++
     condH (notnull tds) << p << typesynSummary tds +++
     condH (notnull dds) << p << dataSummary dds +++
     condH (notnull cds) << p << classSummary cds +++
     condH (notnull ids) << p << instanceSummary ids +++
     condH (notnull fds) << p << funSummary fds +++

     condH (notnull alsoTs) << p << alsoAvailTs alsoTs +++
     condH (notnull alsoDs) << p << alsoAvailDs alsoDs +++
     condH (notnull alsoCs) << p << alsoAvailCs alsoCs +++
     condH (notnull alsoIs) << p << alsoAvailIs alsoIs +++
     condH (notnull alsoFs) << p << alsoAvailFs alsoFs +++

     condH (notnull tds) << p << (partHeading "Type Synonyms" +++
				  intersp hr (map td2h tds)) +++
     condH (notnull dds) << p << (partHeading "Data Types" +++
				  intersp hr (map dd2h dds)) +++
     condH (notnull cds) << p << (partHeading "Classes" +++
				  intersp hr (map cd2h cds))+++
     condH (notnull ids) << p << (partHeading "Instances" +++
				  intersp hr (map id2h ids)) +++
     condH (notnull fds) << p << (partHeading "Function Detail" +++
				  intersp hr (map fd2h fds))
    )
    where
    fd2h fd = condH (hdsLineNumbers hdSet) (line fd) +++ funDoc2html fd
    cd2h c@(cd,_) = condH (hdsLineNumbers hdSet) (line cd) +++ classDoc2html c
    id2h id = condH (hdsLineNumbers hdSet) (line id) +++ instanceDoc2html id
    dd2h d@(dd,_) = condH (hdsLineNumbers hdSet) (line dd) +++ dataDoc2html d
    td2h t@(td,_) = condH (hdsLineNumbers hdSet) (line td) +++ typeDoc2html t

    line :: HasHDocName a => a -> Html
    line obj = thecode << ("line " ++ show (lineNumber obj)) +++ br

    md  = documentedModule dm
    fds = documentedFunctions dm
    tds = documentedTypesynonyms dm
    dds = documentedDatatypes dm
    cds = documentedClasses dm
    ids = documentedInstances dm

    alsoFs = alsoFunctions    dm
    alsoTs = alsoTypesynonyms dm
    alsoDs = alsoDatatypes    dm
    alsoCs = alsoClasses      dm
    alsoIs = alsoInstances    dm

notnull = not . null


aSpace     = primHtml "&nbsp;"
twoSpaces  = primHtml "&nbsp;&nbsp;"
fourSpaces = primHtml "&nbsp;&nbsp;&nbsp;&nbsp;"
tenSpaces  = primHtml ("&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;" ++
		       "&nbsp;&nbsp;&nbsp;&nbsp;")

nowrR :: [HtmlAttr]
nowrR = [nowrap, align "right"]

headFont :: Html -> Html
headFont h = h3 << h

-- <code><b>...</b></code>
boldcode :: Html -> Html
boldcode h = thecode << bold << h

-- <code>&nbsp;<b>...</b></code>
boldcodeSP :: Html -> Html
boldcodeSP h = thecode << (aSpace +++ bold << h)

condH :: Bool -> Html -> Html
condH True  html = html
condH False _    = stringToHtml ""

intersp :: Html -> [Html] -> Html
intersp   _   [] = stringToHtml "" 
intersp inter hl = foldl1 (\x y -> x +++ inter +++ y) hl

intersp' :: String -> [Html] -> Html
intersp' inter = intersp (stringToHtml inter)

genIntersp :: a -> a -> (a -> a -> a) -> [a] -> a
genIntersp sep start conc = inter
    where
    inter []     = start
    inter (x:xs) = case xs of
			 [] -> x
			 _  -> x `conc` sep `conc` inter xs

indentedDescription :: HDocText -> Html
indentedDescription []   = stringToHtml ""
indentedDescription text =
    br +++ oneLineTable [(fourSpaces,[nowrap]), (toHtml text,[])]

indentedDescriptionNoBr :: HDocText -> Html
indentedDescriptionNoBr []   = stringToHtml ""
indentedDescriptionNoBr text =
    oneLineTable [(fourSpaces,[nowrap]), (toHtml text,[])]


-- generate a table with the title `heading'.
-- Each element of rows is the list of columns for the corresponding row.
-- Each row must have the same number of entries!
-- The heading gets a "class" attribute of "TableHeadingColor",
-- all other rows get "TableRowColor".
stdTable :: String -> [[Html]] -> Html
stdTable heading rows =
    (table ! [border 1, width "100%"] <<
     (tr ! [theclass "TableHeadingColor"]
      << td ! [colspan maxW] << font ! [size "+2"] << bold << heading
      +++ foldl (\x row -> x +++ (tr ! [theclass "TableRowColor"] <<
				  foldl (\x e -> x +++ (td << e))
				  (stringToHtml "") row))
      (stringToHtml "") rows))
    where
    maxW = maximum (0:(map length rows))

miniTable :: [[(Html,[HtmlAttr])]] -> Html
miniTable rows =
    table << [tr ! [valign "top"] << [td ! attrs << c | (c,attrs) <- cs]
	      | cs <- rows]

oneLineTable :: [(Html,[HtmlAttr])] -> Html
oneLineTable cols = miniTable [cols]

-- Produce a table which has only a heading, but no other rows.
partHeading :: String -> Html
partHeading heading = stdTable heading []


makeFunIndex :: [FunctionDoc] -> Html
makeFunIndex funs = makeIndexTable "Index of functions" (map mk funs)
    where
    mk :: FunctionDoc -> Html
    mk fd =
	makeLink' fd [target "mainFrame"] << prefixname fd +++ info
	where
	info = case funclass fd of
	       NoClass     -> stringToHtml ""
	       Class cd    -> font ! [size "-2"] << (" (" ++ thename cd ++ ")")
	       Instance id -> font ! [size "-2"] <<
		   (" (" ++ type2text (typedef id)++ ")")

makeDataIndex :: [TypeDoc] -> [DataDoc] -> Html
makeDataIndex ts ds =
    condH (notnull ts)
	  (makeIndexTable "Index of typesynonyms"
	   (map typedefLink2mainFrame ts)) +++
    condH (notnull ts && notnull ds) hr +++
    condH (notnull ds)
	      (makeIndexTable "Index of datatypes"
	       (map typedefLink2mainFrame ds))

makeClassIndex :: [ClassDoc] -> Html
makeClassIndex cs =
    makeIndexTable "Index of classes" (map typedefLink2mainFrame cs)

makeInstanceIndex :: [InstanceDoc] -> Html
makeInstanceIndex is =
    makeIndexTable "Index of instances" (map typedefLink2mainFrame is)


typedefLink2mainFrame :: (AnchorLink a, HasTypedef a) => a -> Html
typedefLink2mainFrame obj =
    makeLink' obj [target "mainFrame"] << type2text (typedef obj)

makeIndexTable :: String -> [Html] -> Html
makeIndexTable titleText xs =
    table ! [border 0, width "100%"] <<
	      [tr << td![nowrap] <<
	       (font![size "+1",theclass "FrameHeadingFont"] << titleText +++
		[br +++ font![theclass "FrameItemFont"] << x | x <- xs])]

makeSeeAlso :: [HDR] -> Html
makeSeeAlso hdrs =
    bold << "See also:" +++ br +++ primHtml "&nbsp;&nbsp;" +++
    makeSeeList hdrs

makeSeeList :: [HDR] -> Html
makeSeeList hdrs = intersp' ", " [makeLink h << prefixname h | h <- hdrs]

makeModIndex :: FilePath -> [ModuleDoc] -> Html
makeModIndex cssFile mods =
    header << (css cssFile +++
	       thetitle << "Index of modules"
	      ) +++
    body <<
	 makeIndexTable "Index of modules" (map mk mods)
--    (font ! [size "+1"] << bold << "Index of modules" +++ br +++
--     foldl (+++) (stringToHtml "") (map mk mods))
    where
    mk :: ModuleDoc -> Html
    mk md = makeLink' md [target "mainFrame"] << moduleName md



htmlDoclet :: HDocletInput -> IO ()
htmlDoclet docletInput =
    do putStrLn ("sending output to " ++ dirname)
       sequence_ (map writeModDoc modules)
       putStrLn "generating module index."
       writeFile (dirname ++ "modules.html")
		     (renderHtml $ makeModIndex cssFile allModules) 
       idxTables [("functions.html", "functions", 
		   makeFunIndex (allDocuFunctions docletInput)),
		  ("datatypes.html", "types",
		   makeDataIndex (map fst $ allDocuTypesynonyms docletInput)
		   (map fst $ allDocuDatatypes docletInput)),
		  ("classes.html", "classes",
		   makeClassIndex (map fst $ allDocuClasses docletInput)),
		  ("instances.html", "instances",
		   makeInstanceIndex (allDocuInstances docletInput))]
       putStrLn "generating index.html."
       writeFile (dirname ++ "index.html") (renderHtml indexhtml)
       when (hdsStyleSheetFile hdSet == Nothing)
		(putStrLn ("generating default stylesheet file " ++
			   cssFileWithPath ++ ".") >>
		 writeFile cssFileWithPath defaultCssFile
		)
       putStrLn "finished."
    where
    modules = allDocuModules docletInput
    writeModDoc dm =
	do putStrLn ("generating " ++ modName ++ ".html")
	   writeFile (dirname ++ modName ++ ".html")
			 (renderHtml (makeDoc hdSet cssFile dm))
	where
	modName = moduleName (documentedModule dm)

    indexhtml = header << (css cssFile +++
			   thetitle << hdsDocumentTitle hdSet
			  ) +++
		frameset ! [cols "20%,80%"] <<
		(frameset ! [rows "30%,70%"] <<
		 (frame ! [src "modules.html"] << "" +++
		  frame ! [src "functions.html"] << "") +++
		 frame ! [src "functions.html", name "mainFrame"] << "")

    idxTables :: [(FilePath, String, Html)] -> IO ()
    idxTables xs = sequence_ [mk i | i <- [0..lastIdx]]
	where
	(files, names, htmls) = unzip3 xs
	lastIdx = length xs - 1

        mk :: Int -> IO ()
	mk i =
	    do putStrLn ("generating index of " ++ (names!!i) ++ ".")
	       writeFile (dirname ++ (files!!i))
                   (renderHtml (header << (css cssFile +++
					   thetitle << (names!!i)
					  )+++
				body << t))
	    where
	    t = intersp' " " [ref j | j <- [0..lastIdx]] +++ hr +++ (htmls!!i)
	    ref j
		| i == j     =  stringToHtml (names!!j)
		| otherwise  =  anchor ! [href (files!!j)] << (names!!j)

    hdSet   = hdocSettings docletInput
    dirname = hdsDestinationDir hdSet

    allModules   = [documentedModule dm | dm <- allDocuModules docletInput]

    (cssFile, cssFileWithPath) =
	case hdsStyleSheetFile hdSet of
	  Nothing   -> ("hdoc.css", dirname ++ "hdoc.css")
	  Just file -> (file, file)

bgColor  = "#DDDDDD"

defaultCssFile :: String
defaultCssFile =
    "body { background: " ++ bgColor ++ " }\n\
    \h2 { color: #000000 }\n\
    \\n\
    \.TableHeadingColor { background: #CCCCFF }\n\
    \.TableRowColor     { background: " ++ bgColor ++ " }\n\
    \\n\
    \.FrameHeadingFont { font-size: normal; font-family: normal } \n\
    \.FrameItemFont    { font-size: normal; font-family: normal } \n\
    \"