aboutsummaryrefslogtreecommitdiff
path: root/src/Main.hs
blob: 8ddea3e97fcb23b9821a186b790584069563962a (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
--
-- Haddock - A Haskell Documentation Tool
--
-- (c) Simon Marlow 2003
-- 
-- Ported to use the GHC API by David Waern during "Summer of Code" 2006
--


module Main (main) where


import Haddock.Packages
import Haddock.Backends.Html
import Haddock.Backends.Hoogle
import Haddock.Interface
import Haddock.Types hiding (NoLink)
import Haddock.Version
import Haddock.InterfaceFile
import Haddock.Exception
import Haddock.Options
import Haddock.GHC
import Haddock.Utils
import Paths_haddock

import Control.Monad
import Control.Exception
import Control.Exception
import Data.Dynamic
import Data.Maybe
import Data.IORef
import qualified Data.Map as Map
import System.IO
import System.Exit
import System.Environment

import GHC
import DynFlags
import Bag
import Util (handleDyn)
import ErrUtils


--------------------------------------------------------------------------------
-- Exception handling
--------------------------------------------------------------------------------


handleTopExceptions = 
  handleNormalExceptions . handleHaddockExceptions . handleGhcExceptions


handleNormalExceptions inner =
  handle (\exception -> do
    hFlush stdout    
    case exception of
      AsyncException StackOverflow -> do
        putStrLn "stack overflow: use -g +RTS -K<size> to increase it"
        exitFailure
      ExitException code -> exitWith code
      _other -> do
        putStrLn ("haddock: internal Haddock or GHC error: " ++ show exception)
        exitFailure
  ) inner


handleHaddockExceptions inner = 
  handleDyn (\(e::HaddockException) -> do
    putStrLn $ "haddock: " ++ (show e)
    exitFailure
  ) inner


handleGhcExceptions inner = 
  -- compilation errors: messages with locations attached
  handleDyn (\dyn -> do
    putStrLn "haddock: Compilation error(s):"
    printBagOfErrors defaultDynFlags (unitBag dyn)
    exitFailure
  ) $

  -- error messages propagated as exceptions
  handleDyn (\dyn -> do
    hFlush stdout
    case dyn of
      PhaseFailed _ code -> exitWith code
      Interrupted -> exitFailure
      _ -> do 
        print (dyn :: GhcException)
        exitFailure
  ) inner


-------------------------------------------------------------------------------
-- Top level
-------------------------------------------------------------------------------


main :: IO ()
main = handleTopExceptions $ do

  -- parse command-line flags and handle some of them initially
  args <- getArgs
  (flags, fileArgs) <- parseHaddockOpts args
  libDir <- handleEasyFlags flags fileArgs
  
  -- initialize GHC
  let ghcFlags = getGhcFlags flags
  (session, dynflags) <- startGhc libDir ghcFlags

  -- get the -use-package packages, load them in GHC,
  -- and try to get the corresponding installed HaddockPackages
  let usePackages = [ pkg | Flag_UsePackage pkg <- flags ]
  pkgInfos <- loadPackages session usePackages
  packages'' <- getHaddockPackages pkgInfos

  -- get packages via --read-interface
  packages' <- getHaddockPackages' (getIfacePairs flags)
  let packages = packages'' ++ packages'

  -- typecheck argument modules using GHC
  modules <- typecheckFiles session fileArgs

  -- combine the link envs of the external packages into one
  let extLinks = combineLinkEnvs packages

  -- create the interfaces -- this is the core part of Haddock
  let (interfaces, homeLinks, messages) = createInterfaces modules extLinks flags
  mapM_ putStrLn messages

  -- render the interfaces
  updateHTMLXRefs packages
  render flags interfaces

  -- last but not least, dump the interface file!
  dumpInterfaceFile (map ghcModule modules) homeLinks flags


-------------------------------------------------------------------------------
-- Rendering
-------------------------------------------------------------------------------


-- | Render the interfaces with whatever backend is specified in the flags 
render :: [Flag] -> [Interface] -> IO ()
render flags interfaces = do
  let
    title = case [str | Flag_Heading str <- flags] of
		[] -> ""
		(t:_) -> t

    maybe_source_urls = (listToMaybe [str | Flag_SourceBaseURL   str <- flags]
                        ,listToMaybe [str | Flag_SourceModuleURL str <- flags]
                        ,listToMaybe [str | Flag_SourceEntityURL str <- flags])

    maybe_wiki_urls = (listToMaybe [str | Flag_WikiBaseURL   str <- flags]
                      ,listToMaybe [str | Flag_WikiModuleURL str <- flags]
                      ,listToMaybe [str | Flag_WikiEntityURL str <- flags])

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

  let 
    visibleMods = [ m | m <- interfaces, OptHide `notElem` (ifaceOptions m) ]
    packageName = (Just . modulePkgStr . ifaceMod . head) visibleMods
 
  when (Flag_GenIndex `elem` flags) $ do
	ppHtmlIndex odir title packageName maybe_html_help_format
                maybe_contents_url maybe_source_urls maybe_wiki_urls
                visibleMods
	copyHtmlBits odir libdir css_file
        
  when (Flag_GenContents `elem` flags && Flag_GenIndex `elem` flags) $ do
    ppHtmlHelpFiles title packageName visibleMods odir maybe_html_help_format []

  when (Flag_GenContents `elem` flags) $ do
	ppHtmlContents odir title packageName maybe_html_help_format
	               maybe_index_url maybe_source_urls maybe_wiki_urls
	               visibleMods True prologue
	copyHtmlBits odir libdir css_file

  when (Flag_Html `elem` flags) $ do
    ppHtml title packageName visibleMods odir
                prologue maybe_html_help_format
                maybe_source_urls maybe_wiki_urls
                maybe_contents_url maybe_index_url
    copyHtmlBits odir libdir css_file


-------------------------------------------------------------------------------
-- Misc
-------------------------------------------------------------------------------


dumpInterfaceFile :: [Module] -> LinkEnv -> [Flag] -> IO ()
dumpInterfaceFile modules homeLinks flags = 
  case [str | Flag_DumpInterface str <- flags] of
    [] -> return ()
    fs -> let filename = last fs in writeInterfaceFile filename ifaceFile
  where 
    ifaceFile = InterfaceFile {
        ifModules = modules,
        ifLinkEnv = homeLinks
      }


handleEasyFlags flags fileArgs = do
  usage <- getUsage

  when (Flag_Help    `elem` flags) (bye usage)
  when (Flag_Version `elem` flags) byeVersion
  when (null fileArgs) (bye usage)

  let ghcLibDir = case [ dir | Flag_GhcLibDir dir <- flags ] of
                    [] -> throwE "no GHC lib dir specified"
                    xs -> last xs

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

  return ghcLibDir
  where
    byeVersion = bye $
      "Haddock version " ++ projectVersion ++ 
      ", (c) Simon Marlow 2003; ported to the GHC-API by David Waern 2006\n"


updateHTMLXRefs :: [HaddockPackage] -> IO ()
updateHTMLXRefs packages = do
  writeIORef html_xrefs_ref (Map.fromList mapping)
  where
    mapping = [ (mod, html) | 
                (HaddockPackage mods _ html) <- packages, mod <- mods ] 


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