Move sources under haddock-api/src

1 files changed, 287 insertions, 0 deletions

diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
new file mode 100644
index 00000000..b166de46
--- /dev/null
+++ b/haddock-api/src/Haddock/Options.hs
@@ -0,0 +1,287 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Haddock.Options
+-- Copyright   :  (c) Simon Marlow      2003-2006,
+--                    David Waern       2006-2009,
+--                    Mateusz Kowalczyk 2013
+-- License     :  BSD-like
+--
+-- Maintainer  :  haddock@projects.haskell.org
+-- Stability   :  experimental
+-- Portability :  portable
+--
+-- Definition of the command line interface of Haddock.
+-----------------------------------------------------------------------------
+module Haddock.Options (
+  parseHaddockOpts,
+  Flag(..),
+  getUsage,
+  optTitle,
+  outputDir,
+  optContentsUrl,
+  optIndexUrl,
+  optCssFile,
+  sourceUrls,
+  wikiUrls,
+  optDumpInterfaceFile,
+  optLaTeXStyle,
+  qualification,
+  verbosity,
+  ghcFlags,
+  readIfaceArgs
+) where
+
+
+import Distribution.Verbosity
+import Haddock.Utils
+import Haddock.Types
+import System.Console.GetOpt
+import qualified Data.Char as Char
+
+
+data Flag
+  = Flag_BuiltInThemes
+  | Flag_CSS String
+--  | Flag_DocBook
+  | Flag_ReadInterface String
+  | Flag_DumpInterface String
+  | Flag_Heading String
+  | Flag_Html
+  | Flag_Hoogle
+  | Flag_Lib String
+  | Flag_OutputDir FilePath
+  | Flag_Prologue FilePath
+  | Flag_SourceBaseURL    String
+  | Flag_SourceModuleURL  String
+  | Flag_SourceEntityURL  String
+  | Flag_SourceLEntityURL String
+  | Flag_WikiBaseURL   String
+  | Flag_WikiModuleURL String
+  | Flag_WikiEntityURL String
+  | Flag_LaTeX
+  | Flag_LaTeXStyle String
+  | Flag_Help
+  | Flag_Verbosity String
+  | Flag_Version
+  | Flag_CompatibleInterfaceVersions
+  | Flag_InterfaceVersion
+  | Flag_UseContents String
+  | Flag_GenContents
+  | Flag_UseIndex String
+  | Flag_GenIndex
+  | Flag_IgnoreAllExports
+  | Flag_HideModule String
+  | Flag_ShowExtensions String
+  | Flag_OptGhc String
+  | Flag_GhcLibDir String
+  | Flag_GhcVersion
+  | Flag_PrintGhcPath
+  | Flag_PrintGhcLibDir
+  | Flag_NoWarnings
+  | Flag_UseUnicode
+  | Flag_NoTmpCompDir
+  | Flag_Qualification String
+  | Flag_PrettyHtml
+  | Flag_PrintMissingDocs
+  deriving (Eq)
+
+
+options :: Bool -> [OptDescr Flag]
+options backwardsCompat =
+  [
+    Option ['B']  []     (ReqArg Flag_GhcLibDir "DIR")
+      "path to a GHC lib dir, to override the default path",
+    Option ['o']  ["odir"]     (ReqArg Flag_OutputDir "DIR")
+      "directory in which to put the output files",
+    Option ['l']  ["lib"]         (ReqArg Flag_Lib "DIR")
+      "location of Haddock's auxiliary files",
+    Option ['i'] ["read-interface"] (ReqArg Flag_ReadInterface "FILE")
+      "read an interface from FILE",
+    Option ['D']  ["dump-interface"] (ReqArg Flag_DumpInterface "FILE")
+      "write the resulting interface to FILE",
+--    Option ['S']  ["docbook"]  (NoArg Flag_DocBook)
+--  "output in DocBook XML",
+    Option ['h']  ["html"]     (NoArg Flag_Html)
+      "output in HTML (XHTML 1.0)",
+    Option []  ["latex"]  (NoArg Flag_LaTeX) "use experimental LaTeX rendering",
+    Option []  ["latex-style"]  (ReqArg Flag_LaTeXStyle "FILE") "provide your own LaTeX style in FILE",
+    Option ['U'] ["use-unicode"] (NoArg Flag_UseUnicode) "use Unicode in HTML output",
+    Option []  ["hoogle"]     (NoArg Flag_Hoogle)
+      "output for Hoogle",
+    Option []  ["source-base"]   (ReqArg Flag_SourceBaseURL "URL")
+      "URL for a source code link on the contents\nand index pages",
+    Option ['s'] (if backwardsCompat then ["source", "source-module"] else ["source-module"])
+      (ReqArg Flag_SourceModuleURL "URL")
+      "URL for a source code link for each module\n(using the %{FILE} or %{MODULE} vars)",
+    Option []  ["source-entity"]  (ReqArg Flag_SourceEntityURL "URL")
+      "URL for a source code link for each entity\n(using the %{FILE}, %{MODULE}, %{NAME},\n%{KIND} or %{LINE} vars)",
+    Option []  ["source-entity-line"] (ReqArg Flag_SourceLEntityURL "URL")
+      "URL for a source code link for each entity.\nUsed if name links are unavailable, eg. for TH splices.",
+    Option []  ["comments-base"]   (ReqArg Flag_WikiBaseURL "URL")
+      "URL for a comments link on the contents\nand index pages",
+    Option []  ["comments-module"]  (ReqArg Flag_WikiModuleURL "URL")
+      "URL for a comments link for each module\n(using the %{MODULE} var)",
+    Option []  ["comments-entity"]  (ReqArg Flag_WikiEntityURL "URL")
+      "URL for a comments link for each entity\n(using the %{FILE}, %{MODULE}, %{NAME},\n%{KIND} or %{LINE} vars)",
+    Option ['c']  ["css", "theme"] (ReqArg Flag_CSS "PATH")
+      "the CSS file or theme directory to use for HTML output",
+    Option []  ["built-in-themes"] (NoArg Flag_BuiltInThemes)
+      "include all the built-in haddock themes",
+    Option ['p']  ["prologue"] (ReqArg Flag_Prologue "FILE")
+      "file containing prologue text",
+    Option ['t']  ["title"]    (ReqArg Flag_Heading "TITLE")
+      "page heading",
+    Option ['q']  ["qual"] (ReqArg Flag_Qualification "QUAL")
+      "qualification of names, one of \n'none' (default), 'full', 'local'\n'relative' or 'aliased'",
+    Option ['?']  ["help"]  (NoArg Flag_Help)
+      "display this help and exit",
+    Option ['V']  ["version"]  (NoArg Flag_Version)
+      "output version information and exit",
+    Option []  ["compatible-interface-versions"]  (NoArg Flag_CompatibleInterfaceVersions)
+      "output compatible interface file versions and exit",
+    Option []  ["interface-version"]  (NoArg Flag_InterfaceVersion)
+      "output interface file version and exit",
+    Option ['v']  ["verbosity"]  (ReqArg Flag_Verbosity "VERBOSITY")
+      "set verbosity level",
+    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\ninterfaces",
+    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\ninterfaces",
+    Option [] ["ignore-all-exports"] (NoArg Flag_IgnoreAllExports)
+      "behave as if all modules have the\nignore-exports atribute",
+    Option [] ["hide"] (ReqArg Flag_HideModule "MODULE")
+      "behave as if MODULE has the hide attribute",
+    Option [] ["show-extensions"] (ReqArg Flag_ShowExtensions "MODULE")
+      "behave as if MODULE has the show-extensions attribute",
+    Option [] ["optghc"] (ReqArg Flag_OptGhc "OPTION")
+      "option to be forwarded to GHC",
+    Option []  ["ghc-version"]  (NoArg Flag_GhcVersion)
+      "output GHC version in numeric format",
+    Option []  ["print-ghc-path"]  (NoArg Flag_PrintGhcPath)
+      "output path to GHC binary",
+    Option []  ["print-ghc-libdir"]  (NoArg Flag_PrintGhcLibDir)
+      "output GHC lib dir",
+    Option ['w'] ["no-warnings"] (NoArg Flag_NoWarnings) "turn off all warnings",
+    Option [] ["no-tmp-comp-dir"] (NoArg Flag_NoTmpCompDir)
+      "do not re-direct compilation output to a temporary directory",
+    Option [] ["pretty-html"] (NoArg Flag_PrettyHtml)
+      "generate html with newlines and indenting (for use with --html)",
+    Option [] ["print-missing-docs"] (NoArg Flag_PrintMissingDocs)
+      "print information about any undocumented entities"
+  ]
+
+
+getUsage :: IO String
+getUsage = do
+  prog <- getProgramName
+  return $ usageInfo (usageHeader prog) (options False)
+  where
+    usageHeader :: String -> String
+    usageHeader prog = "Usage: " ++ prog ++ " [OPTION...] file...\n"
+
+
+parseHaddockOpts :: [String] -> IO ([Flag], [String])
+parseHaddockOpts params =
+  case getOpt Permute (options True) params  of
+    (flags, args, []) -> return (flags, args)
+    (_, _, errors)    -> do
+      usage <- getUsage
+      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 ]
+
+
+optCssFile :: [Flag] -> Maybe FilePath
+optCssFile flags = optLast [ str | Flag_CSS str <- flags ]
+
+
+sourceUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String, Maybe String)
+sourceUrls flags =
+  (optLast [str | Flag_SourceBaseURL    str <- flags]
+  ,optLast [str | Flag_SourceModuleURL  str <- flags]
+  ,optLast [str | Flag_SourceEntityURL  str <- flags]
+  ,optLast [str | Flag_SourceLEntityURL str <- flags])
+
+
+wikiUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String)
+wikiUrls flags =
+  (optLast [str | Flag_WikiBaseURL   str <- flags]
+  ,optLast [str | Flag_WikiModuleURL str <- flags]
+  ,optLast [str | Flag_WikiEntityURL str <- flags])
+
+
+optDumpInterfaceFile :: [Flag] -> Maybe FilePath
+optDumpInterfaceFile flags = optLast [ str | Flag_DumpInterface str <- flags ]
+
+
+optLaTeXStyle :: [Flag] -> Maybe String
+optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ]
+
+
+qualification :: [Flag] -> Either String QualOption
+qualification flags =
+  case map (map Char.toLower) [ str | Flag_Qualification str <- flags ] of
+      []             -> Right OptNoQual
+      ["none"]       -> Right OptNoQual
+      ["full"]       -> Right OptFullQual
+      ["local"]      -> Right OptLocalQual
+      ["relative"]   -> Right OptRelativeQual
+      ["aliased"]    -> Right OptAliasedQual
+      [arg]          -> Left $ "unknown qualification type " ++ show arg
+      _:_            -> Left "qualification option given multiple times"
+
+
+verbosity :: [Flag] -> Verbosity
+verbosity flags =
+  case [ str | Flag_Verbosity str <- flags ] of
+    []  -> normal
+    x:_ -> case parseVerbosity x of
+      Left e -> throwE e
+      Right v -> v
+
+
+ghcFlags :: [Flag] -> [String]
+ghcFlags flags = [ option | Flag_OptGhc option <- flags ]
+
+
+readIfaceArgs :: [Flag] -> [(DocPaths, FilePath)]
+readIfaceArgs flags = [ parseIfaceOption s | Flag_ReadInterface s <- flags ]
+  where
+    parseIfaceOption :: String -> (DocPaths, FilePath)
+    parseIfaceOption str =
+      case break (==',') str of
+        (fpath, ',':rest) ->
+          case break (==',') rest of
+            (src, ',':file) -> ((fpath, Just src), file)
+            (file, _) -> ((fpath, Nothing), file)
+        (file, _) -> (("", Nothing), file)
+
+
+-- | Like 'listToMaybe' but returns the last element instead of the first.
+optLast :: [a] -> Maybe a
+optLast [] = Nothing
+optLast xs = Just (last xs)