aboutsummaryrefslogtreecommitdiff
path: root/src/Main.hs
blob: 1f76fe47aa114066121e40fa293c25c2b066af61 (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
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
{-# OPTIONS_GHC -fglasgow-exts #-}
--
-- Haddock - A Haskell Documentation Tool
--
-- (c) Simon Marlow 2003
--

module Main (main) where

import Binary
import Digraph
--import HaddockDB   -- not compiling
import HaddockHtml
import HaddockLex
import HaddockParse
import HaddockRename
import HaddockTypes
import HaddockUtil
import HaddockVersion
import HsParseMonad
import HsParser
import HsSyn
import Map ( Map )
import qualified Map hiding ( Map )
import Set
import Paths_Haddock	( getDataDir )

import Control.Exception ( bracket )
import Control.Monad ( when )
import Control.Monad.Writer ( Writer, runWriter, tell )
import Data.Char ( isSpace )
import Data.IORef ( writeIORef )
import Data.List ( nub, (\\), foldl', sortBy )
import Data.Maybe ( isJust, isNothing, maybeToList )
--import Debug.Trace
import System.Console.GetOpt ( getOpt, usageInfo, ArgOrder(..), OptDescr(..), ArgDescr(..) )
import System.Environment ( getArgs )
import System.IO ( stderr, IOMode(..), openFile, hClose, hGetContents, hPutStrLn )
#if defined(mingw32_HOST_OS)
import Foreign
import Foreign.C
#endif

#if __GLASGOW_HASKELL__ >= 603
import System.Process
import System.Exit
import Control.Exception	( Exception(..), throwIO, catch )
import Prelude hiding (catch)
import System.Directory		( doesDirectoryExist, doesFileExist )
import Control.Concurrent
#endif

-----------------------------------------------------------------------------
-- Top-level stuff
main :: IO ()
main = do
  cmdline <- getArgs
  case getOpt Permute options cmdline of
    (flags, args, []    ) -> run flags args
    (_,     _,    errors) -> do prog <- getProgramName
                                die (concat errors ++
                                     usageInfo (usageHeader prog) options)

usageHeader :: String -> String
usageHeader prog = "Usage: " ++ prog ++ " [OPTION...] file...\n"

data Flag
  = Flag_CSS String
  | Flag_Debug
--  | Flag_DocBook
  | Flag_DumpInterface FilePath
  | Flag_Heading String
  | Flag_Package String
  | Flag_Html
  | Flag_HtmlHelp String
  | Flag_Lib String
  | Flag_NoImplicitPrelude
  | Flag_OutputDir FilePath
  | Flag_Prologue FilePath
  | Flag_ReadInterface FilePath
  | Flag_SourceURL String
  | Flag_WikiURL String
  | Flag_Help
  | Flag_Verbose
  | Flag_Version
  | Flag_UseContents String
  | Flag_GenContents
  | Flag_UseIndex String
  | Flag_GenIndex
  | Flag_IgnoreAllExports
  | Flag_HideModule String
  | Flag_UsePackage String
  deriving (Eq)

options :: [OptDescr Flag]
options =
  [ 
    Option ['o']  ["odir"]     (ReqArg Flag_OutputDir "DIR")
	"directory in which to put the output files",
    Option ['i'] ["read-interface"] (ReqArg Flag_ReadInterface "FILE")
	"read an interface from FILE",
    Option ['D']  ["dump-interface"]   (ReqArg Flag_DumpInterface "FILE")
        "dump an interface for these modules in FILE",
    Option ['l']  ["lib"]         (ReqArg Flag_Lib "DIR") 
	"location of Haddock's auxiliary files",
--    Option ['S']  ["docbook"]  (NoArg Flag_DocBook)
--	"output in DocBook XML",
    Option ['h']  ["html"]     (NoArg Flag_Html)
	"output in HTML",
    Option []  ["html-help"]    (ReqArg Flag_HtmlHelp "format")
	"produce index and table of contents in mshelp, mshelp2 or devhelp format (with -h)",
    Option ['s']  ["source"]   (ReqArg Flag_SourceURL "URL") 
	"base URL for links to source code",
    Option []     ["wiki"]     (ReqArg Flag_WikiURL "URL")
	"base URL for links to a wiki",
    Option ['c']  ["css"]         (ReqArg Flag_CSS "FILE") 
	"the CSS file to use for HTML output",
    Option ['p']  ["prologue"] (ReqArg Flag_Prologue "FILE")
	"file containing prologue text",
    Option ['t']  ["title"]    (ReqArg Flag_Heading "TITLE")
	"page heading",
    Option ['k']  ["package"]  (ReqArg Flag_Package "PACKAGE")
	"package name (optional)",
    Option ['n']  ["no-implicit-prelude"] (NoArg Flag_NoImplicitPrelude)
 	"do not assume Prelude is imported",
    Option ['d']  ["debug"]  (NoArg Flag_Debug)
	"extra debugging output",
    Option ['?']  ["help"]  (NoArg Flag_Help)
	"display this help and exit",
    Option ['V']  ["version"]  (NoArg Flag_Version)
	"output version information and exit",
    Option ['v']  ["verbose"]  (NoArg Flag_Verbose)
        "increase verbosity",
    Option [] ["use-contents"] (ReqArg Flag_UseContents "URL")
	"use a separately-generated HTML contents page",
    Option [] ["gen-contents"] (NoArg Flag_GenContents)
	"generate an HTML contents from specified interfaces",
    Option [] ["use-index"] (ReqArg Flag_UseIndex "URL")
	"use a separately-generated HTML index",
    Option [] ["gen-index"] (NoArg Flag_GenIndex)
	"generate an HTML index from specified interfaces",
    Option [] ["ignore-all-exports"] (NoArg Flag_IgnoreAllExports)
	"behave as if all modules have the ignore-exports atribute",
    Option [] ["hide"] (ReqArg Flag_HideModule "M")
	"behave as if module M has the hide attribute",
    Option [] ["use-package"] (ReqArg Flag_UsePackage "P")
	"the modules being processed depend on package P"
  ]

run :: [Flag] -> [FilePath] -> IO ()
run flags files = do
  when (Flag_Help `elem` flags) $ do
     prog <- getProgramName
     bye (usageInfo (usageHeader prog) options)

  when (Flag_Version `elem` flags) $
     bye ("Haddock version " ++ projectVersion ++ ", (c) Simon Marlow 2003\n")

  let title = case [str | Flag_Heading str <- flags] of
		[] -> ""
		(t:_) -> t

      package = case [str | Flag_Package str <- flags] of
		[] -> Nothing
		(t:_) -> Just t

      maybe_source_url = case [str | Flag_SourceURL str <- flags] of
			[] -> Nothing
			(t:_) -> Just t

      maybe_wiki_url = case [str | Flag_WikiURL str <- flags] of
			[] -> Nothing
			(t:_) -> Just t

      verbose = Flag_Verbose `elem` flags

  libdir <- case [str | Flag_Lib str <- flags] of
		[] -> getDataDir -- provided by Cabal
		fs -> return (last fs)

  let css_file = case [str | Flag_CSS str <- flags] of
			[] -> Nothing
			fs -> Just (last fs)

  odir <- case [str | Flag_OutputDir str <- flags] of
		[] -> return "."
		fs -> return (last fs)

  let dump_iface = case [str | Flag_DumpInterface str <- flags] of
		  	[] -> Nothing
		  	fs -> Just (last fs)

      read_iface_flags = [ parseIfaceOption str 
		       | Flag_ReadInterface str <- flags ]

      maybe_contents_url = 
	case [url | Flag_UseContents url <- flags] of
		[] -> Nothing
		us -> Just (last us)

      maybe_index_url = 
	case [url | Flag_UseIndex url <- flags] of
		[] -> Nothing
		us -> Just (last us)

      maybe_html_help_format =
	case [hhformat | Flag_HtmlHelp hhformat <- flags] of
		[]      -> Nothing
		formats -> Just (last formats)
		
  prologue <- getPrologue flags

  -- grok the --use-package flags
  pkg_ifaces_to_read <- getPackageIfaces flags verbose

  let ifaces_to_read = read_iface_flags ++ pkg_ifaces_to_read

  read_iface_stuff <- mapM readIface (map snd ifaces_to_read)

  let 
      (read_ifacess, doc_envs) = unzip read_iface_stuff
      read_ifaces = concat read_ifacess

      ext_doc_env = Map.unions doc_envs
      
      visible_read_ifaces = filter ((OptHide `notElem`) . iface_options) 
				read_ifaces
      external_mods = map iface_module read_ifaces
      pkg_paths = map fst ifaces_to_read

  updateHTMLXRefs pkg_paths read_ifacess

  when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags)
	&& Flag_Html `elem` flags) $
	die ("-h cannot be used with --gen-index or --gen-contents")

  when (Flag_GenContents `elem` flags) $ do
	ppHtmlContents odir title package maybe_html_help_format
            maybe_index_url maybe_wiki_url visible_read_ifaces prologue
        copyHtmlBits odir libdir css_file

  when (Flag_GenIndex `elem` flags) $ do
	ppHtmlIndex odir title package maybe_html_help_format
            maybe_contents_url maybe_wiki_url visible_read_ifaces
        copyHtmlBits odir libdir css_file
        
  when (Flag_GenContents `elem` flags && Flag_GenIndex `elem` flags) $ do
    ppHtmlHelpFiles title package visible_read_ifaces odir maybe_html_help_format pkg_paths

  parsed_mods <- mapM parse_file files

  sorted_mod_files <- sortModules (zip parsed_mods files)
	-- emits an error message if there are recursive modules

  -- process the modules in sorted order, building up a mapping from
  -- modules to interfaces.
  let 
	loop mod_env ifaces [] = return (reverse ifaces)
	loop mod_env ifaces ((hsmod,file):mdls)  = do 
	   let (iface,msgs) = runWriter $
		   mkInterfacePhase1 flags verbose mod_env file package hsmod
	       new_mod_env = Map.insert (iface_module iface) iface mod_env
	   mapM_ (hPutStrLn stderr) msgs
	   loop new_mod_env (iface:ifaces) mdls

  let 
	mod_map = Map.fromList [ (iface_module iface,iface) 
			       | iface <- read_ifaces ]
  
  ifaces <- loop mod_map read_ifaces sorted_mod_files
  let 
      these_ifaces0 = [ iface | iface <- ifaces,
		    	        iface_module iface `notElem` external_mods ]

  let these_ifaces1  = attachInstances these_ifaces0
      this_doc_env   = buildGlobalDocEnv these_ifaces1
      global_doc_env = this_doc_env `Map.union`
		       ext_doc_env `Map.union`
		       builtinDocEnv


--  Now do phase 2
  let
	loop2 ifaces [] = return (reverse ifaces)
	loop2 ifaces (iface:rest) = do
	   let (iface',msgs) = runWriter $
		    mkInterfacePhase2 verbose iface global_doc_env
	   mapM_ (hPutStrLn stderr) msgs
	   loop2 (iface':ifaces) rest

  these_ifaces <- loop2 [] these_ifaces1  

--  when (Flag_DocBook `elem` flags) $
--    putStr (ppDocBook odir mod_ifaces)


  when (Flag_Debug `elem` flags) $ do
    mapM_ putStrLn (map show [ (iface_module i, 
				     Map.toAscList (iface_env i), 
				     Map.toAscList (iface_sub i))
			     | i <-  these_ifaces ])

  when (Flag_Html `elem` flags) $ do
    ppHtml title package these_ifaces odir
		prologue maybe_html_help_format
		maybe_source_url maybe_wiki_url
		maybe_contents_url maybe_index_url
    copyHtmlBits odir libdir css_file

  -- dump an interface if requested
  case dump_iface of
     Nothing -> return ()
     Just fn -> dumpInterfaces these_ifaces this_doc_env fn

parseIfaceOption :: String -> (FilePath,FilePath)
parseIfaceOption s = 
  case break (==',') s of
	(fpath,',':file) -> (fpath,file)
	(file, _)        -> ("", file)
		

updateHTMLXRefs :: [FilePath] -> [[Interface]] -> IO ()
updateHTMLXRefs paths ifaces_s =
  writeIORef html_xrefs_ref (Map.fromList mapping)
 where
  mapping = [ (iface_module iface, fpath)
	    | (fpath, ifaces) <- zip paths ifaces_s,
	      iface <- ifaces
	    ]

parse_file :: FilePath -> IO HsModule
parse_file file = do
  bracket 
    (openFile file ReadMode)
    (\h -> hClose h)
    (\h -> do stuff <- hGetContents h 
	      case parse stuff (SrcLoc 1 1 file) 1 0 file [] of
	        Ok _ e -> return e
	        Failed err -> die (file ++ ':':err ++ "\n")
    )

getPrologue :: [Flag] -> IO (Maybe Doc)
getPrologue flags
  = case [filename | Flag_Prologue filename <- flags ] of
	[] -> return Nothing 
	[filename] -> do
	   str <- readFile filename
	   case parseParas (tokenise str) of
		Left err -> dieMsg err
		Right doc -> return (Just doc)
	_otherwise -> dieMsg "multiple -p/--prologue options"

-- ---------------------------------------------------------------------------
-- External packages

getPackageIfaces :: [Flag] -> Bool -> IO [(String,String)]
getPackageIfaces flags verbose =
  let
	pkgs = [pkg | Flag_UsePackage pkg <- flags]
  in
#if __GLASGOW_HASKELL__ < 603
  if (not (null pkgs))
	then die ("-use-package not supported; recompile Haddock with GHC 6.4 or later")
	else return []
#else
  do
    mb_iface_details <- mapM getPkgIface pkgs
    return [ ok | Just ok <- mb_iface_details ]
 where
  hc_pkg = "ghc-pkg"  -- ToDo: flag

  getPkgIface pkg = do
	when verbose $
	   putStrLn ("querying ghc-pkg for " ++ pkg ++ "...")
        getPkgIface' pkg
	   `catch` (\e -> do
		  putStrLn ("Warning: cannot use package " ++ pkg ++ ":")
		  putStrLn ("   " ++ show e)
		  return Nothing)

  getPkgIface' pkg = do
	html <- getPkgField pkg "haddock-html"
	html_exists <- doesDirectoryExist html
	when (not html_exists) $ do
	   throwIO (ErrorCall ("HTML directory " ++ html ++ " does not exist."))

	iface <- getPkgField pkg "haddock-interfaces"
	iface_exists <- doesFileExist iface
	when (not iface_exists) $ do
	   throwIO (ErrorCall ("interface " ++ iface ++ " does not exist."))

	return (Just (html, iface))

  getPkgField pkg field = do
	(hin,hout,herr,p) <- runInteractiveProcess hc_pkg 
				["field", pkg, field]
				Nothing Nothing
	hClose hin
	out <- hGetContents hout
	forkIO (hGetContents herr >> return ()) -- just sink the stderr
	r <- waitForProcess p
	when (r /= ExitSuccess) $
	   throwIO (ErrorCall ("ghc-pkg failed"))
	let value = dropWhile isSpace $ init $ tail $ dropWhile (/=':') out
	when verbose $ 
	   putStrLn ("   " ++ field ++ ": " ++ value)
	return value
#endif

-----------------------------------------------------------------------------
-- Figuring out the definitions that are exported from a module

-- We're going to make interfaces in two passes:
--
--   1. Rename the code.  This basically involves resolving all
--      the names to "original names".
--
--   2. Convert all the entity references to "doc names".  These are
--      the names we want to link to in the documentation.

mkInterfacePhase1
   :: [Flag]
   -> Bool				-- verbose
   -> ModuleMap -> FilePath -> Maybe String -> HsModule
   -> ErrMsgM Interface			-- the "interface" of the module

mkInterfacePhase1 flags verbose mod_map filename package
	(HsModule (SrcLoc _ _ orig_filename) mdl exps imps decls
                  maybe_opts maybe_info maybe_doc) = do

  let
      no_implicit_prelude = Flag_NoImplicitPrelude `elem` flags
      ignore_all_exports = Flag_IgnoreAllExports `elem` flags

  -- Process the options, if available
  opts0 <- case maybe_opts of
		Just opt_str -> processOptions opt_str
		Nothing      -> return []
  let
	-- check for a --hide option
	Module mod_str = mdl
	opts
	  | Flag_HideModule mod_str `elem` flags = OptHide : opts0
	  | otherwise			         = opts0

  let
     -- expand type signatures with multiple variables into multiple
     -- type signatures
     expanded_decls = concat (map expandDecl decls)

     sub_map = mkSubNames expanded_decls

     -- first, attach documentation to declarations
     annotated_decls = collectDoc expanded_decls

     -- now find the defined names
     locally_defined_names = collectNames annotated_decls

     qual_local_names   = map (Qual mdl) locally_defined_names
     unqual_local_names = map UnQual     locally_defined_names

     local_orig_env = Map.fromList (zip unqual_local_names qual_local_names ++
			            zip qual_local_names   qual_local_names)
	 -- both qualified and unqualifed names are in scope for local things

     implicit_imps
	| no_implicit_prelude || any is_prel_import imps = imps
	| otherwise = HsImportDecl loc prelude_mod False Nothing Nothing : imps
	where 
		loc = SrcLoc 0 0 ""
	 	is_prel_import (HsImportDecl _ mdl0 _ _ _ ) = mdl0 == prelude_mod
  -- in

     -- build the orig_env, which maps names to *original* names (so we can
     -- find the original declarations & docs for things).
  imported_orig_env <- buildOrigEnv mdl verbose mod_map implicit_imps
 
  let
     orig_env = local_orig_env `Map.union` imported_orig_env

     -- convert names in source code to original, fully qualified, names
     (orig_exports, missing_names1) 
	= runRnFM orig_env (mapMaybeM renameExportList exps)

     (orig_decls, missing_names2)
	= runRnFM orig_env (mapM renameDecl annotated_decls)

     (orig_module_doc, missing_names3)
        = runRnFM orig_env (renameMaybeDoc maybe_doc)

     decl_map :: Map HsName HsDecl
     decl_map = Map.fromList [ (n,d) | d <- orig_decls, n <- declBinders d ]

     instances = [ d | d@HsInstDecl{} <- orig_decls ] ++
		 [ d | decl <- orig_decls, d <- derivedInstances mdl decl]

  -- trace (show (Map.toAscList orig_env)) $ do

     -- gather up a list of entities that are exported (original names)
  (exported_names, exported_visible_names)
	 <- exportedNames mdl mod_map
			locally_defined_names orig_env sub_map
			orig_exports opts

  let
     -- maps exported HsNames to orig HsQNames
     name_env = Map.fromList [ (nameOfQName n, n) | n <- exported_names ]

     -- find the names exported by this module that other modules should *not*
     -- link to.
     reexports = [ nm | n@(Qual _ nm) <- exported_names, 
			n `notElem` exported_visible_names ]

  -- in

  -- make the "export items", which will be converted into docs later
  orig_export_items <- mkExportItems mod_map mdl exported_names decl_map sub_map
			 		orig_decls opts orig_exports 
					ignore_all_exports
  let
     -- prune the export list to just those declarations that have
     -- documentation, if the 'prune' option is on.
     pruned_export_list
	| OptPrune `elem` opts = pruneExportItems orig_export_items
	| otherwise = orig_export_items
  -- in

  -- report any names we couldn't find/resolve
  let
      missing_names = missing_names1 ++ missing_names2 ++ missing_names3
			 --ignore missing_names3 & missing_names5 for now
      filtered_missing_names = filter (`notElem` builtinNames) missing_names

      name_strings = nub (map show filtered_missing_names)
  -- in

  when (OptHide `notElem` opts &&
	not (null name_strings)) $
	  tell ["Warning: " ++ show mdl ++ 
		": the following names could not be resolved:\n"++
		"   " ++ concat (map (' ':) name_strings)
		]

  return (Interface { 
		   iface_filename     = filename,
                   iface_orig_filename= orig_filename,
		   iface_module	      = mdl,
		   iface_package      = package,
		   iface_env          = name_env,
		   iface_reexported   = reexports,
		   iface_sub	      = sub_map,
		   iface_orig_exports = pruned_export_list,
		   iface_decls        = decl_map,
		   iface_info	      = maybe_info,
		   iface_doc          = orig_module_doc,
		   iface_options      = opts,
		   iface_exports      = error "iface_exports",
		   iface_insts	      = instances
		}
      	  )

-- -----------------------------------------------------------------------------
-- Phase 2

mkInterfacePhase2
   :: Bool			-- verbose
   -> Interface
   -> Map HsQName HsQName	-- global doc-name mapping
   -> ErrMsgM Interface

mkInterfacePhase2 verbose iface gbl_doc_env =
  case iface of {
    Interface {
	iface_module = this_mdl,
	iface_env = env,
	iface_reexported = reexports,
	iface_orig_exports = orig_export_items,
	iface_doc = orig_module_doc } ->

   let
     exported_visible_names = 
	[orig | (nm,orig) <- Map.toAscList env, nm `notElem` reexports ]

     -- build the import_env.
     import_env = foldl fn gbl_doc_env exported_visible_names
	where fn env qnm@(Qual _ nm) = Map.insert qnm (Qual this_mdl nm) env
	      fn env (UnQual nm) = env

     -- rename names in the exported declarations to point to things that
     -- are closer, or maybe even exported by, the current module.
     (renamed_export_list, missing_names1)
        = runRnUnqualFM import_env (renameExportItems orig_export_items)

     (final_module_doc, missing_names2)
        = runRnUnqualFM import_env (renameMaybeDoc orig_module_doc)

	-- we're only interested in reporting missing *qualfied*
	-- names, the unqualified ones are the ones that couldn't
	-- be resolved in phase 1 and have already been reported.
     filtered_missing_names = 
	filter isQual (missing_names1 ++ missing_names2)
	where isQual (Qual _ _) = True
	      isQual _ = False

     missing_names = map show (nub filtered_missing_names)
   in do

	-- report things that we couldn't link to.  Only do this
	-- for non-hidden modules.
   when (OptHide `notElem` iface_options iface &&
	 not (null missing_names)) $
	  tell ["Warning: " ++ show this_mdl ++ 
		": could not find link destinations for:\n"++
		"   " ++ concat (map (' ':) missing_names)
		]

   --  trace (show (Map.toAscList import_env)) $ do

   return iface{ iface_exports = renamed_export_list,
	  	 iface_doc = final_module_doc }
 }

-- -----------------------------------------------------------------------------

-- Try to generate instance declarations for derived instances.
-- We can't do this properly without instance inference, but if a type
-- variable occurs as a constructor argument, then we can just
-- propagate the derived class to the variable.  But we know nothing of
-- the constraints on any type variables that occur elsewhere.
-- Note that a type variable may be in both categories: then we know a
-- constraint, but there may be more, or a stronger constraint.
derivedInstances :: Module -> HsDecl -> [HsDecl]
derivedInstances mdl decl = case decl of
   HsDataDecl srcloc ctxt n tvs cons drv@(_:_) _ ->
      derived srcloc ctxt n tvs cons drv
   HsNewTypeDecl srcloc ctxt n tvs con drv@(_:_) _ ->
      derived srcloc ctxt n tvs [con] drv
   _ -> []
 where
  derived srcloc ctxt n tvs cons drv =
     [HsInstDecl srcloc
		 (ctxt ++ [(cls,[v]) | v <- simple_tvars] ++ extra_constraint)
		 (cls,[lhs]) [] |
	cls <- drv]
   where
     targs = map stripDocs (targsConstrs cons)
     -- a type variable is simple if it occurs as a data constructor argument
     simple_tvars = map HsTyVar $ Set.elems $ Set.fromList $ [tv | HsTyVar tv <- targs]
     -- a type variable is complex if it occurs inside a data constructor
     -- argument, except where the argument is identical to the lhs.
     complex_tvars = map HsTyVar $ Set.elems $ Set.unions $ map tvarsType $
			filter (/= lhs) $ filter (not . isVar) targs
     isVar (HsTyVar _) = True
     isVar _ = False
     extra_constraint
 	| null complex_tvars = []
 	| otherwise = [(unknownConstraint,complex_tvars)]
     lhs
	| n == tuple_tycon_name (length tvs - 1) =
	   HsTyTuple True (map HsTyVar tvs)
        | otherwise = foldl HsTyApp (HsTyCon (Qual mdl n)) (map HsTyVar tvs)

  -- collect type arguments of constructors
  targsConstrs :: [HsConDecl] -> [HsType]
  targsConstrs = foldr targsConstr []

  targsConstr :: HsConDecl -> [HsType] -> [HsType]
  targsConstr (HsConDecl _ _ _ _ bts _) ts = foldr targsBangType ts bts
  targsConstr (HsRecDecl _ _ _ _ fs _) ts = foldr targsField ts fs

  targsField (HsFieldDecl _ bt _) = targsBangType bt

  targsBangType (HsBangedTy t) ts = t : ts
  targsBangType (HsUnBangedTy t) ts = t : ts

  -- remove documentation comments from a type
  stripDocs :: HsType -> HsType
  stripDocs (HsForAllType n ctxt t) = HsForAllType n ctxt (stripDocs t)
  stripDocs (HsTyFun t1 t2) = HsTyFun (stripDocs t1) (stripDocs t2)
  stripDocs (HsTyTuple boxed ts) = HsTyTuple boxed (map stripDocs ts)
  stripDocs (HsTyApp t1 t2) = HsTyApp (stripDocs t1) (stripDocs t2)
  stripDocs (HsTyDoc t _) = stripDocs t
  stripDocs (HsTyIP n t) = HsTyIP n (stripDocs t)
  stripDocs t = t

  -- collect the type variables occurring free in a type
  tvarsType (HsForAllType (Just tvs) _ t) = foldl (flip Set.delete) (tvarsType t) tvs
  tvarsType (HsForAllType Nothing _ t) = tvarsType t
  tvarsType (HsTyFun t1 t2) = tvarsType t1 `Set.union` tvarsType t2
  tvarsType (HsTyTuple _ ts) = Set.unions (map tvarsType ts)
  tvarsType (HsTyApp t1 t2) = tvarsType t1 `Set.union` tvarsType t2
  tvarsType (HsTyVar tv) = Set.singleton tv
  tvarsType (HsTyCon _) = Set.empty
  tvarsType (HsTyDoc t _) = tvarsType t
  tvarsType (HsTyIP _ t) = tvarsType t

unknownConstraint :: HsQName
unknownConstraint = UnQual (HsTyClsName (HsIdent "???"))

-- -----------------------------------------------------------------------------
-- Build the list of items that will become the documentation, from the
-- export list.  At this point, the list of ExportItems is in terms of
-- original names.

mkExportItems
	:: ModuleMap
	-> Module			-- this module
	-> [HsQName]			-- exported names (orig)
	-> Map HsName HsDecl		-- maps local names to declarations
	-> Map HsName [HsName]		-- sub-map for this module
	-> [HsDecl]			-- decls in the current module
	-> [DocOption]
	-> Maybe [HsExportSpec]
	-> Bool				-- --ignore-all-exports flag
	-> ErrMsgM [ExportItem]

mkExportItems mod_map this_mod exported_names decl_map sub_map decls
	 opts maybe_exps ignore_all_exports
  | isNothing maybe_exps
    || ignore_all_exports
    || OptIgnoreExports `elem` opts
     = everything_local_exported
  | Just specs <- maybe_exps
     = do 
	exps <- mapM lookupExport specs
        return (concat exps)
  where
    everything_local_exported =  -- everything exported
	return (fullContentsOfThisModule this_mod decls)

    lookupExport (HsEVar x)            = declWith x
    lookupExport (HsEAbs t)            = declWith t
    lookupExport (HsEThingAll t)       = declWith t
    lookupExport (HsEThingWith t cs)   = declWith t
    lookupExport (HsEModuleContents m) = fullContentsOf m
    lookupExport (HsEGroup lev doc)    = return [ ExportGroup lev "" doc ]
    lookupExport (HsEDoc doc)          = return [ ExportDoc doc ]
    lookupExport (HsEDocNamed str)
	= do r <- findNamedDoc str decls
	     case r of
		Nothing -> return []
		Just found -> return [ ExportDoc found ]
	
    declWith :: HsQName -> ErrMsgM [ ExportItem ]
    declWith (UnQual _) = return []
    declWith t@(Qual mdl x)
	| Just decl <- findDecl t
	= return [ ExportDecl t (restrictTo subs (extractDecl x mdl decl)) [] ]
	| otherwise
	= return [ ExportNoDecl t t (map (Qual mdl) subs) ]
	-- can't find the decl (it might be from another package), but let's
	-- list the entity anyway.  Later on, the renamer will change the
	-- orig name into the import name, so we get a proper link to
	-- the doc for this entity.
	where 
	      subs = map nameOfQName subs_qnames
	      subs_qnames = filter (`elem` exported_names) all_subs_qnames

	      all_subs_qnames = map (Qual mdl) all_subs

	      all_subs | mdl == this_mod = Map.findWithDefault [] x sub_map
		       | otherwise       = all_subs_of_qname mod_map t

    fullContentsOf m
	| m == this_mod  = return (fullContentsOfThisModule this_mod decls)
	| otherwise = 
	   case Map.lookup m mod_map of
	     Just iface
		| OptHide `elem` iface_options iface
			-> return (iface_orig_exports iface)
		| otherwise -> return [ ExportModule m ]
	     Nothing -> return [] -- already emitted a warning in exportedNames

    findDecl :: HsQName -> Maybe HsDecl
    findDecl (UnQual _)
	= Nothing	-- must be a name we couldn't resolve
    findDecl (Qual m n)
	| m == this_mod  = Map.lookup n decl_map
	| otherwise = 
	   case Map.lookup m mod_map of
		Just iface -> Map.lookup n (iface_decls iface)
		Nothing -> Nothing

fullContentsOfThisModule :: Module -> [HsDecl] -> [ExportItem]
fullContentsOfThisModule mdl decls = 
  map mkExportItem (filter keepDecl decls)
  where mkExportItem (HsDocGroup _ lev doc) = ExportGroup lev "" doc
	mkExportItem decl = ExportDecl (Qual mdl x) decl []
	     where Just x = declMainBinder decl

keepDecl :: HsDecl -> Bool
keepDecl HsTypeSig{}       = True
keepDecl HsTypeDecl{}      = True
keepDecl HsNewTypeDecl{}   = True
keepDecl HsDataDecl{}      = True
keepDecl HsClassDecl{}     = True
keepDecl HsDocGroup{}	   = True
keepDecl HsForeignImport{} = True
keepDecl _ = False

-- Sometimes the declaration we want to export is not the "main" declaration:
-- it might be an individual record selector or a class method.  In these
-- cases we have to extract the required declaration (and somehow cobble 
-- together a type signature for it...)

extractDecl :: HsName -> Module -> HsDecl -> HsDecl
extractDecl name mdl decl
  | Just n <- declMainBinder decl, n == name  =  decl
  | otherwise  =  
	case decl of
	    HsClassDecl _ _ n tvs _ decls _ ->
		case [ d | d@HsTypeSig{} <- decls, 
			   declMainBinder d == Just name ] of
		  [d0] -> extractClassDecl n mdl tvs d0
		  _ -> error "internal: extractDecl"

	    HsDataDecl _ _ t tvs cons _ _ ->
		extractRecSel name mdl t tvs cons

	    HsNewTypeDecl _ _ t tvs con _ _ ->
		extractRecSel name mdl t tvs [con]

	    _ -> error ("extractDecl: "  ++ show decl)

extractClassDecl :: HsName -> Module -> [HsName] -> HsDecl -> HsDecl
extractClassDecl c mdl tvs0 (HsTypeSig loc [n] ty doc)
 = case ty of
 	HsForAllType tvs ctxt' ty' -> 
	  HsTypeSig loc [n] (HsForAllType tvs (ctxt ++ ctxt') ty') doc
	_ -> 
	  HsTypeSig loc [n] (HsForAllType Nothing ctxt ty) doc
 where
  ctxt = [HsAssump (Qual mdl c, map HsTyVar tvs0)]
extractClassDecl _ _ _ d =
     error $ "Main.extractClassDecl: unexpected decl: " ++ show d

extractRecSel :: HsName -> Module -> HsName -> [HsName] -> [HsConDecl]
              -> HsDecl
extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
extractRecSel nm mdl t tvs (d@(HsConDecl{}):rest) =
    extractRecSel nm mdl t tvs rest
extractRecSel nm mdl t tvs (HsRecDecl loc _ _tvs _ fields _mb_doc : rest)
  | (HsFieldDecl ns ty mb_doc : _) <- matching_fields
	= HsTypeSig loc [nm] (HsTyFun data_ty (unbang ty)) mb_doc
  | otherwise = extractRecSel nm mdl t tvs rest
  where
	matching_fields = [ f | f@(HsFieldDecl ns ty mb_doc) <- fields,
			        nm `elem` ns ]

	data_ty = foldl HsTyApp (HsTyCon (Qual mdl t)) (map HsTyVar tvs)

-- -----------------------------------------------------------------------------
-- Pruning

pruneExportItems :: [ExportItem] -> [ExportItem]
pruneExportItems items = filter has_doc items
  where has_doc (ExportDecl _ d _) = isJust (declDoc d)
	has_doc _ = True

-- -----------------------------------------------------------------------------
-- Make a sub-name map for this module

mkSubNames :: [HsDecl] -> Map HsName [HsName]
mkSubNames decls = 
  Map.fromList [ (n, subs) | d <- decls, 
		             Just n <- [declMainBinder d],
			     subs@(_:_) <- [declSubBinders d] ]

-- -----------------------------------------------------------------------------
-- Gather a list of original names exported from this module

exportedNames :: Module -> ModuleMap -> [HsName]
	-> Map HsQName HsQName
	-> Map HsName [HsName]
	-> Maybe [HsExportSpec]
	-> [DocOption]
	-> ErrMsgM ([HsQName], [HsQName])

exportedNames mdl mod_map local_names orig_env sub_map maybe_exps opts
  | Nothing <- maybe_exps 	    
	= return all_local_names_pr
  | OptIgnoreExports `elem` opts
	= return all_local_names_pr
  | Just expspecs <- maybe_exps
	= do all_names <- mapM extract expspecs
	     all_vis_names <- mapM extract_vis expspecs
	     return (concat all_names, concat all_vis_names)
 where
  all_local_names = map (Qual mdl) local_names
  all_local_names_pr = (all_local_names,all_local_names)

  in_scope = Set.fromList (Map.elems orig_env)

  extract e = 
   case e of
    HsEVar x -> return [x]
    HsEAbs t -> return [t]
    HsEThingAll t@(Qual m x) ->
	 return (t : filter (`Set.member` in_scope) (map (Qual m) all_subs))
	 where
	      all_subs | m == mdl  = Map.findWithDefault [] x sub_map
		       | otherwise = all_subs_of_qname mod_map t

    HsEThingWith t cs -> return (t : cs)
    HsEModuleContents m
	| m == mdl  -> return (map (Qual mdl) local_names)
	| otherwise ->
	  case Map.lookup m mod_map of
	    Just iface -> 
		return (filter (`Set.member` in_scope) (Map.elems (iface_env iface)))
	    Nothing    -> 
		do tell (exportModuleMissingErr mdl m)
		   return []
    _ -> return []

  -- Just the names that will be visible in the documentation
  -- (ie. omit names exported via a 'module M' export, if we are just
  -- going to cross-reference the module).
  extract_vis e = 
   case e of
    HsEModuleContents m
	| m == mdl  -> return (map (Qual mdl) local_names)
	| otherwise ->
	  case Map.lookup m mod_map of
	    Just iface
		| OptHide `elem` iface_options iface ->
		    return (filter (`Set.member` in_scope) (Map.elems (iface_env iface)))
		| otherwise -> return []
	    Nothing
		-> return []  -- we already emitted a warning above

    -- remaining cases: we have to catch names which are reexported from
    -- here, but for which we have no documentation, perhaps because they
    -- are from another package.  We have to do this by looking for
    -- the declaration in the other module.
    _ -> do xs <- extract e
	    return (filter is_documented_here xs)

  is_documented_here (UnQual _) = False
  is_documented_here (Qual m n)
    | m == mdl  = True -- well, it's not documented anywhere else!
    | otherwise =
	case Map.lookup m mod_map of
	  Nothing -> False
	  Just iface -> isJust (Map.lookup n (iface_decls iface))

exportModuleMissingErr this mdl 
  = ["Warning: in export list of " ++ show this
	 ++ ": module not found: " ++ show mdl]

-- for a given entity, find all the names it "owns" (ie. all the
-- constructors and field names of a tycon, or all the methods of a
-- class).
all_subs_of_qname :: ModuleMap -> HsQName -> [HsName]
all_subs_of_qname mod_map (Qual mdl nm) =
  case Map.lookup mdl mod_map of
	Just iface -> Map.findWithDefault [] nm (iface_sub iface)
	Nothing    -> []
all_subs_of_qname _ n@(UnQual _) =
    error $ "Main.all_subs_of_qname: unexpected unqual'd name:" ++ show n

-- ----------------------------------------------------------------------------
-- Building name environments

-- The orig env maps names in the current source file to
-- fully-qualified "original" names.

buildOrigEnv :: Module -> Bool -> ModuleMap -> [HsImportDecl]
   -> ErrMsgM (Map HsQName HsQName)
buildOrigEnv this_mdl verbose mod_map imp_decls
  = do maps <- mapM build imp_decls
       return (Map.unions (reverse maps))
  where
  build imp_decl@(HsImportDecl _ mdl qual maybe_as _)
    = case Map.lookup mdl mod_map of
       Nothing -> do 
	  when verbose $
	     -- only emit missing module messages when -v is on.  Otherwise
  	     -- we get a ton of spurious messages about missing "Prelude".
	     tell ["Warning: " ++ show this_mdl
		   ++ ": imported module not found: " ++ show mdl]
	  return Map.empty
       Just iface -> 
	  return (Map.fromList (concat (map orig_map 
			                    (processImportDecl mod_map imp_decl))))
        where

	-- bring both qualified and unqualified names into scope, unless
	-- the import was 'qualified'.
	orig_map (nm,qnm)
	  | qual      = [ (Qual qual_module nm, qnm) ]
	  | otherwise = [ (Qual qual_module nm, qnm), (UnQual nm, qnm) ]

        qual_module
	  | Just m <- maybe_as = m
	  | otherwise          = mdl


processImportDecl :: ModuleMap -> HsImportDecl -> [(HsName,HsQName)]
processImportDecl mod_map (HsImportDecl _ mdl is_qualified maybe_as imp_specs)
    = case Map.lookup mdl mod_map of
       Nothing    -> []
       Just iface -> imported_names
        where
	 env = iface_env iface
	 sub = iface_sub iface

 	 all_names = Map.toAscList env

	 imported_names :: [(HsName,HsQName)]
	 imported_names
	   = case imp_specs of
		Nothing          -> all_names
	        Just (False,specs) -> [ (n,qnm) | (n,qnm) <- all_names,
						n `elem` names specs False ]
	        Just (True, specs) -> [ (n,qnm) | (n,qnm) <- all_names,
						n `notElem` names specs True ]
	      where
		names specs is_hiding 
		  = concat (map (spec_names is_hiding) specs)

	-- when hiding, a conid refers to both the constructor and
	-- the type/class constructor.
	 spec_names _hid (HsIVar v)		= [v]
	 spec_names True  (HsIAbs (HsTyClsName i))
		 = [HsTyClsName i, HsVarName i]
	 spec_names False (HsIAbs v)		= [v]
	 spec_names _hid (HsIThingAll v)	= v : sub_names v
	 spec_names _hid (HsIThingWith v xs) 	= v : xs

	 sub_names :: HsName -> [HsName]
	 sub_names nm =
	  case Map.lookup nm env of
	    Just qnm -> filter (`Map.member` env) (all_subs_of_qname mod_map qnm)
	    _ -> []

-- -----------------------------------------------------------------------------

-- | Build a mapping which for each original name, points to the "best"
-- place to link to in the documentation.  For the definition of
-- "best", we use "the module nearest the bottom of the dependency
-- graph which exports this name", not including hidden modules.  When
-- there are multiple choices, we pick a random one.
-- 
-- The interfaces are passed in in topologically sorted order, but we start
-- by reversing the list so we can do a foldl.
-- 
buildGlobalDocEnv :: [Interface] -> Map HsQName HsQName
buildGlobalDocEnv ifaces
 = foldl upd Map.empty (reverse ifaces)
 where
  upd old_env iface
     | OptHide `elem` iface_options iface
     = old_env
     | OptNotHome `elem` iface_options iface
     = foldl' keep_old old_env exported_names
     | otherwise
     = foldl' keep_new old_env exported_names
     where
	mdl = iface_module iface
	exported_names = filter not_reexported (Map.elems (iface_env iface))

	not_reexported (Qual _ n) = n `notElem` iface_reexported iface
	not_reexported (UnQual n) = n `notElem` iface_reexported iface
		-- UnQual probably shouldn't happen

	keep_old env qnm = Map.insertWith (\new old -> old) 
				qnm (Qual mdl nm) env
		where nm = nameOfQName qnm
	keep_new env qnm = Map.insert qnm (Qual mdl nm) env 
		where nm = nameOfQName qnm

builtinDocEnv = Map.fromList (map (\a -> (a,a)) builtinNames)

-- These names cannot be explicitly exported, so we need to treat
-- them specially.
builtinNames = 
     [unit_tycon_qname, fun_tycon_qname, list_tycon_qname,
      unit_con_name, nil_con_name]	

-- -----------------------------------------------------------------------------
-- Expand multiple type signatures

expandDecl :: HsDecl -> [HsDecl]
expandDecl (HsTypeSig loc fs qt doc) = [ HsTypeSig loc [f] qt doc | f <- fs ]
expandDecl (HsClassDecl loc ctxt n tvs fds decls doc)
  = [ HsClassDecl loc ctxt n tvs fds (concat (map expandDecl decls)) doc ]
expandDecl d = [ d ]

-----------------------------------------------------------------------------
-- Collecting documentation and attach it to the right declarations

collectDoc :: [HsDecl] -> [HsDecl]
collectDoc decls = collect Nothing DocEmpty decls

collect :: Maybe HsDecl -> GenDoc [HsQName] -> [HsDecl] -> [HsDecl]
collect d doc_so_far [] = 
   case d of
	Nothing -> []
	Just d0  -> finishedDoc d0 doc_so_far []

collect d doc_so_far (decl:ds) = 
   case decl of
      HsDocCommentNext _ str -> 
	case d of
	   Nothing -> collect d (docAppend doc_so_far str) ds
	   Just d0 -> finishedDoc d0 doc_so_far (collect Nothing str ds)

      HsDocCommentPrev _ str -> collect d (docAppend doc_so_far str) ds

      _other -> 
	let decl' = collectInDecl decl in
	case d of
	    Nothing -> collect (Just decl') doc_so_far ds
	    Just d0 -> finishedDoc d0 doc_so_far
                           (collect (Just decl') DocEmpty ds)

finishedDoc :: HsDecl -> GenDoc [HsQName] -> [HsDecl] -> [HsDecl]
finishedDoc d DocEmpty rest = d : rest
finishedDoc d doc rest = d' : rest
 where d' = 
	 case d of
	  HsTypeDecl loc n ns ty _ -> 
		HsTypeDecl loc n ns ty (Just doc)
	  HsDataDecl loc ctxt n ns cons drv _ -> 
		HsDataDecl loc ctxt n ns cons drv (Just doc)
	  HsNewTypeDecl loc ctxt n ns con drv _ -> 
		HsNewTypeDecl loc ctxt n ns con drv (Just doc)
	  HsClassDecl loc ctxt n tvs fds meths _ -> 
		HsClassDecl loc ctxt n tvs fds meths (Just doc)
	  HsTypeSig loc ns ty _ -> 
		HsTypeSig loc ns ty (Just doc)
	  HsForeignImport loc cc sf str n ty _ ->
		HsForeignImport loc cc sf str n ty (Just doc)
	  _other -> d

collectInDecl :: HsDecl -> HsDecl
collectInDecl (HsClassDecl loc ctxt n tvs fds meths doc)
  = HsClassDecl loc ctxt n tvs fds (collect Nothing DocEmpty meths) doc
collectInDecl decl
  = decl

-- -----------------------------------------------------------------------------
-- Named documentation

findNamedDoc :: String -> [HsDecl] -> ErrMsgM (Maybe Doc)
findNamedDoc name decls = search decls
	where search [] = do
		tell ["Cannot find documentation for: $" ++ name]
		return Nothing
	      search (HsDocCommentNamed _ name' doc : rest) 
			| name == name' = return (Just doc)
		   	| otherwise = search rest
	      search (_other_decl : rest) = search rest

-- -----------------------------------------------------------------------------
-- Haddock options embedded in the source file

processOptions :: String -> ErrMsgM [DocOption]
processOptions str = do
  case break (== ',') str of
    (this, ',':rest) -> do
	opt <- parseOption this
	opts <- processOptions rest
	return (maybeToList opt ++ opts)
    (this, _)
	| all isSpace this -> return []
	| otherwise -> do opt <- parseOption this; return (maybeToList opt)

parseOption :: String -> ErrMsgM (Maybe DocOption)
parseOption "hide" = return (Just OptHide)
parseOption "prune" = return (Just OptPrune)
parseOption "ignore-exports" = return (Just OptIgnoreExports)
parseOption "not-home" = return (Just OptNotHome)
parseOption other = do tell ["Unrecognised option: " ++ other]; return Nothing

-- -----------------------------------------------------------------------------
-- Topologically sort the modules

sortModules :: [(HsModule,FilePath)] -> IO [(HsModule,FilePath)]
sortModules mdls = mapM for_each_scc sccs
  where
	sccs = stronglyConnComp edges

	edges :: [((HsModule,FilePath), Module, [Module])]
	edges = [ ((hsmod,file), mdl, get_imps impdecls)
		| (hsmod@(HsModule _ mdl _ impdecls _ _ _ _), file) <- mdls
		]

        get_imps impdecls  = [ imp | HsImportDecl _ imp _ _ _ <- impdecls  ]

	get_mods hsmodules = [ mdl | HsModule _ mdl _ _ _ _ _ _ <- hsmodules ]

	for_each_scc (AcyclicSCC hsmodule) = return hsmodule
	for_each_scc (CyclicSCC  hsmodules) = 
	   dieMsg ("modules are recursive: " ++
		   unwords (map show (get_mods (map fst hsmodules))))

-- -----------------------------------------------------------------------------
-- Collect instances and attach them to declarations

attachInstances :: [Interface] -> [Interface]
attachInstances mod_ifaces
  = map attach mod_ifaces
  where
  inst_map = fmap (sortImage instHead) $ collectInstances mod_ifaces

  attach iface = iface{ iface_orig_exports = new_exports }
   where
	new_exports = map attach_export (iface_orig_exports iface)

	attach_export (ExportDecl nm decl _) =
	    ExportDecl nm decl (case Map.lookup nm inst_map of
				  Nothing -> []
				  Just instheads -> instheads)
	attach_export other_export =
	    other_export

collectInstances 
   :: [Interface]
   -> Map HsQName [InstHead]  -- maps class/type names to instances

collectInstances ifaces
  = Map.fromListWith (flip (++)) ty_inst_pairs `Map.union`
    Map.fromListWith (flip (++)) class_inst_pairs
  where
    all_instances = concat (map iface_insts ifaces)

    class_inst_pairs = [ (cls, [(ctxt,(cls,args))])
		       | HsInstDecl _ ctxt (cls,args) _ <- all_instances ]
			
    ty_inst_pairs = [ (nm, [(ctxt,(cls,args))])
		    | HsInstDecl _ ctxt (cls,args) _ <- all_instances,
		      nm <- nub (concat (map freeTyCons args))
		    ]

-- simplified type for sorting types, ignoring qualification (not visible
-- in Haddock output) and unifying special tycons with normal ones.
data SimpleType = SimpleType HsName [SimpleType] deriving (Eq,Ord)

-- Sort key for instances:
--	arities of arguments, to place higher-kind instances
--	name of class
--	type arguments
instHead :: (HsContext,(HsQName,[HsType])) -> ([Int],HsName,[SimpleType])
instHead (ctxt,(cls,args))
  = (map argCount args, nameOfQName cls, map simplify args)
  where
    argCount (HsTyApp t _) = argCount t + 1
    argCount _ = 0

    simplify (HsForAllType tvs ctxt t) = simplify t
    simplify (HsTyFun t1 t2) =
	SimpleType fun_tycon_name [simplify t1, simplify t2]
    simplify (HsTyTuple b ts) =
	SimpleType (tuple_tycon_name (length ts - 1)) (map simplify ts)
    simplify (HsTyApp t1 t2) = SimpleType s (args ++ [simplify t2])
	where (SimpleType s args) = simplify t1
    simplify (HsTyVar v) = SimpleType v []
    simplify (HsTyCon n) = SimpleType (nameOfQName n) []
    simplify (HsTyDoc t _) = simplify t
    simplify (HsTyIP n t) = simplify t

-- sortImage f = sortBy (\x y -> compare (f x) (f y))
sortImage :: Ord b => (a -> b) -> [a] -> [a]
sortImage f xs = map snd $ sortBy cmp_fst [(f x, x) | x <- xs]
 where cmp_fst (x,_) (y,_) = compare x y

-- -----------------------------------------------------------------------------
-- The interface file format.
-- This has to read interfaces up to Haddock 0.6 (without the short
-- document annotations), and interfaces afterwards, so we use the
-- FormatVersion hack to work out which one the interface file contains.

thisFormatVersion :: FormatVersion
thisFormatVersion = mkFormatVersion 2

-- | How we store interfaces.  Not everything is stored.
type StoredInterface2 =
   (Module,Maybe Doc,Maybe String,Bool,[(HsName,Module)], [(HsName,[HsName])])

-- | How we store interfaces.  Not everything is stored.
type StoredInterface1 =
   (Module,Maybe Doc,Maybe String,Bool,[(HsName,HsQName)],[(HsName,HsQName)],
      [(HsName,[HsName])])

-- | How we used to store interfaces.
type NullVersionStoredInterface = 
   (Module,Maybe String,Bool,[(HsName,HsQName)],[(HsName,HsQName)],
      [(HsName,[HsName])])

dumpInterfaces :: [Interface] -> Map HsQName HsQName -> FilePath -> IO ()
dumpInterfaces interfaces global_doc_env fileName =
   do
      let
         preparedInterfaces :: [StoredInterface2]
         preparedInterfaces = map from_interface interfaces

      bh <- openBinMem 100000
      put_ bh thisFormatVersion
      put_ bh preparedInterfaces
      putDocEnv bh global_doc_env
      writeBinMem bh fileName


readIface :: FilePath -> IO ([Interface], Map HsQName HsQName)
readIface fileName = do
   bh <- readBinMem fileName
   formatVersion <- get bh
   case formatVersion of
     v | v == thisFormatVersion -> do
            (stuff :: [StoredInterface2]) <- get bh
	    doc_env <- getDocEnv bh
            return (map to_interface2 stuff, doc_env)
     v | v == mkFormatVersion 1 -> do
            (stuff :: [StoredInterface1]) <- get bh
            return (map to_interface1 stuff, Map.empty)
     v | v == nullFormatVersion -> do
            (stuff :: [NullVersionStoredInterface]) <- get bh
            return (map nullVersion_to_interface stuff, Map.empty)
     otherwise -> do
            noDieMsg (
               "Warning: The interface file " ++ show fileName 
                  ++ " could not be read.\n"
                  ++ "Maybe it's from a later version of Haddock?\n")
            return ([], Map.empty)

from_interface :: Interface -> StoredInterface2
from_interface iface =
   (  iface_module iface,
      toDescription iface,iface_package iface,
      OptHide `elem` iface_options iface,
      [(n,mdl) | (n,Qual mdl n') <- Map.toAscList (iface_env iface),
		 if n /= n' then error "help!" else True], 
      Map.toAscList (iface_sub iface)
      )

getDocEnv :: BinHandle -> IO (Map HsQName HsQName)
getDocEnv bh = do
   doc_env_list <- get bh
   return (Map.fromList [(Qual mdl1 nm,Qual mdl2 nm) | 
			 (mdl1,nm,mdl2) <- doc_env_list])

putDocEnv :: BinHandle -> Map HsQName HsQName -> IO ()
putDocEnv bh env = do
   let doc_env_list = 
	 [(mdl1,nm,mdl2) | (Qual mdl1 nm, Qual mdl2 _) <- Map.toAscList env]
   put_ bh doc_env_list
  

to_interface1 :: StoredInterface1 -> Interface
to_interface1 (mdl,descriptionOpt,package, hide, env, _, sub) = 
   Interface { 
      iface_module	 = mdl,
      iface_filename     = "",
      iface_orig_filename= "",
      iface_package      = package,
      iface_env          = Map.fromList env,
      iface_sub          = Map.fromList sub,
      iface_reexported   = [],
      iface_exports      = [],
      iface_orig_exports = [],
      iface_insts        = [],
      iface_decls        = Map.empty,
      iface_info         = toModuleInfo descriptionOpt,
      iface_doc          = Nothing,
      iface_options      = if hide then [OptHide] else []
      }

to_interface2 :: StoredInterface2 -> Interface
to_interface2 (mdl,descriptionOpt,package, hide, env, sub) =
   Interface { 
      iface_module	 = mdl,
      iface_filename     = "",
      iface_orig_filename= "",
      iface_package      = package,
      iface_env          = 
	Map.fromList [(n,Qual mdl n) | (n,mdl) <- env],
      iface_sub          = Map.fromList sub,
      iface_reexported   = [],
      iface_exports      = [],
      iface_orig_exports = [],
      iface_insts        = [],
      iface_decls        = Map.empty,
      iface_info         = toModuleInfo descriptionOpt,
      iface_doc          = Nothing,
      iface_options      = if hide then [OptHide] else []
      }

nullVersion_to_interface :: NullVersionStoredInterface -> Interface
nullVersion_to_interface (mdl, package, hide, env, reexported, sub) = 
   Interface { 
      iface_module	 = mdl,
      iface_filename     = "",
      iface_orig_filename= "",
      iface_package      = package,
      iface_env          = Map.fromList env,
      iface_sub          = Map.fromList sub,
      iface_reexported   = [],
      iface_exports      = [],
      iface_orig_exports = [],
      iface_insts        = [],
      iface_decls        = Map.empty,
      iface_info         = emptyModuleInfo,
      iface_doc          = Nothing,
      iface_options      = if hide then [OptHide] else []
      }

toModuleInfo :: Maybe Doc -> ModuleInfo
toModuleInfo descriptionOpt = 
   emptyModuleInfo {description = descriptionOpt}


 
-- -----------------------------------------------------------------------------
-- A monad which collects error messages

type ErrMsg = String
type ErrMsgM a = Writer [ErrMsg] a