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(..)
  , Visibility(..)
  , getUsage
  , optTitle
  , outputDir
  , optContentsUrl
  , optIndexUrl
  , optCssFile
  , optSourceCssFile
  , sourceUrls
  , wikiUrls
  , baseUrl
  , optParCount
  , optDumpInterfaceFile
  , optShowInterfaceFile
  , optLaTeXStyle
  , optMathjax
  , qualification
  , sinceQualification
  , verbosity
  , ghcFlags
  , reexportFlags
  , readIfaceArgs
  , optPackageName
  , optPackageVersion
  , modulePackageInfo
  , ignoredSymbols
  ) where


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


data Flag
  = Flag_BuiltInThemes
  | Flag_CSS String
  | Flag_Org
--  | 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_BaseURL       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_IgnoreLinkSymbol 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 ['O'] ["org"]   (NoArg Flag_Org)   "output in Org"
  , 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
    []
    ["base-url"]
    (ReqArg Flag_BaseURL "URL")
    "Base URL for static assets (eg. css, javascript, json files etc.).\nWhen given statis assets will not be copied."
  , 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
    []
    ["ignore-link-symbol"]
    (ReqArg Flag_IgnoreLinkSymbol "SYMBOL")
    "name of a symbol which does not trigger a warning in case of link issue"
  , 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 ]
  )


baseUrl :: [Flag] -> Maybe String
baseUrl flags = optLast [ str | Flag_BaseURL 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

ignoredSymbols :: [Flag] -> [String]
ignoredSymbols flags = [ symbol | Flag_IgnoreLinkSymbol symbol <- flags ]

ghcFlags :: [Flag] -> [String]
ghcFlags flags = [ option | Flag_OptGhc option <- flags ]

reexportFlags :: [Flag] -> [String]
reexportFlags flags = [ option | Flag_Reexport option <- flags ]

data Visibility = Visible | Hidden
  deriving (Eq, Show)

readIfaceArgs :: [Flag] -> [(DocPaths, Visibility, FilePath)]
readIfaceArgs flags = [ parseIfaceOption s | Flag_ReadInterface s <- flags ]
 where
  parseIfaceOption :: String -> (DocPaths, Visibility, FilePath)
  parseIfaceOption str = case break (== ',') str of
    (fpath, ',' : rest) -> case break (== ',') rest of
      (src, ',' : rest') ->
        let src' = case src of
              "" -> Nothing
              _  -> Just src
        in  case break (== ',') rest' of
              (visibility, ',' : file)
                | visibility == "hidden" -> ((fpath, src'), Hidden, file)
                | otherwise              -> ((fpath, src'), Visible, file)
              (file, _) -> ((fpath, src'), Visible, file)
      (file, _) -> ((fpath, Nothing), Visible, file)
    (file, _) -> (("", Nothing), Visible, 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)