aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Haddock/Options.hs60
-rw-r--r--src/Main.hs69
2 files changed, 81 insertions, 48 deletions
diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs
index 89a79a41..1c194166 100644
--- a/src/Haddock/Options.hs
+++ b/src/Haddock/Options.hs
@@ -15,11 +15,20 @@ module Haddock.Options (
parseHaddockOpts,
Flag(..),
getUsage,
+ optTitle,
+ outputDir,
+ optContentsUrl,
+ optIndexUrl,
+ optHtmlHelpFormat,
+ optCssFile,
+ optSourceUrls,
+ optWikiUrls,
ghcFlags,
ifacePairs
) where
+import Data.Maybe
import Haddock.Utils
import Haddock.Types
import System.Console.GetOpt
@@ -43,6 +52,50 @@ parseHaddockOpts params =
throwE (concat errors ++ usage)
+optTitle :: [Flag] -> Maybe String
+optTitle flags =
+ case [str | Flag_Heading str <- flags] of
+ [] -> Nothing
+ (t:_) -> Just t
+
+
+outputDir :: [Flag] -> FilePath
+outputDir flags =
+ case [ path | Flag_OutputDir path <- flags ] of
+ [] -> "."
+ paths -> last paths
+
+
+optContentsUrl :: [Flag] -> Maybe String
+optContentsUrl flags = optLast [ url | Flag_UseContents url <- flags ]
+
+
+optIndexUrl :: [Flag] -> Maybe String
+optIndexUrl flags = optLast [ url | Flag_UseIndex url <- flags ]
+
+
+optHtmlHelpFormat :: [Flag] -> Maybe String
+optHtmlHelpFormat flags = optLast [ hhformat | Flag_HtmlHelp hhformat <- flags ]
+
+
+optCssFile :: [Flag] -> Maybe FilePath
+optCssFile flags = optLast [ str | Flag_CSS str <- flags ]
+
+
+optSourceUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String)
+optSourceUrls flags =
+ (listToMaybe [str | Flag_SourceBaseURL str <- flags]
+ ,listToMaybe [str | Flag_SourceModuleURL str <- flags]
+ ,listToMaybe [str | Flag_SourceEntityURL str <- flags])
+
+
+optWikiUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String)
+optWikiUrls flags =
+ (listToMaybe [str | Flag_WikiBaseURL str <- flags]
+ ,listToMaybe [str | Flag_WikiModuleURL str <- flags]
+ ,listToMaybe [str | Flag_WikiEntityURL str <- flags])
+
+
ghcFlags :: [Flag] -> [String]
ghcFlags flags = [ option | Flag_OptGhc option <- flags ]
@@ -169,3 +222,10 @@ options backwardsCompat =
Option [] ["no-tmp-comp-dir"] (NoArg Flag_NoTmpCompDir)
"don't re-direct compilation output to a temporary directory"
]
+
+
+-- | Like 'listToMaybe' but returns the last element instead of the first.
+optLast :: [a] -> Maybe a
+optLast [] = Nothing
+optLast xs = Just (last xs)
+
diff --git a/src/Main.hs b/src/Main.hs
index 4c0728db..d1a94fd8 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -4,7 +4,7 @@
-- |
-- Module : Main
-- Copyright : (c) Simon Marlow 2003-2006,
--- David Waern 2006-2009
+-- David Waern 2006-2010
-- License : BSD-like
--
-- Maintainer : haddock@projects.haskell.org
@@ -173,48 +173,18 @@ main = handleTopExceptions $ do
-- | Render the interfaces with whatever backend is specified in the flags
render :: [Flag] -> [Interface] -> [InstalledInterface] -> IO ()
render flags ifaces installedIfaces = 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])
-
- libDir <- getHaddockLibDir flags
- let unicode = Flag_UseUnicode `elem` flags
- 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)
+ title = case optTitle flags of Nothing -> ""; Just t -> t
+ 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
+ opt_html_help_format = optHtmlHelpFormat flags
+ css_file = optCssFile flags
+ odir = outputDir flags
- maybe_html_help_format =
- case [hhformat | Flag_HtmlHelp hhformat <- flags] of
- [] -> Nothing
- formats -> Just (last formats)
-
- prologue <- getPrologue flags
-
- let
visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ]
-- *all* visible interfaces including external package modules
@@ -232,27 +202,30 @@ render flags ifaces installedIfaces = do
ppHtmlContents = pick Html.ppHtmlContents Xhtml.ppHtmlContents
ppHtml = pick Html.ppHtml Xhtml.ppHtml
copyHtmlBits = pick Html.copyHtmlBits Xhtml.copyHtmlBits
+
+ libDir <- getHaddockLibDir flags
+ prologue <- getPrologue flags
when (Flag_GenIndex `elem` flags) $ do
- ppHtmlIndex odir title packageStr maybe_html_help_format
- maybe_contents_url maybe_source_urls maybe_wiki_urls
+ ppHtmlIndex odir title packageStr opt_html_help_format
+ opt_contents_url opt_source_urls opt_wiki_urls
allVisibleIfaces
copyHtmlBits odir libDir css_file
when (Flag_GenContents `elem` flags && Flag_GenIndex `elem` flags) $
- ppHtmlHelpFiles title packageStr visibleIfaces odir maybe_html_help_format []
+ ppHtmlHelpFiles title packageStr visibleIfaces odir opt_html_help_format []
when (Flag_GenContents `elem` flags) $ do
- ppHtmlContents odir title packageStr maybe_html_help_format
- maybe_index_url maybe_source_urls maybe_wiki_urls
+ ppHtmlContents odir title packageStr opt_html_help_format
+ opt_index_url opt_source_urls opt_wiki_urls
allVisibleIfaces True prologue
copyHtmlBits odir libDir css_file
when (Flag_Html `elem` flags) $ do
ppHtml title packageStr visibleIfaces odir
- prologue maybe_html_help_format
- maybe_source_urls maybe_wiki_urls
- maybe_contents_url maybe_index_url unicode
+ prologue opt_html_help_format
+ opt_source_urls opt_wiki_urls
+ opt_contents_url opt_index_url unicode
copyHtmlBits odir libDir css_file
when (Flag_Hoogle `elem` flags) $ do