aboutsummaryrefslogtreecommitdiff
path: root/src/Main.hs
blob: 5c0d01740e901c6420faeeb0a99497ef75f1b3f5 (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
{-# OPTIONS_GHC -Wwarn #-}
{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Main
-- Copyright   :  (c) Simon Marlow 2003-2006,
--                    David Waern  2006-2010
-- License     :  BSD-like
--
-- Maintainer  :  haddock@projects.haskell.org
-- Stability   :  experimental
-- Portability :  portable
--
-- Haddock - A Haskell Documentation Tool
--
-- Program entry point and top-level code.
-----------------------------------------------------------------------------
module Main (main, createInterfaces') where


import Haddock.Backends.Xhtml
import Haddock.Backends.Xhtml.Themes (getThemes)
import Haddock.Backends.LaTeX
import Haddock.Backends.Hoogle
import Haddock.Interface
import Haddock.Lex
import Haddock.Parse
import Haddock.Types
import Haddock.Version
import Haddock.InterfaceFile
import Haddock.Options
import Haddock.Utils
import Haddock.GhcUtils

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

#if defined(mingw32_HOST_OS)
import Foreign
import Foreign.C
import Data.Int
#endif

#ifdef IN_GHC_TREE
import System.FilePath
#else
import GHC.Paths
import Paths_haddock
#endif

import GHC hiding (flags, verbosity)
import Config
import DynFlags hiding (flags, verbosity)
import Panic (handleGhcException)


--------------------------------------------------------------------------------
-- * Exception handling
--------------------------------------------------------------------------------


handleTopExceptions :: IO a -> IO a
handleTopExceptions =
  handleNormalExceptions . handleHaddockExceptions . handleGhcExceptions


-- | Either returns normally or throws an ExitCode exception;
-- all other exceptions are turned into exit exceptions.
handleNormalExceptions :: IO a -> IO a
handleNormalExceptions inner =
  (inner `onException` hFlush stdout)
  `catches`
  [  Handler (\(code :: ExitCode) -> exitWith code)
  ,  Handler (\(StackOverflow) -> do
        putStrLn "stack overflow: use -g +RTS -K<size> to increase it"
        exitFailure)
  ,  Handler (\(ex :: SomeException) -> do
        putStrLn ("haddock: internal Haddock or GHC error: " ++ show ex)
        exitFailure)
  ]


handleHaddockExceptions :: IO a -> IO a
handleHaddockExceptions inner =
  catches inner [Handler handler]
  where
    handler (e::HaddockException) = do
      putStrLn $ "haddock: " ++ show e
      exitFailure


handleGhcExceptions :: IO a -> IO a
handleGhcExceptions =
  -- error messages propagated as exceptions
  handleGhcException $ \e -> do
    hFlush stdout
    case e of
      PhaseFailed _ code -> exitWith code
#if ! MIN_VERSION_ghc(6,13,0)
      Interrupted -> exitFailure
#endif
      _ -> do
        print (e :: GhcException)
        exitFailure


-------------------------------------------------------------------------------
-- * Top level
-------------------------------------------------------------------------------


-- | Create 'Interface' structures from a given list of Haddock command-line
-- flags and file or module names (as accepted by 'haddock' executable).  Flags
-- that control documentation generation or show help or version information
-- are ignored.
--
-- This is a more high-level alternative to 'createInterfaces'.
createInterfaces'
  :: [String]       -- ^ A list of command-line flags and file or module names
  -> IO [Interface] -- ^ Resulting list of interfaces
createInterfaces' args = do
  (flags, fileArgs) <- parseHaddockOpts args
  (_, ifaces) <- readPackagesAndCreateInterfaces flags fileArgs
  return ifaces


readPackagesAndCreateInterfaces :: [Flag] -> [String] -> IO ([(InterfaceFile, FilePath)], [Interface])
readPackagesAndCreateInterfaces flags fileArgs = do
  libDir <- getGhcLibDir flags

  -- Catches all GHC source errors, then prints and re-throws them.
  let handleSrcErrors action' = flip handleSourceError action' $ \err -> do
        printExceptionAndWarnings err
        liftIO exitFailure

  -- Initialize GHC.
  withGhc libDir (ghcFlags flags) $ \_ -> handleSrcErrors $ do

    -- Get packages supplied with --read-interface.
    packages <- readInterfaceFiles nameCacheFromGhc (ifacePairs flags)

    -- Create the interfaces -- this is the core part of Haddock.
    (ifaces, homeLinks) <- createInterfaces (verbosity flags) fileArgs flags
                                            (map fst packages)

    -- Dump an "interface file" (.haddock file), if requested.
    liftIO $ case optDumpInterfaceFile flags of
      Just f -> dumpInterfaceFile f (map toInstalledIface ifaces) homeLinks
      Nothing -> return ()

    return (packages, ifaces)


main :: IO ()
main = handleTopExceptions $ do

  -- Parse command-line flags and handle some of them initially.
  args <- getArgs
  (flags, fileArgs) <- parseHaddockOpts args
  shortcutFlags flags

  if not (null fileArgs)
    then do
      (packages, ifaces) <- readPackagesAndCreateInterfaces flags fileArgs

      -- Render the interfaces.
      renderStep flags packages ifaces

    else do
      when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $
        throwE "No input file(s)."

      -- Get packages supplied with --read-interface.
      packages <- readInterfaceFiles freshNameCache (ifacePairs flags)

      -- Render even though there are no input files (usually contents/index).
      renderStep flags packages []


renderStep :: [Flag] -> [(InterfaceFile, FilePath)] -> [Interface] -> IO ()
renderStep flags packages interfaces = do
  updateHTMLXRefs packages
  let ifaceFiles      = map fst packages
      installedIfaces = concatMap ifInstalledIfaces ifaceFiles
  render flags interfaces installedIfaces


-- | Render the interfaces with whatever backend is specified in the flags.
render :: [Flag] -> [Interface] -> [InstalledInterface] -> IO ()
render flags ifaces installedIfaces = do

  let
    title                = fromMaybe "" (optTitle flags)
    unicode              = Flag_UseUnicode `elem` flags
    opt_source_urls      = optSourceUrls     flags
    opt_wiki_urls        = optWikiUrls       flags
    opt_contents_url     = optContentsUrl    flags
    opt_index_url        = optIndexUrl       flags
    odir                 = outputDir         flags
    opt_latex_style      = optLaTeXStyle     flags

    visibleIfaces    = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ]

    -- /All/ visible interfaces including external package modules.
    allIfaces        = map toInstalledIface ifaces ++ installedIfaces
    allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ]

    packageMod       = ifaceMod (head ifaces)
    packageStr       = Just (modulePackageString packageMod)
    (pkgName,pkgVer) = modulePackageInfo packageMod

  libDir   <- getHaddockLibDir flags
  prologue <- getPrologue flags
  themes <- getThemes libDir flags >>= either bye return

  when (Flag_GenIndex `elem` flags) $ do
    ppHtmlIndex odir title packageStr
                themes opt_contents_url opt_source_urls opt_wiki_urls
                allVisibleIfaces
    copyHtmlBits odir libDir themes

  when (Flag_GenContents `elem` flags) $ do
    ppHtmlContents odir title packageStr
                   themes opt_index_url opt_source_urls opt_wiki_urls
                   allVisibleIfaces True prologue
    copyHtmlBits odir libDir themes

  when (Flag_Html `elem` flags) $ do
    ppHtml title packageStr visibleIfaces odir
                prologue
                themes opt_source_urls opt_wiki_urls
                opt_contents_url opt_index_url unicode
    copyHtmlBits odir libDir themes

  when (Flag_Hoogle `elem` flags) $ do
    let pkgName2 = if pkgName == "main" && title /= [] then title else pkgName
    ppHoogle pkgName2 pkgVer title prologue visibleIfaces odir

  when (Flag_LaTeX `elem` flags) $ do
    ppLaTeX title packageStr visibleIfaces odir prologue opt_latex_style
                  libDir

-------------------------------------------------------------------------------
-- * Reading and dumping interface files
-------------------------------------------------------------------------------


readInterfaceFiles :: MonadIO m =>
                      NameCacheAccessor m
                   -> [(FilePath, FilePath)] ->
                      m [(InterfaceFile, FilePath)]
readInterfaceFiles name_cache_accessor pairs = do
  mbPackages <- mapM tryReadIface pairs
  return (catMaybes mbPackages)
  where
    -- try to read an interface, warn if we can't
    tryReadIface (html, iface) = do
      eIface <- readInterfaceFile name_cache_accessor iface
      case eIface of
        Left err -> liftIO $ do
          putStrLn ("Warning: Cannot read " ++ iface ++ ":")
          putStrLn ("   " ++ err)
          putStrLn "Skipping this interface."
          return Nothing
        Right f -> return $ Just (f, html)


dumpInterfaceFile :: FilePath -> [InstalledInterface] -> LinkEnv -> IO ()
dumpInterfaceFile path ifaces homeLinks = writeInterfaceFile path ifaceFile
  where
    ifaceFile = InterfaceFile {
        ifInstalledIfaces = ifaces,
        ifLinkEnv         = homeLinks
      }


-------------------------------------------------------------------------------
-- * Creating a GHC session
-------------------------------------------------------------------------------


-- | Start a GHC session with the -haddock flag set. Also turn off
-- compilation and linking. Then run the given 'Ghc' action.
withGhc :: String -> [String] -> (DynFlags -> Ghc a) -> IO a
withGhc libDir flags ghcActs = do
  -- TODO: handle warnings?
  (restFlags, _) <- parseStaticFlags (map noLoc flags)
  runGhc (Just libDir) $ do
    dynflags  <- getSessionDynFlags
    let dynflags' = dopt_set dynflags Opt_Haddock
    let dynflags'' = dynflags' {
        hscTarget = HscNothing,
        ghcMode   = CompManager,
        ghcLink   = NoLink
      }
    dynflags''' <- parseGhcFlags dynflags'' restFlags flags
    defaultCleanupHandler dynflags''' $ do
        -- ignore the following return-value, which is a list of packages
        -- that may need to be re-linked: Haddock doesn't do any
        -- dynamic or static linking at all!
        _ <- setSessionDynFlags dynflags'''
        ghcActs dynflags'''
  where
    parseGhcFlags :: Monad m => DynFlags -> [Located String]
                  -> [String] -> m DynFlags
    parseGhcFlags dynflags flags_ origFlags = do
      -- TODO: handle warnings?
      (dynflags', rest, _) <- parseDynamicFlags dynflags flags_
      if not (null rest)
        then throwE ("Couldn't parse GHC options: " ++ unwords origFlags)
        else return dynflags'


-------------------------------------------------------------------------------
-- * Misc
-------------------------------------------------------------------------------


getHaddockLibDir :: [Flag] -> IO String
getHaddockLibDir flags =
  case [str | Flag_Lib str <- flags] of
    [] ->
#ifdef IN_GHC_TREE
      getInTreeLibDir
#else
      getDataDir -- provided by Cabal
#endif
    fs -> return (last fs)


getGhcLibDir :: [Flag] -> IO String
getGhcLibDir flags =
  case [ dir | Flag_GhcLibDir dir <- flags ] of
    [] ->
#ifdef IN_GHC_TREE
      getInTreeLibDir
#else
      return libdir -- from GHC.Paths
#endif
    xs -> return $ last xs


shortcutFlags :: [Flag] -> IO ()
shortcutFlags flags = do
  usage <- getUsage

  when (Flag_Help           `elem` flags) (bye usage)
  when (Flag_Version        `elem` flags) byeVersion
  when (Flag_GhcVersion     `elem` flags) byeGhcVersion

  when (Flag_PrintGhcLibDir `elem` flags) $ do
    dir <- getGhcLibDir flags
    bye $ dir ++ "\n"

  when (Flag_UseUnicode `elem` flags && Flag_Html `notElem` flags) $
    throwE "Unicode can only be enabled for HTML output."

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

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

  when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags)
        && Flag_LaTeX `elem` flags) $
    throwE "--latex cannot be used with --gen-index or --gen-contents"
  where
    byeVersion = bye $
      "Haddock version " ++ projectVersion ++ ", (c) Simon Marlow 2006\n"
      ++ "Ported to use the GHC API by David Waern 2006-2008\n"

    byeGhcVersion = bye (cProjectVersion ++ "\n")


updateHTMLXRefs :: [(InterfaceFile, FilePath)] -> IO ()
updateHTMLXRefs packages = writeIORef html_xrefs_ref (Map.fromList mapping)
  where
    mapping = [ (instMod iface, html) | (ifaces, html) <- packages
              , iface <- ifInstalledIfaces ifaces ]


getPrologue :: [Flag] -> IO (Maybe (Doc RdrName))
getPrologue flags =
  case [filename | Flag_Prologue filename <- flags ] of
    [] -> return Nothing
    [filename] -> do
      str <- readFile filename
      case parseParas (tokenise defaultDynFlags str (0,0) {- TODO: real position -}) of
        Nothing -> throwE $ "failed to parse haddock prologue from file: " ++ filename
        Just doc -> return (Just doc)
    _otherwise -> throwE "multiple -p/--prologue options"


#ifdef IN_GHC_TREE

getInTreeLibDir :: IO String
getInTreeLibDir =
      do m <- getExecDir
         case m of
             Nothing -> error "No GhcLibDir found"
#ifdef NEW_GHC_LAYOUT
             Just d -> return (d </> ".." </> "lib")
#else
             Just d -> return (d </> "..")
#endif


getExecDir :: IO (Maybe String)
#if defined(mingw32_HOST_OS)
getExecDir = allocaArray len $ \buf -> do
    ret <- getModuleFileName nullPtr buf len
    if ret == 0
        then return Nothing
        else do s <- peekCString buf
                return (Just (dropFileName s))
  where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.


foreign import stdcall unsafe "GetModuleFileNameA"
  getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
#else
getExecDir = return Nothing
#endif

#endif