Move flag evaluation code from Main to Haddock.Options

Determining the value of "singular" flags (by e.g. taking the last occurrence
of the flag) and other flag evaluation should done in Haddock.Options which is
the module that is supposed to define the command line interface. This makes
Main a bit easier on the eyes as well.

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