aboutsummaryrefslogtreecommitdiff
path: root/src/HaddockHtml.hs
blob: 5a16b6699b14277abeabf6720536394311fc2536 (plain) (blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
--
-- Haddock - A Haskell Documentation Tool
--
-- (c) Simon Marlow 2002
--

module HaddockHtml (ppHtml) where

import Prelude hiding (div)
import HaddockVersion
import HaddockTypes
import HaddockUtil
import HsSyn

import Maybe	( fromJust, isNothing, isJust )
import FiniteMap
import List 	( sortBy )
import Char	( toUpper, toLower )
import Monad	( when )
--import IOExts

import Html
import qualified Html

-- -----------------------------------------------------------------------------
-- Files we need to copy from our $libdir

cssFile  = "haddock.css"
iconFile = "haskell_icon.gif"

-- -----------------------------------------------------------------------------
-- Generating HTML documentation

ppHtml	:: String
	-> Maybe String
	-> [(Module, Interface)]
	-> FilePath			-- destination directory
	-> Maybe String			-- CSS file
	-> String			-- $libdir
	-> IO ()
ppHtml title source_url ifaces odir maybe_css libdir =  do
  let 
	css_file = case maybe_css of
			Nothing -> libdir ++ pathSeparator:cssFile
			Just f  -> f
	css_destination = odir ++ pathSeparator:cssFile

	icon_file        = libdir ++ pathSeparator:iconFile
	icon_destination = odir   ++ pathSeparator:iconFile

	visible_ifaces = filter visible ifaces
	visible (m,i) = OptHide `notElem` iface_options i

  css_contents <- readFile css_file
  writeFile css_destination css_contents
  icon_contents <- readFile icon_file
  writeFile icon_destination icon_contents

  ppHtmlContents odir title source_url (map fst visible_ifaces)
  ppHtmlIndex odir title visible_ifaces
  mapM_ (ppHtmlModule odir title source_url) visible_ifaces

moduleHtmlFile :: String -> FilePath
moduleHtmlFile mod = mod ++ ".html" -- ToDo: Z-encode filename?

contentsHtmlFile = "index.html"
indexHtmlFile    = "doc-index.html"
subIndexHtmlFile k a = "doc-index-" ++ k:a:".html"

footer = 
  tda [theclass "botbar"] << 
	( toHtml "Produced by" <+> 
	  (anchor ! [href projectUrl] << toHtml projectName) <+>
	  toHtml ("version " ++ projectVersion)
	)
   

src_button source_url mod file
  | Just u <- source_url = 
	let src_url = if (last u == '/') then u ++ file else u ++ '/':file
	in
	(tda [theclass "topbut", nowrap] <<
  	   anchor ! [href src_url] << toHtml "Source code")
  | otherwise =
	Html.emptyTable
  

parent_button mod = 
  case span (/= '.') (reverse mod) of
   (m, '.':rest) -> 
       (tda [theclass "topbut", nowrap] <<
  	 anchor ! [href (moduleHtmlFile (reverse rest))] << toHtml "Parent")
   _ -> 
	Html.emptyTable

contentsButton = tda [theclass "topbut", nowrap] <<
  	 	    anchor ! [href contentsHtmlFile] << toHtml "Contents"

indexButton = tda [theclass "topbut", nowrap] <<
  	 	    anchor ! [href indexHtmlFile] << toHtml "Index"

simpleHeader title = 
  (tda [theclass "topbar"] << 
     vanillaTable << (
       (td << 
  	image ! [src "haskell_icon.gif", width "16", height 16, alt " " ]
       ) <->
       (tda [theclass "title"] << toHtml title) <->
	contentsButton <-> indexButton
   ))

pageHeader mod iface title source_url =
  (tda [theclass "topbar"] << 
    vanillaTable << (
       (td << 
  	image ! [src "haskell_icon.gif", width "16", height 16, alt " "]
       ) <->
       (tda [theclass "title"] << toHtml title) <->
	src_button source_url mod (iface_filename iface) <->
	parent_button mod <->
	contentsButton <->
	indexButton
    )
   ) </>
   tda [theclass "modulebar"] <<
	(vanillaTable << (
	  (td << font ! [size "6"] << toHtml mod) <->
	  moduleInfo iface
	)
    )

moduleInfo iface 
  | Nothing   <- iface_info iface = Html.emptyTable
  | Just info <- iface_info iface =
          tda [align "right"] <<
             (table ! [border 0, cellspacing 0, cellpadding 0] << (
        	  (tda [theclass "infohead"] << toHtml "Portability") <->
        	  (tda [theclass "infoval"] << toHtml (portability info)) </>
        	  (tda [theclass "infohead"] << toHtml "Stability") <->
        	  (tda [theclass "infoval"] << toHtml (stability info)) </>
        	  (tda [theclass "infohead"] << toHtml "Maintainer") <->
        	  (tda [theclass "infoval"] << toHtml (maintainer info))
              ))

-- ---------------------------------------------------------------------------
-- Generate the module contents

ppHtmlContents :: FilePath -> String -> Maybe String -> [Module]
   -> IO ()
ppHtmlContents odir title source_url mods = do
  let tree = mkModuleTree mods  
      html = 
	header (thetitle (toHtml title) +++
		thelink ! [href cssFile, 
		  rel "stylesheet", thetype "text/css"]) +++
        body <<  
	  table ! [width "100%", cellpadding 0, cellspacing 1] << (
   	    simpleHeader title </>
	    ppModuleTree title tree </>
	    footer
	  )
  writeFile (odir ++ pathSeparator:contentsHtmlFile) (renderHtml html)

ppModuleTree :: String -> [ModuleTree] -> HtmlTable
ppModuleTree title ts = 
  tda [theclass "section1"] << toHtml "Modules" </>
  td <<  table ! [cellpadding 0, cellspacing 2] << aboves (map (mkNode []) ts)

mkNode :: [String] -> ModuleTree -> HtmlTable
mkNode ss (Node s leaf []) =
  td << mkLeaf s ss leaf
mkNode ss (Node s leaf ts) = 
  (td << mkLeaf s ss leaf)
  </>
  (tda [theclass "children"] << 
     vanillaTable (toHtml (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  = t : addToTrees (s1:ss) ts
  | s1 == s2  = Node s2 (leaf || null ss) (addToTrees ss subs) : ts
  | otherwise = mkSubTree (s1:ss) ++ t : 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 index

ppHtmlIndex :: FilePath -> String -> [(Module,Interface)] -> IO ()
ppHtmlIndex odir title ifaces = do
  let html = 
	header (thetitle (toHtml (title ++ " (Index)")) +++
		thelink ! [href cssFile, 
		  rel "stylesheet", thetype "text/css"]) +++
        body <<  
	  table ! [width "100%", cellpadding 0, cellspacing 1] << (
	    simpleHeader title </>
	    tda [theclass "section1"] << toHtml "Type/Class Index" </>
	    index_html tycls_index 't' </>
	    tda [theclass "section1"] << toHtml "Function/Constructor Index" </>
	    index_html var_index 'v'
	   )

  when split_indices
    (do mapM_ (do_sub_index "Type/Class" tycls_index 't') ['A'..'Z'] 
        mapM_ (do_sub_index "Function/Constructor" var_index 'v') ['A'..'Z'] 
    )

  writeFile (odir ++ pathSeparator:indexHtmlFile) (renderHtml html)

 where
  split_indices = length tycls_index > 50 || length var_index > 50

  index_html this_ix kind
    | split_indices = 
	td << table ! [cellpadding 0, cellspacing 5] <<
	    besides [ td << anchor ! [href (subIndexHtmlFile kind c)] <<
			 toHtml [c]
		    | c <- ['A'..'Z'] ]
   | otherwise =
	td << table ! [cellpadding 0, cellspacing 5] <<
	  aboves (map indexElt this_ix) 
 	
  do_sub_index descr this_ix kind c
    = writeFile (odir ++ pathSeparator:subIndexHtmlFile kind c)
	(renderHtml html)
    where 
      html = header (thetitle (toHtml (title ++ " (" ++ descr ++ "Index)")) +++
		thelink ! [href cssFile, 
		  rel "stylesheet", thetype "text/css"]) +++
             body <<  
	      table ! [width "100%", cellpadding 0, cellspacing 1] << (
	        simpleHeader title </>
	        tda [theclass "section1"] << 
	      	toHtml (descr ++ " Index (" ++ c:")") </>
	        td << table ! [cellpadding 0, cellspacing 5] <<
	      	  aboves (map indexElt index_part) 
	       )

      index_part = [(n,stuff) | (n,stuff) <- this_ix, n `nameBeginsWith` c]

  tycls_index = index isTyClsName
  var_index   = index (not.isTyClsName)

  isTyClsName (HsTyClsName _) = True
  isTyClsName _ = False

  index :: (HsName -> Bool) -> [(HsName, [(Module,Bool)])]
  index f = sortBy cmp (fmToList (full_index f))
    where cmp (n1,_) (n2,_) = n1 `compare` n2
    
  iface_indices f = map (getIfaceIndex f) ifaces
  full_index f = foldr1 (plusFM_C (++)) (iface_indices f)

  getIfaceIndex f (mod,iface) = listToFM
    [ (name, [(mod, mod == mod')]) 
    | (name, Qual mod' _) <- fmToList (iface_env iface),
      f name ]

  indexElt :: (HsName, [(Module,Bool)]) -> HtmlTable
  indexElt (nm, entries) = 
     td << ppHsName nm
     <-> td << (hsep [ if defining then
			 bold << anchor ! [href (linkId mod nm)] << toHtml mod
		       else
			 anchor ! [href (linkId mod nm)] << toHtml mod
	             | (Module mod, defining) <- entries ])

nameBeginsWith (HsTyClsName id) c = idBeginsWith id c
nameBeginsWith (HsVarName   id) c = idBeginsWith id c

idBeginsWith (HsIdent   s) c = head s `elem` [toLower c, toUpper c]
idBeginsWith (HsSymbol  s) c = head s `elem` [toLower c, toUpper c]
idBeginsWith (HsSpecial s) c = head s `elem` [toLower c, toUpper c]

-- ---------------------------------------------------------------------------
-- Generate the HTML page for a module

ppHtmlModule :: FilePath -> String -> Maybe String
	-> (Module,Interface) -> IO ()
ppHtmlModule odir title source_url (Module mod,iface) = do
  let html = 
	header (thetitle (toHtml mod) +++
		thelink ! [href cssFile,
		  rel "stylesheet", thetype "text/css"]) +++
        body <<  
	  table ! [width "100%", cellpadding 0, cellspacing 1] << (
	    pageHeader mod iface title source_url </>
	    ifaceToHtml mod iface </>
	    footer
         )
  writeFile (odir ++ pathSeparator:moduleHtmlFile mod) (renderHtml html)

ifaceToHtml :: String -> Interface -> HtmlTable
ifaceToHtml mod iface
  | null exports = Html.emptyTable
  | otherwise =
    td << table ! [width "100%", cellpadding 0, cellspacing 15] << 
	(contents </> description </> synopsis </> maybe_hr </> body)
  where 
	exports = numberSectionHeadings (iface_exports iface)
	doc_map = iface_name_docs iface

	has_doc (ExportDecl d)
	 | Just x <- declMainBinder d = isJust (lookupFM doc_map x)
	has_doc (ExportModule _) = False
	has_doc _ = True

	no_doc_at_all = not (any has_doc exports)

	contents = td << ppModuleContents exports

	description
         | Just doc <- iface_doc iface
         = (tda [theclass "section1"] << toHtml "Description") </>
	   docBox (markup htmlMarkup doc)
	 | otherwise
	 = Html.emptyTable

	-- omit the synopsis if there are no documentation annotations at all
	synopsis
	  | no_doc_at_all = Html.emptyTable
	  | otherwise
	  = (tda [theclass "section1"] << toHtml "Synopsis") </>
            (tda [width "100%", theclass "synopsis"] << 
  	      table ! [width "100%", cellpadding 0, cellspacing 8, border 0] << 
  	        aboves (map (processExport doc_map True)  exports))

	maybe_hr
	     | not (no_doc_at_all),  ExportGroup 1 _ _ <- head exports
		 = td << hr
	     | otherwise  = Html.emptyTable

	body = aboves (map (processExport doc_map False) exports)

ppModuleContents :: [ExportItem] -> HtmlTable
ppModuleContents exports
  | length sections < 2 = Html.emptyTable
  | otherwise           = tda [theclass "section4"] << bold << toHtml "Contents"
  		           </> td << dlist << concatHtml sections
 where
  (sections, _leftovers{-should be []-}) = process 0 exports

  process :: Int -> [ExportItem] -> ([Html],[ExportItem])
  process n [] = ([], [])
  process n items@(ExportGroup lev id doc : rest) 
    | lev <= n  = ( [], items )
    | otherwise = ( html:sections, rest2 )
    where
	html = (dterm << anchor ! [href ('#':id)] << markup htmlMarkup doc)
		 +++ mk_subsections subsections
	(subsections, rest1) = process lev rest
	(sections,    rest2) = process n   rest1
  process n (_ : rest) = process n rest

  mk_subsections [] = noHtml
  mk_subsections ss = ddef << dlist << concatHtml ss

-- we need to assign a unique id to each section heading so we can hyperlink
-- them from the contents:
numberSectionHeadings :: [ExportItem] -> [ExportItem]
numberSectionHeadings exports = go 1 exports
  where go n [] = []
	go n (ExportGroup lev _ doc : es) 
	  = ExportGroup lev (show n) doc : go (n+1) es
	go n (other:es)
	  = other : go n es

processExport :: FiniteMap HsName Doc -> Bool -> ExportItem -> HtmlTable
processExport doc_map summary (ExportGroup lev id doc)
  | summary   = Html.emptyTable
  | otherwise = ppDocGroup lev (anchor ! [name id] << markup htmlMarkup doc)
processExport doc_map summary (ExportDecl decl)
  = doDecl doc_map summary decl
processExport doc_map summary (ExportDoc doc)
  | summary = Html.emptyTable
  | otherwise = docBox (markup htmlMarkup doc)
processExport doc_map summary (ExportModule (Module mod))
  = declBox (toHtml "module" <+> ppHsModule mod)

ppDocGroup lev doc
  | lev == 1  = tda [ theclass "section1" ] << doc
  | lev == 2  = tda [ theclass "section2" ] << doc
  | lev == 3  = tda [ theclass "section3" ] << doc
  | otherwise = tda [ theclass "section4" ] << doc

-- -----------------------------------------------------------------------------
-- Converting declarations to HTML

declWithDoc :: Bool -> Maybe Doc -> Html -> HtmlTable
declWithDoc True  doc        html_decl = declBox html_decl
declWithDoc False Nothing    html_decl = declBox html_decl
declWithDoc False (Just doc) html_decl = 
	tda [width "100%"] << 
	    vanillaTable << 
		(declBox html_decl </> docBox (markup htmlMarkup doc))

doDecl :: FiniteMap HsName Doc -> Bool -> HsDecl -> HtmlTable
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 True{-is newtype-}
		(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 False{-not newtype-} decl

     do_decl decl@(HsClassDecl _ _ _ _)
	= ppHsClassDecl doc_map summary decl

     do_decl (HsDocGroup lev str) 
	= if summary then Html.emptyTable 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

ppShortDataDecl :: Bool -> Bool -> HsDecl -> Html
ppShortDataDecl summary is_newty 
	(HsDataDecl loc ctx nm args [con] drv) =
   ppHsDataHeader summary is_newty nm args      
     <+> equals <+> ppShortConstr summary con
ppShortDataDecl summary is_newty
	(HsDataDecl loc ctx nm args cons drv) = 
   vanillaTable << (
     aboves (
	(declBox (ppHsDataHeader summary is_newty nm args) :
 	zipWith do_constr ('=':repeat '|') cons
     )
    )
  )
  where do_constr c con = tda [theclass "condecl"] << (
				toHtml [c] <+> ppShortConstr summary con)

-- First, the abstract case:

ppHsDataDecl doc_map summary is_newty (HsDataDecl loc ctx nm args [] drv) = 
   declWithDoc summary (lookupFM doc_map nm)
     (ppHsDataHeader summary is_newty nm args)

-- The rest of the cases:

ppHsDataDecl doc_map summary is_newty decl@(HsDataDecl loc ctx nm args cons drv)
  | summary || no_constr_docs
	= declWithDoc summary (lookupFM doc_map nm)
     		(ppShortDataDecl summary is_newty decl)

  | otherwise
        = td << vanillaTable << (header </> datadoc </> constrs)
  where
	header = declBox (ppHsDataHeader False is_newty nm args)
	datadoc = docBox (markup htmlMarkup (fromJust doc))

	constr_hdr = tda [ theclass "section4" ] << toHtml "Constructors"

	constrs
	  | null cons = Html.emptyTable
	  | otherwise = 
		tda [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

	no_constr_docs = all constr_has_no_doc cons

	constr_has_no_doc (HsConDecl _ nm _ _ _ _) 
	   = isNothing (lookupFM doc_map nm)
	constr_has_no_doc (HsRecDecl _ nm _ _ fields _)
	   = isNothing (lookupFM doc_map nm) && all field_has_no_doc fields

 	field_has_no_doc (HsFieldDecl nms _ _)
	   = all isNothing (map (lookupFM doc_map) nms)


ppShortConstr :: Bool -> HsConDecl -> Html
ppShortConstr summary (HsConDecl pos nm tvs ctxt typeList _maybe_doc) = 
   ppHsConstrHdr tvs ctxt +++
	hsep (ppHsBinder summary nm : map ppHsBangType typeList)
ppShortConstr summary (HsRecDecl pos nm tvs ctxt fields maybe_doc) =
   ppHsConstrHdr tvs ctxt +++
   ppHsBinder summary nm +++
   braces (vanillaTable << aboves (map (ppShortField summary) fields))

ppHsConstrHdr tvs ctxt
 = (if null tvs then noHtml else keyword "forall" <+> 
				 hsep (map ppHsName tvs) <+> 
				 toHtml ". ")
   +++
   (if null ctxt then noHtml else ppHsContext ctxt <+> toHtml "=> ")

ppHsFullConstr doc_map (HsConDecl pos nm tvs ctxt typeList _maybe_doc) = 
     declWithDoc False doc (
	hsep ((ppHsConstrHdr tvs ctxt +++ 
		ppHsBinder False nm) : map ppHsBangType typeList)
      )
   where
     doc = lookupFM doc_map nm
ppHsFullConstr doc_map (HsRecDecl pos nm tvs ctxt fields maybe_doc) =
   td << vanillaTable << (
     case doc of
       Nothing  -> aboves [hdr, fields_html]
       Just doc -> aboves [hdr, constr_doc, fields_html]
   )

  where hdr = declBox (ppHsConstrHdr tvs ctxt +++ 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


ppShortField summary (HsFieldDecl ns ty _doc) 
  = tda [theclass "recfield"] << (
	  hsep (punctuate comma (map (ppHsBinder summary) 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 is_newty nm args = 
  (if is_newty then keyword "newtype" else 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 fds = 
  keyword "class" <+> ppHsType ty <+>
  if null fds then noHtml else 
	char '|' <+> hsep (punctuate comma (map fundep fds))
  where
	fundep (vars1,vars2) = hsep (map ppHsName vars1) <+> toHtml "->" <+>
			       hsep (map ppHsName vars2)

ppShortClassDecl doc_map summary decl@(HsClassDecl loc ty fds decls) = 
  if null decls
    then declBox hdr
    else td << (
	  vanillaTable << (
           declBox (hdr <+> keyword "where")
	    </> 
           tda [theclass "cbody"] << (
	    vanillaTable << (
	       aboves (map (doDecl doc_map summary) (filter keepDecl decls))
           ))
         ))
   where
	Just c = declMainBinder decl
	hdr | not summary = linkTarget c +++ ppClassHdr ty fds
	    | otherwise   = ppClassHdr ty fds

ppHsClassDecl doc_map summary decl@(HsClassDecl loc ty fds 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 fds)
	   | otherwise  = declBox (linkTarget c +++ ppClassHdr ty fds <+> 
					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) kept_decls)
           	      )

	kept_decls = filter keepDecl decls

        decl_has_no_doc decl
	 | Just b <- declMainBinder decl = isNothing (lookupFM doc_map b)
	 | otherwise = True

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

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 (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b )
  = brackets $ ppHsType b
ppHsAType t = parens $ ppHsType t

-- -----------------------------------------------------------------------------
-- Names

linkTarget :: HsName -> Html
linkTarget nm = anchor ! [name (hsNameStr nm)] << toHtml ""

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,
  markupURL	      = \url -> anchor ! [href url] << toHtml url
  }

-- -----------------------------------------------------------------------------
-- * 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  = noHtml

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 "#)"

text   = strAttr "TEXT"

declBox :: Html -> HtmlTable
declBox html = tda [theclass "decl"] << html

docBox :: Html -> HtmlTable
docBox html = tda [theclass "doc"] << html

vanillaTable = table ! [width "100%", cellpadding 0, cellspacing 0, border 0]