path: root/haddock-api/src/Haddock/Options.hs

-----------------------------------------------------------------------------
-- |
-- 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,
  optSourceCssFile,
  sourceUrls,
  wikiUrls,
  optParCount,
  optDumpInterfaceFile,
  optShowInterfaceFile,
  optLaTeXStyle,
  optMathjax,
  qualification,
  sinceQualification,
  verbosity,
  ghcFlags,
  reexportFlags,
  readIfaceArgs,
  optPackageName,
  optPackageVersion,
  modulePackageInfo
) where


import qualified Data.Char as Char
import           Data.Version
import           Control.Applicative
import           Distribution.Verbosity
import           GHC.Data.FastString
import           GHC ( DynFlags, Module, moduleUnit )
import           GHC.Unit.State
import           Haddock.Types
import           Haddock.Utils
import           GHC.Unit.State
import           System.Console.GetOpt
import qualified Text.ParserCombinators.ReadP as RP


data Flag
  = Flag_BuiltInThemes
  | Flag_CSS String
--  | Flag_DocBook
  | Flag_ReadInterface String
  | Flag_DumpInterface String
  | Flag_ShowInterface 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_QuickJumpIndex
  | Flag_HyperlinkedSource
  | Flag_SourceCss String
  | Flag_Mathjax String
  | Flag_Help
  | Flag_Verbosity String
  | Flag_Version
  | Flag_CompatibleInterfaceVersions
  | Flag_InterfaceVersion
  | Flag_BypassInterfaceVersonCheck
  | Flag_UseContents String
  | Flag_GenContents
  | Flag_UseIndex String
  | Flag_GenIndex
  | Flag_IgnoreAllExports
  | Flag_HideModule String
  | Flag_ShowModule String
  | Flag_ShowAllModules
  | 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_NoPrintMissingDocs
  | Flag_PackageName String
  | Flag_PackageVersion String
  | Flag_Reexport String
  | Flag_SinceQualification String
  | Flag_ParCount (Maybe Int)
  deriving (Eq, Show)


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 []     ["show-interface"] (ReqArg Flag_ShowInterface "FILE")
      "print the interface in a human readable form",
--    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 []  ["mathjax"]  (ReqArg Flag_Mathjax "URL") "URL FOR mathjax",
    Option ['U'] ["use-unicode"] (NoArg Flag_UseUnicode) "use Unicode in HTML output",
    Option []  ["hoogle"]     (NoArg Flag_Hoogle)
      "output for Hoogle; you may want --package-name and --package-version too",
    Option [] ["quickjump"] (NoArg Flag_QuickJumpIndex)
      "generate an index for interactive documentation navigation",
    Option [] ["hyperlinked-source"] (NoArg Flag_HyperlinkedSource)
      "generate highlighted and hyperlinked source code (for use with --html)",
    Option [] ["source-css"] (ReqArg Flag_SourceCss "FILE")
      "use custom CSS file instead of default one in hyperlinked source",
    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 []  ["bypass-interface-version-check"] (NoArg Flag_BypassInterfaceVersonCheck)
      "bypass the interface file version check (dangerous)",
    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 attribute",
    Option [] ["hide"] (ReqArg Flag_HideModule "MODULE")
      "behave as if MODULE has the hide attribute",
    Option [] ["show"] (ReqArg Flag_ShowModule "MODULE")
      "behave as if MODULE does not have the hide attribute",
    Option [] ["show-all"] (NoArg Flag_ShowAllModules)
      "behave as if not modules have 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 [] ["no-print-missing-docs"] (NoArg Flag_NoPrintMissingDocs)
      "don't print information about any undocumented entities",
    Option []  ["reexport"] (ReqArg Flag_Reexport "MOD")
      "reexport the module MOD, adding it to the index",
    Option [] ["package-name"] (ReqArg Flag_PackageName "NAME")
      "name of the package being documented",
    Option [] ["package-version"] (ReqArg Flag_PackageVersion "VERSION")
      "version of the package being documented in usual x.y.z.w format",
    Option []  ["since-qual"] (ReqArg Flag_SinceQualification "QUAL")
      "package qualification of @since, one of\n'always' (default) or 'only-external'",
    Option ['j'] [] (OptArg (\count -> Flag_ParCount (fmap read count)) "n")
      "load modules in parallel"
  ]


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)

optPackageVersion :: [Flag] -> Maybe Data.Version.Version
optPackageVersion flags =
  let ver = optLast [ v | Flag_PackageVersion v <- flags ]
  in ver >>= fmap fst . optLast . RP.readP_to_S parseVersion

optPackageName :: [Flag] -> Maybe PackageName
optPackageName flags =
  optLast [ PackageName $ mkFastString n | Flag_PackageName n <- flags ]


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 ]

optSourceCssFile :: [Flag] -> Maybe FilePath
optSourceCssFile flags = optLast [ str | Flag_SourceCss 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 ]

optShowInterfaceFile :: [Flag] -> Maybe FilePath
optShowInterfaceFile flags = optLast [ str | Flag_ShowInterface str <- flags ]

optLaTeXStyle :: [Flag] -> Maybe String
optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ]

optMathjax :: [Flag] -> Maybe String
optMathjax flags = optLast [ str | Flag_Mathjax str <- flags ]

optParCount :: [Flag] -> Maybe (Maybe Int)
optParCount flags = optLast [ n | Flag_ParCount n <- 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"

sinceQualification :: [Flag] -> Either String SinceQual
sinceQualification flags =
  case map (map Char.toLower) [ str | Flag_SinceQualification str <- flags ] of
      []             -> Right Always
      ["always"]     -> Right Always
      ["external"]   -> Right External
      [arg]          -> Left $ "unknown since-qualification type " ++ show arg
      _:_            -> Left "since-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 ]

reexportFlags :: [Flag] -> [String]
reexportFlags flags = [ option | Flag_Reexport 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)


-- | This function has a potential to return 'Nothing' because package name and
-- versions can no longer reliably be extracted in all cases: if the package is
-- not installed yet then this info is no longer available.
--
-- The @--package-name@ and @--package-version@ Haddock flags allow the user to
-- specify this information manually and it is returned here if present.
modulePackageInfo :: UnitState
                  -> [Flag] -- ^ Haddock flags are checked as they may contain
                            -- the package name or version provided by the user
                            -- which we prioritise
                  -> Maybe Module
                  -> (Maybe PackageName, Maybe Data.Version.Version)
modulePackageInfo _unit_state _flags Nothing = (Nothing, Nothing)
modulePackageInfo unit_state flags (Just modu) =
  ( optPackageName flags    <|> fmap unitPackageName pkgDb
  , optPackageVersion flags <|> fmap unitPackageVersion pkgDb
  )
  where
    pkgDb = lookupUnit unit_state (moduleUnit modu)