{-# LANGUAGE DeriveGeneric #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Simple.Setup
-- Copyright   :  Isaac Jones 2003-2004
--                Duncan Coutts 2007
-- License     :  BSD3
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- This is a big module, but not very complicated. The code is very regular
-- and repetitive. It defines the command line interface for all the Cabal
-- commands. For each command (like @configure@, @build@ etc) it defines a type
-- that holds all the flags, the default set of flags and a 'CommandUI' that
-- maps command line flags to and from the corresponding flags type.
--
-- All the flags types are instances of 'Monoid', see
-- <http://www.haskell.org/pipermail/cabal-devel/2007-December/001509.html>
-- for an explanation.
--
-- The types defined here get used in the front end and especially in
-- @cabal-install@ which has to do quite a bit of manipulating sets of command
-- line flags.
--
-- This is actually relatively nice, it works quite well. The main change it
-- needs is to unify it with the code for managing sets of fields that can be
-- read and written from files. This would allow us to save configure flags in
-- config files.

{-# LANGUAGE CPP #-}

module Distribution.Simple.Setup (

  GlobalFlags(..),   emptyGlobalFlags,   defaultGlobalFlags,   globalCommand,
  ConfigFlags(..),   emptyConfigFlags,   defaultConfigFlags,   configureCommand,
  configAbsolutePaths, readPackageDbList, showPackageDbList,
  CopyFlags(..),     emptyCopyFlags,     defaultCopyFlags,     copyCommand,
  InstallFlags(..),  emptyInstallFlags,  defaultInstallFlags,  installCommand,
  HaddockFlags(..),  emptyHaddockFlags,  defaultHaddockFlags,  haddockCommand,
  HscolourFlags(..), emptyHscolourFlags, defaultHscolourFlags, hscolourCommand,
  BuildFlags(..),    emptyBuildFlags,    defaultBuildFlags,    buildCommand,
  buildVerbose,
  ReplFlags(..),                         defaultReplFlags,     replCommand,
  CleanFlags(..),    emptyCleanFlags,    defaultCleanFlags,    cleanCommand,
  RegisterFlags(..), emptyRegisterFlags, defaultRegisterFlags, registerCommand,
                                                               unregisterCommand,
  SDistFlags(..),    emptySDistFlags,    defaultSDistFlags,    sdistCommand,
  TestFlags(..),     emptyTestFlags,     defaultTestFlags,     testCommand,
  TestShowDetails(..),
  BenchmarkFlags(..), emptyBenchmarkFlags,
  defaultBenchmarkFlags, benchmarkCommand,
  CopyDest(..),
  configureArgs, configureOptions, configureCCompiler, configureLinker,
  buildOptions, haddockOptions, installDirsOptions,
  programConfigurationOptions, programConfigurationPaths',

  defaultDistPref,

  Flag(..),
  toFlag,
  fromFlag,
  fromFlagOrDefault,
  flagToMaybe,
  flagToList,
  boolOpt, boolOpt', trueArg, falseArg, optionVerbosity, optionNumJobs ) where

import Distribution.Compiler ()
import Distribution.ReadE
import Distribution.Text
         ( Text(..), display )
import qualified Distribution.Compat.ReadP as Parse
import qualified Text.PrettyPrint as Disp
import Distribution.ModuleName
import Distribution.Package ( Dependency(..)
                            , PackageName
                            , InstalledPackageId )
import Distribution.PackageDescription
         ( FlagName(..), FlagAssignment )
import Distribution.Simple.Command hiding (boolOpt, boolOpt')
import qualified Distribution.Simple.Command as Command
import Distribution.Simple.Compiler
         ( CompilerFlavor(..), defaultCompilerFlavor, PackageDB(..)
         , DebugInfoLevel(..), flagToDebugInfoLevel
         , OptimisationLevel(..), flagToOptimisationLevel
         , absolutePackageDBPath )
import Distribution.Simple.Utils
         ( wrapText, wrapLine, lowercase, intercalate )
import Distribution.Simple.Program (Program(..), ProgramConfiguration,
                             requireProgram,
                             programInvocation, progInvokePath, progInvokeArgs,
                             knownPrograms,
                             addKnownProgram, emptyProgramConfiguration,
                             haddockProgram, ghcProgram, gccProgram, ldProgram)
import Distribution.Simple.InstallDirs
         ( InstallDirs(..), CopyDest(..),
           PathTemplate, toPathTemplate, fromPathTemplate )
import Distribution.Verbosity
import Distribution.Utils.NubList

import Control.Monad (liftM)
import Data.Binary (Binary)
import Data.List   ( sort )
import Data.Char   ( isSpace, isAlpha )
import Data.Monoid ( Monoid(..) )
import GHC.Generics (Generic)

-- FIXME Not sure where this should live
defaultDistPref :: FilePath
defaultDistPref = "dist"

-- ------------------------------------------------------------
-- * Flag type
-- ------------------------------------------------------------

-- | All flags are monoids, they come in two flavours:
--
-- 1. list flags eg
--
-- > --ghc-option=foo --ghc-option=bar
--
-- gives us all the values ["foo", "bar"]
--
-- 2. singular value flags, eg:
--
-- > --enable-foo --disable-foo
--
-- gives us Just False
-- So this Flag type is for the latter singular kind of flag.
-- Its monoid instance gives us the behaviour where it starts out as
-- 'NoFlag' and later flags override earlier ones.
--
data Flag a = Flag a | NoFlag deriving (Eq, Generic, Show, Read)

instance Binary a => Binary (Flag a)

instance Functor Flag where
  fmap f (Flag x) = Flag (f x)
  fmap _ NoFlag  = NoFlag

instance Monoid (Flag a) where
  mempty = NoFlag
  _ `mappend` f@(Flag _) = f
  f `mappend` NoFlag     = f

instance Bounded a => Bounded (Flag a) where
  minBound = toFlag minBound
  maxBound = toFlag maxBound

instance Enum a => Enum (Flag a) where
  fromEnum = fromEnum . fromFlag
  toEnum   = toFlag   . toEnum
  enumFrom (Flag a) = map toFlag . enumFrom $ a
  enumFrom _        = []
  enumFromThen (Flag a) (Flag b) = toFlag `map` enumFromThen a b
  enumFromThen _        _        = []
  enumFromTo   (Flag a) (Flag b) = toFlag `map` enumFromTo a b
  enumFromTo   _        _        = []
  enumFromThenTo (Flag a) (Flag b) (Flag c) = toFlag `map` enumFromThenTo a b c
  enumFromThenTo _        _        _        = []

toFlag :: a -> Flag a
toFlag = Flag

fromFlag :: Flag a -> a
fromFlag (Flag x) = x
fromFlag NoFlag   = error "fromFlag NoFlag. Use fromFlagOrDefault"

fromFlagOrDefault :: a -> Flag a -> a
fromFlagOrDefault _   (Flag x) = x
fromFlagOrDefault def NoFlag   = def

flagToMaybe :: Flag a -> Maybe a
flagToMaybe (Flag x) = Just x
flagToMaybe NoFlag   = Nothing

flagToList :: Flag a -> [a]
flagToList (Flag x) = [x]
flagToList NoFlag   = []

allFlags :: [Flag Bool] -> Flag Bool
allFlags flags = if all (\f -> fromFlagOrDefault False f) flags
                 then Flag True
                 else NoFlag

-- ------------------------------------------------------------
-- * Global flags
-- ------------------------------------------------------------

-- In fact since individual flags types are monoids and these are just sets of
-- flags then they are also monoids pointwise. This turns out to be really
-- useful. The mempty is the set of empty flags and mappend allows us to
-- override specific flags. For example we can start with default flags and
-- override with the ones we get from a file or the command line, or both.

-- | Flags that apply at the top level, not to any sub-command.
data GlobalFlags = GlobalFlags {
    globalVersion        :: Flag Bool,
    globalNumericVersion :: Flag Bool
  }

defaultGlobalFlags :: GlobalFlags
defaultGlobalFlags  = GlobalFlags {
    globalVersion        = Flag False,
    globalNumericVersion = Flag False
  }

globalCommand :: [Command action] -> CommandUI GlobalFlags
globalCommand commands = CommandUI
  { commandName         = ""
  , commandSynopsis     = ""
  , commandUsage        = \pname ->
         "This Setup program uses the Haskell Cabal Infrastructure.\n"
      ++ "See http://www.haskell.org/cabal/ for more information.\n"
      ++ "\n"
      ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n"
  , commandDescription = Just $ \pname ->
      let
        commands' = commands ++ [commandAddAction helpCommandUI undefined]
        cmdDescs = getNormalCommandDescriptions commands'
        maxlen    = maximum $ [length name | (name, _) <- cmdDescs]
        align str = str ++ replicate (maxlen - length str) ' '
      in
         "Commands:\n"
      ++ unlines [ "  " ++ align name ++ "    " ++ description
                 | (name, description) <- cmdDescs ]
      ++ "\n"
      ++ "For more information about a command use\n"
      ++ "  " ++ pname ++ " COMMAND --help\n\n"
      ++ "Typical steps for installing Cabal packages:\n"
      ++ concat [ "  " ++ pname ++ " " ++ x ++ "\n"
                | x <- ["configure", "build", "install"]]
  , commandNotes        = Nothing
  , commandDefaultFlags = defaultGlobalFlags
  , commandOptions      = \_ ->
      [option ['V'] ["version"]
         "Print version information"
         globalVersion (\v flags -> flags { globalVersion = v })
         trueArg
      ,option [] ["numeric-version"]
         "Print just the version number"
         globalNumericVersion (\v flags -> flags { globalNumericVersion = v })
         trueArg
      ]
  }

emptyGlobalFlags :: GlobalFlags
emptyGlobalFlags = mempty

instance Monoid GlobalFlags where
  mempty = GlobalFlags {
    globalVersion        = mempty,
    globalNumericVersion = mempty
  }
  mappend a b = GlobalFlags {
    globalVersion        = combine globalVersion,
    globalNumericVersion = combine globalNumericVersion
  }
    where combine field = field a `mappend` field b

-- ------------------------------------------------------------
-- * Config flags
-- ------------------------------------------------------------

-- | Flags to @configure@ command
data ConfigFlags = ConfigFlags {
    --FIXME: the configPrograms is only here to pass info through to configure
    -- because the type of configure is constrained by the UserHooks.
    -- when we change UserHooks next we should pass the initial
    -- ProgramConfiguration directly and not via ConfigFlags
    configPrograms      :: ProgramConfiguration, -- ^All programs that cabal may
                                                 -- run

    configProgramPaths  :: [(String, FilePath)], -- ^user specified programs paths
    configProgramArgs   :: [(String, [String])], -- ^user specified programs args
    configProgramPathExtra :: NubList FilePath,  -- ^Extend the $PATH
    configHcFlavor      :: Flag CompilerFlavor, -- ^The \"flavor\" of the
                                                -- compiler, such as GHC or
                                                -- JHC.
    configHcPath        :: Flag FilePath, -- ^given compiler location
    configHcPkg         :: Flag FilePath, -- ^given hc-pkg location
    configVanillaLib    :: Flag Bool,     -- ^Enable vanilla library
    configProfLib       :: Flag Bool,     -- ^Enable profiling in the library
    configSharedLib     :: Flag Bool,     -- ^Build shared library
    configDynExe        :: Flag Bool,     -- ^Enable dynamic linking of the
                                          -- executables.
    configProfExe       :: Flag Bool,     -- ^Enable profiling in the
                                          -- executables.
    configConfigureArgs :: [String],      -- ^Extra arguments to @configure@
    configOptimization  :: Flag OptimisationLevel,  -- ^Enable optimization.
    configProgPrefix    :: Flag PathTemplate, -- ^Installed executable prefix.
    configProgSuffix    :: Flag PathTemplate, -- ^Installed executable suffix.
    configInstallDirs   :: InstallDirs (Flag PathTemplate), -- ^Installation
                                                            -- paths
    configScratchDir    :: Flag FilePath,
    configExtraLibDirs  :: [FilePath],   -- ^ path to search for extra libraries
    configExtraIncludeDirs :: [FilePath],   -- ^ path to search for header files

    configDistPref :: Flag FilePath, -- ^"dist" prefix
    configVerbosity :: Flag Verbosity, -- ^verbosity level
    configUserInstall :: Flag Bool,    -- ^The --user\/--global flag
    configPackageDBs :: [Maybe PackageDB], -- ^Which package DBs to use
    configGHCiLib   :: Flag Bool,      -- ^Enable compiling library for GHCi
    configSplitObjs :: Flag Bool,      -- ^Enable -split-objs with GHC
    configStripExes :: Flag Bool,      -- ^Enable executable stripping
    configStripLibs :: Flag Bool,      -- ^Enable library stripping
    configConstraints :: [Dependency], -- ^Additional constraints for
                                       -- dependencies.
    configDependencies :: [(PackageName, InstalledPackageId)],
    configInstantiateWith :: [(ModuleName, (InstalledPackageId, ModuleName))],
      -- ^The packages depended on.
    configConfigurationsFlags :: FlagAssignment,
    configTests               :: Flag Bool, -- ^Enable test suite compilation
    configBenchmarks          :: Flag Bool, -- ^Enable benchmark compilation
    configCoverage :: Flag Bool, -- ^Enable program coverage
    configLibCoverage :: Flag Bool, -- ^OBSOLETE. Just used to signal error.
    configExactConfiguration  :: Flag Bool,
      -- ^All direct dependencies and flags are provided on the command line by
      -- the user via the '--dependency' and '--flags' options.
    configFlagError :: Flag String,
      -- ^Halt and show an error message indicating an error in flag assignment
    configRelocatable :: Flag Bool, -- ^ Enable relocatable package built
    configDebugInfo :: Flag DebugInfoLevel  -- ^ Emit debug info.
  }
  deriving (Generic, Read, Show)

instance Binary ConfigFlags

configAbsolutePaths :: ConfigFlags -> IO ConfigFlags
configAbsolutePaths f =
  (\v -> f { configPackageDBs = v })
  `liftM` mapM (maybe (return Nothing) (liftM Just . absolutePackageDBPath))
  (configPackageDBs f)

defaultConfigFlags :: ProgramConfiguration -> ConfigFlags
defaultConfigFlags progConf = emptyConfigFlags {
    configPrograms     = progConf,
    configHcFlavor     = maybe NoFlag Flag defaultCompilerFlavor,
    configVanillaLib   = Flag True,
    configProfLib      = NoFlag,
    configSharedLib    = NoFlag,
    configDynExe       = Flag False,
    configProfExe      = NoFlag,
    configOptimization = Flag NormalOptimisation,
    configProgPrefix   = Flag (toPathTemplate ""),
    configProgSuffix   = Flag (toPathTemplate ""),
    configDistPref     = Flag defaultDistPref,
    configVerbosity    = Flag normal,
    configUserInstall  = Flag False,           --TODO: reverse this
#if defined(mingw32_HOST_OS)
    -- See #1589.
    configGHCiLib      = Flag True,
#else
    configGHCiLib      = NoFlag,
#endif
    configSplitObjs    = Flag False, -- takes longer, so turn off by default
    configStripExes    = Flag True,
    configStripLibs    = Flag True,
    configTests        = Flag False,
    configBenchmarks   = Flag False,
    configCoverage     = Flag False,
    configLibCoverage  = NoFlag,
    configExactConfiguration = Flag False,
    configFlagError    = NoFlag,
    configRelocatable  = Flag False,
    configDebugInfo    = Flag NoDebugInfo
  }

configureCommand :: ProgramConfiguration -> CommandUI ConfigFlags
configureCommand progConf = CommandUI
  { commandName         = "configure"
  , commandSynopsis     = "Prepare to build the package."
  , commandDescription  = Just $ \_ -> wrapText $
         "Configure how the package is built by setting "
      ++ "package (and other) flags.\n"
      ++ "\n"
      ++ "The configuration affects several other commands, "
      ++ "including build, test, bench, run, repl.\n"
  , commandNotes        = Just (\_ -> programFlagsDescription progConf)
  , commandUsage        = \pname ->
      "Usage: " ++ pname ++ " configure [FLAGS]\n"
  , commandDefaultFlags = defaultConfigFlags progConf
  , commandOptions      = \showOrParseArgs ->
         configureOptions showOrParseArgs
      ++ programConfigurationPaths   progConf showOrParseArgs
           configProgramPaths (\v fs -> fs { configProgramPaths = v })
      ++ programConfigurationOption progConf showOrParseArgs
           configProgramArgs (\v fs -> fs { configProgramArgs = v })
      ++ programConfigurationOptions progConf showOrParseArgs
           configProgramArgs (\v fs -> fs { configProgramArgs = v })
  }

configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags]
configureOptions showOrParseArgs =
      [optionVerbosity configVerbosity
       (\v flags -> flags { configVerbosity = v })
      ,optionDistPref
         configDistPref (\d flags -> flags { configDistPref = d })
         showOrParseArgs

      ,option [] ["compiler"] "compiler"
         configHcFlavor (\v flags -> flags { configHcFlavor = v })
         (choiceOpt [ (Flag GHC,   ("g", ["ghc"]),   "compile with GHC")
                    , (Flag GHCJS, ([] , ["ghcjs"]), "compile with GHCJS")
                    , (Flag JHC,   ([] , ["jhc"]),   "compile with JHC")
                    , (Flag LHC,   ([] , ["lhc"]),   "compile with LHC")
                    , (Flag UHC,   ([] , ["uhc"]),   "compile with UHC")
                    -- "haskell-suite" compiler id string will be replaced
                    -- by a more specific one during the configure stage
                    , (Flag (HaskellSuite "haskell-suite"), ([] , ["haskell-suite"]),
                        "compile with a haskell-suite compiler")])

      ,option "w" ["with-compiler"]
         "give the path to a particular compiler"
         configHcPath (\v flags -> flags { configHcPath = v })
         (reqArgFlag "PATH")

      ,option "" ["with-hc-pkg"]
         "give the path to the package tool"
         configHcPkg (\v flags -> flags { configHcPkg = v })
         (reqArgFlag "PATH")
      ]
   ++ map liftInstallDirs installDirsOptions
   ++ [option "" ["program-prefix"]
          "prefix to be applied to installed executables"
          configProgPrefix
          (\v flags -> flags { configProgPrefix = v })
          (reqPathTemplateArgFlag "PREFIX")

      ,option "" ["program-suffix"]
          "suffix to be applied to installed executables"
          configProgSuffix (\v flags -> flags { configProgSuffix = v } )
          (reqPathTemplateArgFlag "SUFFIX")

      ,option "" ["library-vanilla"]
         "Vanilla libraries"
         configVanillaLib (\v flags -> flags { configVanillaLib = v })
         (boolOpt [] [])

      ,option "p" ["library-profiling"]
         "Library profiling"
         configProfLib (\v flags -> flags { configProfLib = v })
         (boolOpt "p" [])

      ,option "" ["shared"]
         "Shared library"
         configSharedLib (\v flags -> flags { configSharedLib = v })
         (boolOpt [] [])

      ,option "" ["executable-dynamic"]
         "Executable dynamic linking"
         configDynExe (\v flags -> flags { configDynExe = v })
         (boolOpt [] [])

      ,option "" ["profiling", "executable-profiling"]
         "Executable profiling (requires library profiling)"
         configProfExe (\v flags -> flags { configProfExe = v })
         (boolOpt [] [])

      ,multiOption "optimization"
         configOptimization (\v flags -> flags { configOptimization = v })
         [optArg' "n" (Flag . flagToOptimisationLevel)
                     (\f -> case f of
                              Flag NoOptimisation      -> []
                              Flag NormalOptimisation  -> [Nothing]
                              Flag MaximumOptimisation -> [Just "2"]
                              _                        -> [])
                 "O" ["enable-optimization","enable-optimisation"]
                 "Build with optimization (n is 0--2, default is 1)",
          noArg (Flag NoOptimisation) []
                ["disable-optimization","disable-optimisation"]
                "Build without optimization"
         ]

      ,multiOption "debug-info"
         configDebugInfo (\v flags -> flags { configDebugInfo = v })
         [optArg' "n" (Flag . flagToDebugInfoLevel)
                     (\f -> case f of
                              Flag NoDebugInfo      -> []
                              Flag MinimalDebugInfo -> [Just "1"]
                              Flag NormalDebugInfo  -> [Nothing]
                              Flag MaximalDebugInfo -> [Just "3"]
                              _                     -> [])
                 "" ["enable-debug-info"]
                 "Emit debug info (n is 0--3, default is 0)",
          noArg (Flag NoDebugInfo) []
                ["disable-debug-info"]
                "Don't emit debug info"
         ]

      ,option "" ["library-for-ghci"]
         "compile library for use with GHCi"
         configGHCiLib (\v flags -> flags { configGHCiLib = v })
         (boolOpt [] [])

      ,option "" ["split-objs"]
         "split library into smaller objects to reduce binary sizes (GHC 6.6+)"
         configSplitObjs (\v flags -> flags { configSplitObjs = v })
         (boolOpt [] [])

      ,option "" ["executable-stripping"]
         "strip executables upon installation to reduce binary sizes"
         configStripExes (\v flags -> flags { configStripExes = v })
         (boolOpt [] [])

      ,option "" ["library-stripping"]
         "strip libraries upon installation to reduce binary sizes"
         configStripLibs (\v flags -> flags { configStripLibs = v })
         (boolOpt [] [])

      ,option "" ["configure-option"]
         "Extra option for configure"
         configConfigureArgs (\v flags -> flags { configConfigureArgs = v })
         (reqArg' "OPT" (\x -> [x]) id)

      ,option "" ["user-install"]
         "doing a per-user installation"
         configUserInstall (\v flags -> flags { configUserInstall = v })
         (boolOpt' ([],["user"]) ([], ["global"]))

      ,option "" ["package-db"]
         "Use a given package database (to satisfy dependencies and register in). May be a specific file, 'global', 'user' or 'clear'."
         configPackageDBs (\v flags -> flags { configPackageDBs = v })
         (reqArg' "DB" readPackageDbList showPackageDbList)

      ,option "f" ["flags"]
         "Force values for the given flags in Cabal conditionals in the .cabal file.  E.g., --flags=\"debug -usebytestrings\" forces the flag \"debug\" to true and \"usebytestrings\" to false."
         configConfigurationsFlags (\v flags -> flags { configConfigurationsFlags = v })
         (reqArg' "FLAGS" readFlagList showFlagList)

      ,option "" ["extra-include-dirs"]
         "A list of directories to search for header files"
         configExtraIncludeDirs (\v flags -> flags {configExtraIncludeDirs = v})
         (reqArg' "PATH" (\x -> [x]) id)

      ,option "" ["extra-lib-dirs"]
         "A list of directories to search for external libraries"
         configExtraLibDirs (\v flags -> flags {configExtraLibDirs = v})
         (reqArg' "PATH" (\x -> [x]) id)

      ,option "" ["extra-prog-path"]
         "A list of directories to search for required programs (in addition to the normal search locations)"
         configProgramPathExtra (\v flags -> flags {configProgramPathExtra = v})
         (reqArg' "PATH" (\x -> toNubList [x]) fromNubList)

      ,option "" ["constraint"]
         "A list of additional constraints on the dependencies."
         configConstraints (\v flags -> flags { configConstraints = v})
         (reqArg "DEPENDENCY"
                 (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parse))
                 (map (\x -> display x)))

      ,option "" ["dependency"]
         "A list of exact dependencies. E.g., --dependency=\"void=void-0.5.8-177d5cdf20962d0581fe2e4932a6c309\""
         configDependencies (\v flags -> flags { configDependencies = v})
         (reqArg "NAME=ID"
                 (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parseDependency))
                 (map (\x -> display (fst x) ++ "=" ++ display (snd x))))

      ,option "" ["instantiate-with"]
         "A mapping of signature names to concrete module instantiations. E.g., --instantiate-with=\"Map=Data.Map.Strict@containers-0.5.5.1-inplace\""
         configInstantiateWith (\v flags -> flags { configInstantiateWith = v })
         (reqArg "NAME=PKG:MOD"
                 (readP_to_E (const "signature mapping expected") ((\x -> [x]) `fmap` parseHoleMapEntry))
                 (map (\(n,(p,m)) -> display n ++ "=" ++ display m ++ "@" ++ display p)))

      ,option "" ["tests"]
         "dependency checking and compilation for test suites listed in the package description file."
         configTests (\v flags -> flags { configTests = v })
         (boolOpt [] [])

      ,option "" ["library-coverage"]
         "OBSOLETE. Please use --enable-coverage instead."
         configLibCoverage (\v flags -> flags { configLibCoverage = v })
         (boolOpt [] [])

      ,option "" ["coverage"]
         "build package with Haskell Program Coverage enabled. (GHC only)"
         configCoverage (\v flags -> flags { configCoverage = v })
         (boolOpt [] [])

      ,option "" ["exact-configuration"]
         "All direct dependencies and flags are provided on the command line."
         configExactConfiguration
         (\v flags -> flags { configExactConfiguration = v })
         trueArg

      ,option "" ["benchmarks"]
         "dependency checking and compilation for benchmarks listed in the package description file."
         configBenchmarks (\v flags -> flags { configBenchmarks = v })
         (boolOpt [] [])

      ,option "" ["relocatable"]
         "building a package that is relocatable. (GHC only)"
         configRelocatable (\v flags -> flags { configRelocatable = v})
         (boolOpt [] [])
      ]
  where
    readFlagList :: String -> FlagAssignment
    readFlagList = map tagWithValue . words
      where tagWithValue ('-':fname) = (FlagName (lowercase fname), False)
            tagWithValue fname       = (FlagName (lowercase fname), True)

    showFlagList :: FlagAssignment -> [String]
    showFlagList fs = [ if not set then '-':fname else fname
                      | (FlagName fname, set) <- fs]

    liftInstallDirs =
      liftOption configInstallDirs (\v flags -> flags { configInstallDirs = v })

    reqPathTemplateArgFlag title _sf _lf d get set =
      reqArgFlag title _sf _lf d
        (fmap fromPathTemplate . get) (set . fmap toPathTemplate)

readPackageDbList :: String -> [Maybe PackageDB]
readPackageDbList "clear"  = [Nothing]
readPackageDbList "global" = [Just GlobalPackageDB]
readPackageDbList "user"   = [Just UserPackageDB]
readPackageDbList other    = [Just (SpecificPackageDB other)]

showPackageDbList :: [Maybe PackageDB] -> [String]
showPackageDbList = map showPackageDb
  where
    showPackageDb Nothing                       = "clear"
    showPackageDb (Just GlobalPackageDB)        = "global"
    showPackageDb (Just UserPackageDB)          = "user"
    showPackageDb (Just (SpecificPackageDB db)) = db


parseDependency :: Parse.ReadP r (PackageName, InstalledPackageId)
parseDependency = do
  x <- parse
  _ <- Parse.char '='
  y <- parse
  return (x, y)

parseHoleMapEntry :: Parse.ReadP r (ModuleName, (InstalledPackageId, ModuleName))
parseHoleMapEntry = do
  x <- parse
  _ <- Parse.char '='
  y <- parse
  _ <- Parse.char '@'
  z <- parse
  return (x, (z, y))

installDirsOptions :: [OptionField (InstallDirs (Flag PathTemplate))]
installDirsOptions =
  [ option "" ["prefix"]
      "bake this prefix in preparation of installation"
      prefix (\v flags -> flags { prefix = v })
      installDirArg

  , option "" ["bindir"]
      "installation directory for executables"
      bindir (\v flags -> flags { bindir = v })
      installDirArg

  , option "" ["libdir"]
      "installation directory for libraries"
      libdir (\v flags -> flags { libdir = v })
      installDirArg

  , option "" ["libsubdir"]
      "subdirectory of libdir in which libs are installed"
      libsubdir (\v flags -> flags { libsubdir = v })
      installDirArg

  , option "" ["libexecdir"]
      "installation directory for program executables"
      libexecdir (\v flags -> flags { libexecdir = v })
      installDirArg

  , option "" ["datadir"]
      "installation directory for read-only data"
      datadir (\v flags -> flags { datadir = v })
      installDirArg

  , option "" ["datasubdir"]
      "subdirectory of datadir in which data files are installed"
      datasubdir (\v flags -> flags { datasubdir = v })
      installDirArg

  , option "" ["docdir"]
      "installation directory for documentation"
      docdir (\v flags -> flags { docdir = v })
      installDirArg

  , option "" ["htmldir"]
      "installation directory for HTML documentation"
      htmldir (\v flags -> flags { htmldir = v })
      installDirArg

  , option "" ["haddockdir"]
      "installation directory for haddock interfaces"
      haddockdir (\v flags -> flags { haddockdir = v })
      installDirArg

  , option "" ["sysconfdir"]
      "installation directory for configuration files"
      sysconfdir (\v flags -> flags { sysconfdir = v })
      installDirArg
  ]
  where
    installDirArg _sf _lf d get set =
      reqArgFlag "DIR" _sf _lf d
        (fmap fromPathTemplate . get) (set . fmap toPathTemplate)

emptyConfigFlags :: ConfigFlags
emptyConfigFlags = mempty

instance Monoid ConfigFlags where
  mempty = ConfigFlags {
    configPrograms      = error "FIXME: remove configPrograms",
    configProgramPaths  = mempty,
    configProgramArgs   = mempty,
    configProgramPathExtra = mempty,
    configHcFlavor      = mempty,
    configHcPath        = mempty,
    configHcPkg         = mempty,
    configVanillaLib    = mempty,
    configProfLib       = mempty,
    configSharedLib     = mempty,
    configDynExe        = mempty,
    configProfExe       = mempty,
    configConfigureArgs = mempty,
    configOptimization  = mempty,
    configProgPrefix    = mempty,
    configProgSuffix    = mempty,
    configInstallDirs   = mempty,
    configScratchDir    = mempty,
    configDistPref      = mempty,
    configVerbosity     = mempty,
    configUserInstall   = mempty,
    configPackageDBs    = mempty,
    configGHCiLib       = mempty,
    configSplitObjs     = mempty,
    configStripExes     = mempty,
    configStripLibs     = mempty,
    configExtraLibDirs  = mempty,
    configConstraints   = mempty,
    configDependencies  = mempty,
    configInstantiateWith     = mempty,
    configExtraIncludeDirs    = mempty,
    configConfigurationsFlags = mempty,
    configTests               = mempty,
    configCoverage         = mempty,
    configLibCoverage   = mempty,
    configExactConfiguration  = mempty,
    configBenchmarks          = mempty,
    configFlagError     = mempty,
    configRelocatable   = mempty,
    configDebugInfo     = mempty
  }
  mappend a b =  ConfigFlags {
    configPrograms      = configPrograms b,
    configProgramPaths  = combine configProgramPaths,
    configProgramArgs   = combine configProgramArgs,
    configProgramPathExtra = combine configProgramPathExtra,
    configHcFlavor      = combine configHcFlavor,
    configHcPath        = combine configHcPath,
    configHcPkg         = combine configHcPkg,
    configVanillaLib    = combine configVanillaLib,
    configProfLib       = combine configProfLib,
    configSharedLib     = combine configSharedLib,
    configDynExe        = combine configDynExe,
    configProfExe       = combine configProfExe,
    configConfigureArgs = combine configConfigureArgs,
    configOptimization  = combine configOptimization,
    configProgPrefix    = combine configProgPrefix,
    configProgSuffix    = combine configProgSuffix,
    configInstallDirs   = combine configInstallDirs,
    configScratchDir    = combine configScratchDir,
    configDistPref      = combine configDistPref,
    configVerbosity     = combine configVerbosity,
    configUserInstall   = combine configUserInstall,
    configPackageDBs    = combine configPackageDBs,
    configGHCiLib       = combine configGHCiLib,
    configSplitObjs     = combine configSplitObjs,
    configStripExes     = combine configStripExes,
    configStripLibs     = combine configStripLibs,
    configExtraLibDirs  = combine configExtraLibDirs,
    configConstraints   = combine configConstraints,
    configDependencies  = combine configDependencies,
    configInstantiateWith     = combine configInstantiateWith,
    configExtraIncludeDirs    = combine configExtraIncludeDirs,
    configConfigurationsFlags = combine configConfigurationsFlags,
    configTests               = combine configTests,
    configCoverage         = combine configCoverage,
    configLibCoverage         = combine configLibCoverage,
    configExactConfiguration  = combine configExactConfiguration,
    configBenchmarks          = combine configBenchmarks,
    configFlagError     = combine configFlagError,
    configRelocatable   = combine configRelocatable,
    configDebugInfo     = combine configDebugInfo
  }
    where combine field = field a `mappend` field b

-- ------------------------------------------------------------
-- * Copy flags
-- ------------------------------------------------------------

-- | Flags to @copy@: (destdir, copy-prefix (backwards compat), verbosity)
data CopyFlags = CopyFlags {
    copyDest      :: Flag CopyDest,
    copyDistPref  :: Flag FilePath,
    copyVerbosity :: Flag Verbosity
  }
  deriving Show

defaultCopyFlags :: CopyFlags
defaultCopyFlags  = CopyFlags {
    copyDest      = Flag NoCopyDest,
    copyDistPref  = Flag defaultDistPref,
    copyVerbosity = Flag normal
  }

copyCommand :: CommandUI CopyFlags
copyCommand = CommandUI
  { commandName         = "copy"
  , commandSynopsis     = "Copy the files into the install locations."
  , commandDescription  = Just $ \_ -> wrapText $
          "Does not call register, and allows a prefix at install time. "
       ++ "Without the --destdir flag, configure determines location.\n"
  , commandNotes        = Nothing
  , commandUsage        = \pname ->
      "Usage: " ++ pname ++ " copy [FLAGS]\n"
  , commandDefaultFlags = defaultCopyFlags
  , commandOptions      = \showOrParseArgs ->
      [optionVerbosity copyVerbosity (\v flags -> flags { copyVerbosity = v })

      ,optionDistPref
         copyDistPref (\d flags -> flags { copyDistPref = d })
         showOrParseArgs

      ,option "" ["destdir"]
         "directory to copy files to, prepended to installation directories"
         copyDest (\v flags -> flags { copyDest = v })
         (reqArg "DIR" (succeedReadE (Flag . CopyTo))
                       (\f -> case f of Flag (CopyTo p) -> [p]; _ -> []))
      ]
  }

emptyCopyFlags :: CopyFlags
emptyCopyFlags = mempty

instance Monoid CopyFlags where
  mempty = CopyFlags {
    copyDest      = mempty,
    copyDistPref  = mempty,
    copyVerbosity = mempty
  }
  mappend a b = CopyFlags {
    copyDest      = combine copyDest,
    copyDistPref  = combine copyDistPref,
    copyVerbosity = combine copyVerbosity
  }
    where combine field = field a `mappend` field b

-- ------------------------------------------------------------
-- * Install flags
-- ------------------------------------------------------------

-- | Flags to @install@: (package db, verbosity)
data InstallFlags = InstallFlags {
    installPackageDB :: Flag PackageDB,
    installDistPref  :: Flag FilePath,
    installUseWrapper :: Flag Bool,
    installInPlace    :: Flag Bool,
    installVerbosity :: Flag Verbosity
  }
  deriving Show

defaultInstallFlags :: InstallFlags
defaultInstallFlags  = InstallFlags {
    installPackageDB = NoFlag,
    installDistPref  = Flag defaultDistPref,
    installUseWrapper = Flag False,
    installInPlace    = Flag False,
    installVerbosity = Flag normal
  }

installCommand :: CommandUI InstallFlags
installCommand = CommandUI
  { commandName         = "install"
  , commandSynopsis     =
      "Copy the files into the install locations. Run register."
  , commandDescription  = Just $ \_ -> wrapText $
         "Unlike the copy command, install calls the register command."
      ++ "If you want to install into a location that is not what was"
      ++ "specified in the configure step, use the copy command.\n"
  , commandNotes        = Nothing
  , commandUsage        = \pname ->
      "Usage: " ++ pname ++ " install [FLAGS]\n"
  , commandDefaultFlags = defaultInstallFlags
  , commandOptions      = \showOrParseArgs ->
      [optionVerbosity installVerbosity (\v flags -> flags { installVerbosity = v })
      ,optionDistPref
         installDistPref (\d flags -> flags { installDistPref = d })
         showOrParseArgs

      ,option "" ["inplace"]
         "install the package in the install subdirectory of the dist prefix, so it can be used without being installed"
         installInPlace (\v flags -> flags { installInPlace = v })
         trueArg

      ,option "" ["shell-wrappers"]
         "using shell script wrappers around executables"
         installUseWrapper (\v flags -> flags { installUseWrapper = v })
         (boolOpt [] [])

      ,option "" ["package-db"] ""
         installPackageDB (\v flags -> flags { installPackageDB = v })
         (choiceOpt [ (Flag UserPackageDB, ([],["user"]),
                      "upon configuration register this package in the user's local package database")
                    , (Flag GlobalPackageDB, ([],["global"]),
                      "(default) upon configuration register this package in the system-wide package database")])
      ]
  }

emptyInstallFlags :: InstallFlags
emptyInstallFlags = mempty

instance Monoid InstallFlags where
  mempty = InstallFlags{
    installPackageDB = mempty,
    installDistPref  = mempty,
    installUseWrapper = mempty,
    installInPlace    = mempty,
    installVerbosity = mempty
  }
  mappend a b = InstallFlags{
    installPackageDB = combine installPackageDB,
    installDistPref  = combine installDistPref,
    installUseWrapper = combine installUseWrapper,
    installInPlace    = combine installInPlace,
    installVerbosity = combine installVerbosity
  }
    where combine field = field a `mappend` field b

-- ------------------------------------------------------------
-- * SDist flags
-- ------------------------------------------------------------

-- | Flags to @sdist@: (snapshot, verbosity)
data SDistFlags = SDistFlags {
    sDistSnapshot    :: Flag Bool,
    sDistDirectory   :: Flag FilePath,
    sDistDistPref    :: Flag FilePath,
    sDistListSources :: Flag FilePath,
    sDistVerbosity   :: Flag Verbosity
  }
  deriving Show

defaultSDistFlags :: SDistFlags
defaultSDistFlags = SDistFlags {
    sDistSnapshot    = Flag False,
    sDistDirectory   = mempty,
    sDistDistPref    = Flag defaultDistPref,
    sDistListSources = mempty,
    sDistVerbosity   = Flag normal
  }

sdistCommand :: CommandUI SDistFlags
sdistCommand = CommandUI
  { commandName         = "sdist"
  , commandSynopsis     =
      "Generate a source distribution file (.tar.gz)."
  , commandDescription  = Nothing
  , commandNotes        = Nothing
  , commandUsage        = \pname ->
      "Usage: " ++ pname ++ " sdist [FLAGS]\n"
  , commandDefaultFlags = defaultSDistFlags
  , commandOptions      = \showOrParseArgs ->
      [optionVerbosity sDistVerbosity (\v flags -> flags { sDistVerbosity = v })
      ,optionDistPref
         sDistDistPref (\d flags -> flags { sDistDistPref = d })
         showOrParseArgs

      ,option "" ["list-sources"]
         "Just write a list of the package's sources to a file"
         sDistListSources (\v flags -> flags { sDistListSources = v })
         (reqArgFlag "FILE")

      ,option "" ["snapshot"]
         "Produce a snapshot source distribution"
         sDistSnapshot (\v flags -> flags { sDistSnapshot = v })
         trueArg

      ,option "" ["output-directory"]
       ("Generate a source distribution in the given directory, "
        ++ "without creating a tarball")
         sDistDirectory (\v flags -> flags { sDistDirectory = v })
         (reqArgFlag "DIR")
      ]
  }

emptySDistFlags :: SDistFlags
emptySDistFlags = mempty

instance Monoid SDistFlags where
  mempty = SDistFlags {
    sDistSnapshot    = mempty,
    sDistDirectory   = mempty,
    sDistDistPref    = mempty,
    sDistListSources = mempty,
    sDistVerbosity   = mempty
  }
  mappend a b = SDistFlags {
    sDistSnapshot    = combine sDistSnapshot,
    sDistDirectory   = combine sDistDirectory,
    sDistDistPref    = combine sDistDistPref,
    sDistListSources = combine sDistListSources,
    sDistVerbosity   = combine sDistVerbosity
  }
    where combine field = field a `mappend` field b

-- ------------------------------------------------------------
-- * Register flags
-- ------------------------------------------------------------

-- | Flags to @register@ and @unregister@: (user package, gen-script,
-- in-place, verbosity)
data RegisterFlags = RegisterFlags {
    regPackageDB   :: Flag PackageDB,
    regGenScript   :: Flag Bool,
    regGenPkgConf  :: Flag (Maybe FilePath),
    regInPlace     :: Flag Bool,
    regDistPref    :: Flag FilePath,
    regPrintId     :: Flag Bool,
    regVerbosity   :: Flag Verbosity
  }
  deriving Show

defaultRegisterFlags :: RegisterFlags
defaultRegisterFlags = RegisterFlags {
    regPackageDB   = NoFlag,
    regGenScript   = Flag False,
    regGenPkgConf  = NoFlag,
    regInPlace     = Flag False,
    regDistPref    = Flag defaultDistPref,
    regPrintId     = Flag False,
    regVerbosity   = Flag normal
  }

registerCommand :: CommandUI RegisterFlags
registerCommand = CommandUI
  { commandName         = "register"
  , commandSynopsis     =
      "Register this package with the compiler."
  , commandDescription  = Nothing
  , commandNotes        = Nothing
  , commandUsage        = \pname ->
      "Usage: " ++ pname ++ " register [FLAGS]\n"
  , commandDefaultFlags = defaultRegisterFlags
  , commandOptions      = \showOrParseArgs ->
      [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v })
      ,optionDistPref
         regDistPref (\d flags -> flags { regDistPref = d })
         showOrParseArgs

      ,option "" ["packageDB"] ""
         regPackageDB (\v flags -> flags { regPackageDB = v })
         (choiceOpt [ (Flag UserPackageDB, ([],["user"]),
                                "upon registration, register this package in the user's local package database")
                    , (Flag GlobalPackageDB, ([],["global"]),
                                "(default)upon registration, register this package in the system-wide package database")])

      ,option "" ["inplace"]
         "register the package in the build location, so it can be used without being installed"
         regInPlace (\v flags -> flags { regInPlace = v })
         trueArg

      ,option "" ["gen-script"]
         "instead of registering, generate a script to register later"
         regGenScript (\v flags -> flags { regGenScript = v })
         trueArg

      ,option "" ["gen-pkg-config"]
         "instead of registering, generate a package registration file"
         regGenPkgConf (\v flags -> flags { regGenPkgConf  = v })
         (optArg' "PKG" Flag flagToList)

      ,option "" ["print-ipid"]
         "print the installed package ID calculated for this package"
         regPrintId (\v flags -> flags { regPrintId = v })
         trueArg
      ]
  }

unregisterCommand :: CommandUI RegisterFlags
unregisterCommand = CommandUI
  { commandName         = "unregister"
  , commandSynopsis     =
      "Unregister this package with the compiler."
  , commandDescription  = Nothing
  , commandNotes        = Nothing
  , commandUsage        = \pname ->
      "Usage: " ++ pname ++ " unregister [FLAGS]\n"
  , commandDefaultFlags = defaultRegisterFlags
  , commandOptions      = \showOrParseArgs ->
      [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v })
      ,optionDistPref
         regDistPref (\d flags -> flags { regDistPref = d })
          showOrParseArgs

      ,option "" ["user"] ""
         regPackageDB (\v flags -> flags { regPackageDB = v })
         (choiceOpt [ (Flag UserPackageDB, ([],["user"]),
                              "unregister this package in the user's local package database")
                    , (Flag GlobalPackageDB, ([],["global"]),
                              "(default) unregister this package in the  system-wide package database")])

      ,option "" ["gen-script"]
         "Instead of performing the unregister command, generate a script to unregister later"
         regGenScript (\v flags -> flags { regGenScript = v })
         trueArg
      ]
  }

emptyRegisterFlags :: RegisterFlags
emptyRegisterFlags = mempty

instance Monoid RegisterFlags where
  mempty = RegisterFlags {
    regPackageDB   = mempty,
    regGenScript   = mempty,
    regGenPkgConf  = mempty,
    regInPlace     = mempty,
    regPrintId     = mempty,
    regDistPref    = mempty,
    regVerbosity   = mempty
  }
  mappend a b = RegisterFlags {
    regPackageDB   = combine regPackageDB,
    regGenScript   = combine regGenScript,
    regGenPkgConf  = combine regGenPkgConf,
    regInPlace     = combine regInPlace,
    regPrintId     = combine regPrintId,
    regDistPref    = combine regDistPref,
    regVerbosity   = combine regVerbosity
  }
    where combine field = field a `mappend` field b

-- ------------------------------------------------------------
-- * HsColour flags
-- ------------------------------------------------------------

data HscolourFlags = HscolourFlags {
    hscolourCSS         :: Flag FilePath,
    hscolourExecutables :: Flag Bool,
    hscolourTestSuites  :: Flag Bool,
    hscolourBenchmarks  :: Flag Bool,
    hscolourDistPref    :: Flag FilePath,
    hscolourVerbosity   :: Flag Verbosity
  }
  deriving Show

emptyHscolourFlags :: HscolourFlags
emptyHscolourFlags = mempty

defaultHscolourFlags :: HscolourFlags
defaultHscolourFlags = HscolourFlags {
    hscolourCSS         = NoFlag,
    hscolourExecutables = Flag False,
    hscolourTestSuites  = Flag False,
    hscolourBenchmarks  = Flag False,
    hscolourDistPref    = Flag defaultDistPref,
    hscolourVerbosity   = Flag normal
  }

instance Monoid HscolourFlags where
  mempty = HscolourFlags {
    hscolourCSS         = mempty,
    hscolourExecutables = mempty,
    hscolourTestSuites  = mempty,
    hscolourBenchmarks  = mempty,
    hscolourDistPref    = mempty,
    hscolourVerbosity   = mempty
  }
  mappend a b = HscolourFlags {
    hscolourCSS         = combine hscolourCSS,
    hscolourExecutables = combine hscolourExecutables,
    hscolourTestSuites  = combine hscolourTestSuites,
    hscolourBenchmarks  = combine hscolourBenchmarks,
    hscolourDistPref    = combine hscolourDistPref,
    hscolourVerbosity   = combine hscolourVerbosity
  }
    where combine field = field a `mappend` field b

hscolourCommand :: CommandUI HscolourFlags
hscolourCommand = CommandUI
  { commandName         = "hscolour"
  , commandSynopsis     =
      "Generate HsColour colourised code, in HTML format."
  , commandDescription  = Just (\_ -> "Requires the hscolour program.\n")
  , commandNotes        = Nothing
  , commandUsage        = \pname ->
      "Usage: " ++ pname ++ " hscolour [FLAGS]\n"
  , commandDefaultFlags = defaultHscolourFlags
  , commandOptions      = \showOrParseArgs ->
      [optionVerbosity hscolourVerbosity
       (\v flags -> flags { hscolourVerbosity = v })
      ,optionDistPref
         hscolourDistPref (\d flags -> flags { hscolourDistPref = d })
         showOrParseArgs

      ,option "" ["executables"]
         "Run hscolour for Executables targets"
         hscolourExecutables (\v flags -> flags { hscolourExecutables = v })
         trueArg

      ,option "" ["tests"]
         "Run hscolour for Test Suite targets"
         hscolourTestSuites (\v flags -> flags { hscolourTestSuites = v })
         trueArg

      ,option "" ["benchmarks"]
         "Run hscolour for Benchmark targets"
         hscolourBenchmarks (\v flags -> flags { hscolourBenchmarks = v })
         trueArg

      ,option "" ["all"]
         "Run hscolour for all targets"
         (\f -> allFlags [ hscolourExecutables f
                         , hscolourTestSuites  f
                         , hscolourBenchmarks  f])
         (\v flags -> flags { hscolourExecutables = v
                            , hscolourTestSuites  = v
                            , hscolourBenchmarks  = v })
         trueArg

      ,option "" ["css"]
         "Use a cascading style sheet"
         hscolourCSS (\v flags -> flags { hscolourCSS = v })
         (reqArgFlag "PATH")
      ]
  }

-- ------------------------------------------------------------
-- * Haddock flags
-- ------------------------------------------------------------

data HaddockFlags = HaddockFlags {
    haddockProgramPaths :: [(String, FilePath)],
    haddockProgramArgs  :: [(String, [String])],
    haddockHoogle       :: Flag Bool,
    haddockHtml         :: Flag Bool,
    haddockHtmlLocation :: Flag String,
    haddockExecutables  :: Flag Bool,
    haddockTestSuites   :: Flag Bool,
    haddockBenchmarks   :: Flag Bool,
    haddockInternal     :: Flag Bool,
    haddockCss          :: Flag FilePath,
    haddockHscolour     :: Flag Bool,
    haddockHscolourCss  :: Flag FilePath,
    haddockContents     :: Flag PathTemplate,
    haddockDistPref     :: Flag FilePath,
    haddockKeepTempFiles:: Flag Bool,
    haddockVerbosity    :: Flag Verbosity
  }
  deriving Show

defaultHaddockFlags :: HaddockFlags
defaultHaddockFlags  = HaddockFlags {
    haddockProgramPaths = mempty,
    haddockProgramArgs  = [],
    haddockHoogle       = Flag False,
    haddockHtml         = Flag False,
    haddockHtmlLocation = NoFlag,
    haddockExecutables  = Flag False,
    haddockTestSuites   = Flag False,
    haddockBenchmarks   = Flag False,
    haddockInternal     = Flag False,
    haddockCss          = NoFlag,
    haddockHscolour     = Flag False,
    haddockHscolourCss  = NoFlag,
    haddockContents     = NoFlag,
    haddockDistPref     = Flag defaultDistPref,
    haddockKeepTempFiles= Flag False,
    haddockVerbosity    = Flag normal
  }

haddockCommand :: CommandUI HaddockFlags
haddockCommand = CommandUI
  { commandName         = "haddock"
  , commandSynopsis     = "Generate Haddock HTML documentation."
  , commandDescription  = Just $ \_ ->
      "Requires the program haddock, version 2.x.\n"
  , commandNotes        = Nothing
  , commandUsage        = \pname ->
      "Usage: " ++ pname ++ " haddock [FLAGS]\n"
  , commandDefaultFlags = defaultHaddockFlags
  , commandOptions      = \showOrParseArgs ->
         haddockOptions showOrParseArgs
      ++ programConfigurationPaths   progConf ParseArgs
             haddockProgramPaths (\v flags -> flags { haddockProgramPaths = v})
      ++ programConfigurationOption  progConf showOrParseArgs
             haddockProgramArgs (\v fs -> fs { haddockProgramArgs = v })
      ++ programConfigurationOptions progConf ParseArgs
             haddockProgramArgs  (\v flags -> flags { haddockProgramArgs = v})
  }
  where
    progConf = addKnownProgram haddockProgram
             $ addKnownProgram ghcProgram
             $ emptyProgramConfiguration

haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags]
haddockOptions showOrParseArgs =
  [optionVerbosity haddockVerbosity
   (\v flags -> flags { haddockVerbosity = v })
  ,optionDistPref
   haddockDistPref (\d flags -> flags { haddockDistPref = d })
   showOrParseArgs

  ,option "" ["keep-temp-files"]
   "Keep temporary files"
   haddockKeepTempFiles (\b flags -> flags { haddockKeepTempFiles = b })
   trueArg

  ,option "" ["hoogle"]
   "Generate a hoogle database"
   haddockHoogle (\v flags -> flags { haddockHoogle = v })
   trueArg

  ,option "" ["html"]
   "Generate HTML documentation (the default)"
   haddockHtml (\v flags -> flags { haddockHtml = v })
   trueArg

  ,option "" ["html-location"]
   "Location of HTML documentation for pre-requisite packages"
   haddockHtmlLocation (\v flags -> flags { haddockHtmlLocation = v })
   (reqArgFlag "URL")

  ,option "" ["executables"]
   "Run haddock for Executables targets"
   haddockExecutables (\v flags -> flags { haddockExecutables = v })
   trueArg

  ,option "" ["tests"]
   "Run haddock for Test Suite targets"
   haddockTestSuites (\v flags -> flags { haddockTestSuites = v })
   trueArg

  ,option "" ["benchmarks"]
   "Run haddock for Benchmark targets"
   haddockBenchmarks (\v flags -> flags { haddockBenchmarks = v })
   trueArg

  ,option "" ["all"]
   "Run haddock for all targets"
   (\f -> allFlags [ haddockExecutables f
                   , haddockTestSuites  f
                   , haddockBenchmarks  f])
         (\v flags -> flags { haddockExecutables = v
                            , haddockTestSuites  = v
                            , haddockBenchmarks  = v })
         trueArg

  ,option "" ["internal"]
   "Run haddock for internal modules and include all symbols"
   haddockInternal (\v flags -> flags { haddockInternal = v })
   trueArg

  ,option "" ["css"]
   "Use PATH as the haddock stylesheet"
   haddockCss (\v flags -> flags { haddockCss = v })
   (reqArgFlag "PATH")

  ,option "" ["hyperlink-source","hyperlink-sources"]
   "Hyperlink the documentation to the source code (using HsColour)"
   haddockHscolour (\v flags -> flags { haddockHscolour = v })
   trueArg

  ,option "" ["hscolour-css"]
   "Use PATH as the HsColour stylesheet"
   haddockHscolourCss (\v flags -> flags { haddockHscolourCss = v })
   (reqArgFlag "PATH")

  ,option "" ["contents-location"]
   "Bake URL in as the location for the contents page"
   haddockContents (\v flags -> flags { haddockContents = v })
   (reqArg' "URL"
    (toFlag . toPathTemplate)
    (flagToList . fmap fromPathTemplate))
  ]

emptyHaddockFlags :: HaddockFlags
emptyHaddockFlags = mempty

instance Monoid HaddockFlags where
  mempty = HaddockFlags {
    haddockProgramPaths = mempty,
    haddockProgramArgs  = mempty,
    haddockHoogle       = mempty,
    haddockHtml         = mempty,
    haddockHtmlLocation = mempty,
    haddockExecutables  = mempty,
    haddockTestSuites   = mempty,
    haddockBenchmarks   = mempty,
    haddockInternal     = mempty,
    haddockCss          = mempty,
    haddockHscolour     = mempty,
    haddockHscolourCss  = mempty,
    haddockContents     = mempty,
    haddockDistPref     = mempty,
    haddockKeepTempFiles= mempty,
    haddockVerbosity    = mempty
  }
  mappend a b = HaddockFlags {
    haddockProgramPaths = combine haddockProgramPaths,
    haddockProgramArgs  = combine haddockProgramArgs,
    haddockHoogle       = combine haddockHoogle,
    haddockHtml         = combine haddockHoogle,
    haddockHtmlLocation = combine haddockHtmlLocation,
    haddockExecutables  = combine haddockExecutables,
    haddockTestSuites   = combine haddockTestSuites,
    haddockBenchmarks   = combine haddockBenchmarks,
    haddockInternal     = combine haddockInternal,
    haddockCss          = combine haddockCss,
    haddockHscolour     = combine haddockHscolour,
    haddockHscolourCss  = combine haddockHscolourCss,
    haddockContents     = combine haddockContents,
    haddockDistPref     = combine haddockDistPref,
    haddockKeepTempFiles= combine haddockKeepTempFiles,
    haddockVerbosity    = combine haddockVerbosity
  }
    where combine field = field a `mappend` field b

-- ------------------------------------------------------------
-- * Clean flags
-- ------------------------------------------------------------

data CleanFlags = CleanFlags {
    cleanSaveConf  :: Flag Bool,
    cleanDistPref  :: Flag FilePath,
    cleanVerbosity :: Flag Verbosity
  }
  deriving Show

defaultCleanFlags :: CleanFlags
defaultCleanFlags  = CleanFlags {
    cleanSaveConf  = Flag False,
    cleanDistPref  = Flag defaultDistPref,
    cleanVerbosity = Flag normal
  }

cleanCommand :: CommandUI CleanFlags
cleanCommand = CommandUI
  { commandName         = "clean"
  , commandSynopsis     = "Clean up after a build."
  , commandDescription  = Just $ \_ ->
      "Removes .hi, .o, preprocessed sources, etc.\n"
  , commandNotes        = Nothing
  , commandUsage        = \pname ->
      "Usage: " ++ pname ++ " clean [FLAGS]\n"
  , commandDefaultFlags = defaultCleanFlags
  , commandOptions      = \showOrParseArgs ->
      [optionVerbosity cleanVerbosity (\v flags -> flags { cleanVerbosity = v })
      ,optionDistPref
         cleanDistPref (\d flags -> flags { cleanDistPref = d })
         showOrParseArgs

      ,option "s" ["save-configure"]
         "Do not remove the configuration file (dist/setup-config) during cleaning.  Saves need to reconfigure."
         cleanSaveConf (\v flags -> flags { cleanSaveConf = v })
         trueArg
      ]
  }

emptyCleanFlags :: CleanFlags
emptyCleanFlags = mempty

instance Monoid CleanFlags where
  mempty = CleanFlags {
    cleanSaveConf  = mempty,
    cleanDistPref  = mempty,
    cleanVerbosity = mempty
  }
  mappend a b = CleanFlags {
    cleanSaveConf  = combine cleanSaveConf,
    cleanDistPref  = combine cleanDistPref,
    cleanVerbosity = combine cleanVerbosity
  }
    where combine field = field a `mappend` field b

-- ------------------------------------------------------------
-- * Build flags
-- ------------------------------------------------------------

data BuildFlags = BuildFlags {
    buildProgramPaths :: [(String, FilePath)],
    buildProgramArgs :: [(String, [String])],
    buildDistPref    :: Flag FilePath,
    buildVerbosity   :: Flag Verbosity,
    buildNumJobs     :: Flag (Maybe Int),
    -- TODO: this one should not be here, it's just that the silly
    -- UserHooks stop us from passing extra info in other ways
    buildArgs :: [String]
  }
  deriving Show

{-# DEPRECATED buildVerbose "Use buildVerbosity instead" #-}
buildVerbose :: BuildFlags -> Verbosity
buildVerbose = fromFlagOrDefault normal . buildVerbosity

defaultBuildFlags :: BuildFlags
defaultBuildFlags  = BuildFlags {
    buildProgramPaths = mempty,
    buildProgramArgs = [],
    buildDistPref    = Flag defaultDistPref,
    buildVerbosity   = Flag normal,
    buildNumJobs     = mempty,
    buildArgs        = []
  }

buildCommand :: ProgramConfiguration -> CommandUI BuildFlags
buildCommand progConf = CommandUI
  { commandName         = "build"
  , commandSynopsis     = "Compile all/specific components."
  , commandDescription  = Just $ \_ -> wrapText $
         "Components encompass executables, tests, and benchmarks.\n"
      ++ "\n"
      ++ "Affected by configuration options, see `configure`.\n"
  , commandNotes        = Just $ \pname ->
       "Examples:\n"
        ++ "  " ++ pname ++ " build           "
        ++ "    All the components in the package\n"
        ++ "  " ++ pname ++ " build foo       "
        ++ "    A component (i.e. lib, exe, test suite)\n\n"
        ++ programFlagsDescription progConf
--TODO: re-enable once we have support for module/file targets
--        ++ "  " ++ pname ++ " build Foo.Bar   "
--        ++ "    A module\n"
--        ++ "  " ++ pname ++ " build Foo/Bar.hs"
--        ++ "    A file\n\n"
--        ++ "If a target is ambiguous it can be qualified with the component "
--        ++ "name, e.g.\n"
--        ++ "  " ++ pname ++ " build foo:Foo.Bar\n"
--        ++ "  " ++ pname ++ " build testsuite1:Foo/Bar.hs\n"
  , commandUsage        = usageAlternatives "build" $
      [ "[FLAGS]"
      , "COMPONENTS [FLAGS]"
      ]
  , commandDefaultFlags = defaultBuildFlags
  , commandOptions      = \showOrParseArgs ->
      [ optionVerbosity
        buildVerbosity (\v flags -> flags { buildVerbosity = v })

      , optionDistPref
        buildDistPref (\d flags -> flags { buildDistPref = d }) showOrParseArgs
      ]
      ++ buildOptions progConf showOrParseArgs
  }

buildOptions :: ProgramConfiguration -> ShowOrParseArgs
                -> [OptionField BuildFlags]
buildOptions progConf showOrParseArgs =
  [ optionNumJobs
      buildNumJobs (\v flags -> flags { buildNumJobs = v })
  ]

  ++ programConfigurationPaths progConf showOrParseArgs
       buildProgramPaths (\v flags -> flags { buildProgramPaths = v})

  ++ programConfigurationOption progConf showOrParseArgs
       buildProgramArgs (\v fs -> fs { buildProgramArgs = v })

  ++ programConfigurationOptions progConf showOrParseArgs
       buildProgramArgs (\v flags -> flags { buildProgramArgs = v})

emptyBuildFlags :: BuildFlags
emptyBuildFlags = mempty

instance Monoid BuildFlags where
  mempty = BuildFlags {
    buildProgramPaths = mempty,
    buildProgramArgs = mempty,
    buildVerbosity   = mempty,
    buildDistPref    = mempty,
    buildNumJobs     = mempty,
    buildArgs        = mempty
  }
  mappend a b = BuildFlags {
    buildProgramPaths = combine buildProgramPaths,
    buildProgramArgs = combine buildProgramArgs,
    buildVerbosity   = combine buildVerbosity,
    buildDistPref    = combine buildDistPref,
    buildNumJobs     = combine buildNumJobs,
    buildArgs        = combine buildArgs
  }
    where combine field = field a `mappend` field b

-- ------------------------------------------------------------
-- * REPL Flags
-- ------------------------------------------------------------

data ReplFlags = ReplFlags {
    replProgramPaths :: [(String, FilePath)],
    replProgramArgs :: [(String, [String])],
    replDistPref    :: Flag FilePath,
    replVerbosity   :: Flag Verbosity,
    replReload      :: Flag Bool
  }
  deriving Show

defaultReplFlags :: ReplFlags
defaultReplFlags  = ReplFlags {
    replProgramPaths = mempty,
    replProgramArgs = [],
    replDistPref    = Flag defaultDistPref,
    replVerbosity   = Flag normal,
    replReload      = Flag False
  }

instance Monoid ReplFlags where
  mempty = ReplFlags {
    replProgramPaths = mempty,
    replProgramArgs = mempty,
    replVerbosity   = mempty,
    replDistPref    = mempty,
    replReload      = mempty
  }
  mappend a b = ReplFlags {
    replProgramPaths = combine replProgramPaths,
    replProgramArgs = combine replProgramArgs,
    replVerbosity   = combine replVerbosity,
    replDistPref    = combine replDistPref,
    replReload      = combine replReload
  }
    where combine field = field a `mappend` field b

replCommand :: ProgramConfiguration -> CommandUI ReplFlags
replCommand progConf = CommandUI
  { commandName         = "repl"
  , commandSynopsis     = 
      "Open an interpreter session for the given component."
  , commandDescription  = Just $ \pname -> wrapText $
         "If the current directory contains no package, ignores COMPONENT "
      ++ "parameters and opens an interactive interpreter session; if a "
      ++ "sandbox is present, its package database will be used.\n"
      ++ "\n"
      ++ "Otherwise, (re)configures with the given or default flags, and "
      ++ "loads the interpreter with the relevant modules. For executables, "
      ++ "tests and benchmarks, loads the main module (and its "
      ++ "dependencies); for libraries all exposed/other modules.\n"
      ++ "\n"
      ++ "The default component is the library itself, or the executable "
      ++ "if that is the only component.\n"
      ++ "\n"
      ++ "Support for loading specific modules is planned but not "
      ++ "implemented yet. For certain scenarios, `" ++ pname
      ++ " exec -- ghci :l Foo` may be used instead. Note that `exec` will "
      ++ "not (re)configure and you will have to specify the location of "
      ++ "other modules, if required.\n"

  , commandNotes        = Just $ \pname ->
         "Examples:\n"
      ++ "  " ++ pname ++ " repl           "
      ++ "    The first component in the package\n"
      ++ "  " ++ pname ++ " repl foo       "
      ++ "    A named component (i.e. lib, exe, test suite)\n"
      ++ "  " ++ pname ++ " repl --ghc-options=\"-lstdc++\""
      ++ "  Specifying flags for interpreter\n"
--TODO: re-enable once we have support for module/file targets
--        ++ "  " ++ pname ++ " repl Foo.Bar   "
--        ++ "    A module\n"
--        ++ "  " ++ pname ++ " repl Foo/Bar.hs"
--        ++ "    A file\n\n"
--        ++ "If a target is ambiguous it can be qualified with the component "
--        ++ "name, e.g.\n"
--        ++ "  " ++ pname ++ " repl foo:Foo.Bar\n"
--        ++ "  " ++ pname ++ " repl testsuite1:Foo/Bar.hs\n"
  , commandUsage =  \pname -> "Usage: " ++ pname ++ " repl [COMPONENT] [FLAGS]\n"
  , commandDefaultFlags = defaultReplFlags
  , commandOptions = \showOrParseArgs ->
      optionVerbosity replVerbosity (\v flags -> flags { replVerbosity = v })
      : optionDistPref
          replDistPref (\d flags -> flags { replDistPref = d })
          showOrParseArgs

      : programConfigurationPaths   progConf showOrParseArgs
          replProgramPaths (\v flags -> flags { replProgramPaths = v})

     ++ programConfigurationOption progConf showOrParseArgs
          replProgramArgs (\v flags -> flags { replProgramArgs = v})

     ++ programConfigurationOptions progConf showOrParseArgs
          replProgramArgs (\v flags -> flags { replProgramArgs = v})

     ++ case showOrParseArgs of
          ParseArgs ->
            [ option "" ["reload"]
              "Used from within an interpreter to update files."
              replReload (\v flags -> flags { replReload = v })
              trueArg
            ]
          _ -> []
  }

-- ------------------------------------------------------------
-- * Test flags
-- ------------------------------------------------------------

data TestShowDetails = Never | Failures | Always | Streaming
    deriving (Eq, Ord, Enum, Bounded, Show)

knownTestShowDetails :: [TestShowDetails]
knownTestShowDetails = [minBound..maxBound]

instance Text TestShowDetails where
    disp  = Disp.text . lowercase . show

    parse = maybe Parse.pfail return . classify =<< ident
      where
        ident        = Parse.munch1 (\c -> isAlpha c || c == '_' || c == '-')
        classify str = lookup (lowercase str) enumMap
        enumMap     :: [(String, TestShowDetails)]
        enumMap      = [ (display x, x)
                       | x <- knownTestShowDetails ]

--TODO: do we need this instance?
instance Monoid TestShowDetails where
    mempty = Never
    mappend a b = if a < b then b else a

data TestFlags = TestFlags {
    testDistPref    :: Flag FilePath,
    testVerbosity   :: Flag Verbosity,
    testHumanLog    :: Flag PathTemplate,
    testMachineLog  :: Flag PathTemplate,
    testShowDetails :: Flag TestShowDetails,
    testKeepTix     :: Flag Bool,
    -- TODO: think about if/how options are passed to test exes
    testOptions     :: [PathTemplate]
  }

defaultTestFlags :: TestFlags
defaultTestFlags  = TestFlags {
    testDistPref    = Flag defaultDistPref,
    testVerbosity   = Flag normal,
    testHumanLog    = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log",
    testMachineLog  = toFlag $ toPathTemplate $ "$pkgid.log",
    testShowDetails = toFlag Failures,
    testKeepTix     = toFlag False,
    testOptions     = []
  }

testCommand :: CommandUI TestFlags
testCommand = CommandUI
  { commandName         = "test"
  , commandSynopsis     =
      "Run all/specific tests in the test suite."
  , commandDescription  = Just $ \pname -> wrapText $
         "If necessary (re)configures with `--enable-tests` flag and builds"
      ++ " the test suite.\n"
      ++ "\n"
      ++ "Remember that the tests' dependencies must be installed if there"
      ++ " are additional ones; e.g. with `" ++ pname
      ++ " install --only-dependencies --enable-tests`.\n"
      ++ "\n"
      ++ "By defining UserHooks in a custom Setup.hs, the package can"
      ++ " define actions to be executed before and after running tests.\n"
  , commandNotes        = Nothing
  , commandUsage        = usageAlternatives "test"
      [ "[FLAGS]"
      , "TESTCOMPONENTS [FLAGS]"
      ]
  , commandDefaultFlags = defaultTestFlags
  , commandOptions = \showOrParseArgs ->
      [ optionVerbosity testVerbosity (\v flags -> flags { testVerbosity = v })
      , optionDistPref
            testDistPref (\d flags -> flags { testDistPref = d })
            showOrParseArgs
      , option [] ["log"]
            ("Log all test suite results to file (name template can use "
            ++ "$pkgid, $compiler, $os, $arch, $test-suite, $result)")
            testHumanLog (\v flags -> flags { testHumanLog = v })
            (reqArg' "TEMPLATE"
                (toFlag . toPathTemplate)
                (flagToList . fmap fromPathTemplate))
      , option [] ["machine-log"]
            ("Produce a machine-readable log file (name template can use "
            ++ "$pkgid, $compiler, $os, $arch, $result)")
            testMachineLog (\v flags -> flags { testMachineLog = v })
            (reqArg' "TEMPLATE"
                (toFlag . toPathTemplate)
                (flagToList . fmap fromPathTemplate))
      , option [] ["show-details"]
            ("'always': always show results of individual test cases. "
             ++ "'never': never show results of individual test cases. "
             ++ "'failures': show results of failing test cases. "
             ++ "'streaming': show results of test cases in real time.")
            testShowDetails (\v flags -> flags { testShowDetails = v })
            (reqArg "FILTER"
                (readP_to_E (\_ -> "--show-details flag expects one of "
                              ++ intercalate ", "
                                   (map display knownTestShowDetails))
                            (fmap toFlag parse))
                (flagToList . fmap display))
      , option [] ["keep-tix-files"]
            "keep .tix files for HPC between test runs"
            testKeepTix (\v flags -> flags { testKeepTix = v})
            trueArg
      , option [] ["test-options"]
            ("give extra options to test executables "
             ++ "(name templates can use $pkgid, $compiler, "
             ++ "$os, $arch, $test-suite)")
            testOptions (\v flags -> flags { testOptions = v })
            (reqArg' "TEMPLATES" (map toPathTemplate . splitArgs)
                (const []))
      , option [] ["test-option"]
            ("give extra option to test executables "
             ++ "(no need to quote options containing spaces, "
             ++ "name template can use $pkgid, $compiler, "
             ++ "$os, $arch, $test-suite)")
            testOptions (\v flags -> flags { testOptions = v })
            (reqArg' "TEMPLATE" (\x -> [toPathTemplate x])
                (map fromPathTemplate))
      ]
  }

emptyTestFlags :: TestFlags
emptyTestFlags  = mempty

instance Monoid TestFlags where
  mempty = TestFlags {
    testDistPref    = mempty,
    testVerbosity   = mempty,
    testHumanLog    = mempty,
    testMachineLog  = mempty,
    testShowDetails = mempty,
    testKeepTix     = mempty,
    testOptions     = mempty
  }
  mappend a b = TestFlags {
    testDistPref    = combine testDistPref,
    testVerbosity   = combine testVerbosity,
    testHumanLog    = combine testHumanLog,
    testMachineLog  = combine testMachineLog,
    testShowDetails = combine testShowDetails,
    testKeepTix     = combine testKeepTix,
    testOptions     = combine testOptions
  }
    where combine field = field a `mappend` field b

-- ------------------------------------------------------------
-- * Benchmark flags
-- ------------------------------------------------------------

data BenchmarkFlags = BenchmarkFlags {
    benchmarkDistPref  :: Flag FilePath,
    benchmarkVerbosity :: Flag Verbosity,
    benchmarkOptions   :: [PathTemplate]
  }

defaultBenchmarkFlags :: BenchmarkFlags
defaultBenchmarkFlags  = BenchmarkFlags {
    benchmarkDistPref  = Flag defaultDistPref,
    benchmarkVerbosity = Flag normal,
    benchmarkOptions   = []
  }

benchmarkCommand :: CommandUI BenchmarkFlags
benchmarkCommand = CommandUI
  { commandName         = "bench"
  , commandSynopsis     =
      "Run all/specific benchmarks."
  , commandDescription  = Just $ \pname -> wrapText $
         "If necessary (re)configures with `--enable-benchmarks` flag and"
      ++ " builds the benchmarks.\n"
      ++ "\n"
      ++ "Remember that the benchmarks' dependencies must be installed if"
      ++ " there are additional ones; e.g. with `" ++ pname
      ++ " install --only-dependencies --enable-benchmarks`.\n"
      ++ "\n"
      ++ "By defining UserHooks in a custom Setup.hs, the package can"
      ++ " define actions to be executed before and after running"
      ++ " benchmarks.\n"
  , commandNotes        = Nothing
  , commandUsage        = usageAlternatives "bench"
      [ "[FLAGS]"
      , "BENCHCOMPONENTS [FLAGS]"
      ]
  , commandDefaultFlags = defaultBenchmarkFlags
  , commandOptions = \showOrParseArgs ->
      [ optionVerbosity benchmarkVerbosity
        (\v flags -> flags { benchmarkVerbosity = v })
      , optionDistPref
            benchmarkDistPref (\d flags -> flags { benchmarkDistPref = d })
            showOrParseArgs
      , option [] ["benchmark-options"]
            ("give extra options to benchmark executables "
             ++ "(name templates can use $pkgid, $compiler, "
             ++ "$os, $arch, $benchmark)")
            benchmarkOptions (\v flags -> flags { benchmarkOptions = v })
            (reqArg' "TEMPLATES" (map toPathTemplate . splitArgs)
                (const []))
      , option [] ["benchmark-option"]
            ("give extra option to benchmark executables "
             ++ "(no need to quote options containing spaces, "
             ++ "name template can use $pkgid, $compiler, "
             ++ "$os, $arch, $benchmark)")
            benchmarkOptions (\v flags -> flags { benchmarkOptions = v })
            (reqArg' "TEMPLATE" (\x -> [toPathTemplate x])
                (map fromPathTemplate))
      ]
  }

emptyBenchmarkFlags :: BenchmarkFlags
emptyBenchmarkFlags = mempty

instance Monoid BenchmarkFlags where
  mempty = BenchmarkFlags {
    benchmarkDistPref  = mempty,
    benchmarkVerbosity = mempty,
    benchmarkOptions   = mempty
  }
  mappend a b = BenchmarkFlags {
    benchmarkDistPref  = combine benchmarkDistPref,
    benchmarkVerbosity = combine benchmarkVerbosity,
    benchmarkOptions   = combine benchmarkOptions
  }
    where combine field = field a `mappend` field b

-- ------------------------------------------------------------
-- * Shared options utils
-- ------------------------------------------------------------

programFlagsDescription :: ProgramConfiguration -> String
programFlagsDescription progConf =
     "The flags --with-PROG and --PROG-option(s) can be used with"
  ++ " the following programs:"
  ++ (concatMap (\line -> "\n  " ++ unwords line) . wrapLine 77 . sort)
     [ programName prog | (prog, _) <- knownPrograms progConf ]
  ++ "\n"

-- | For each known program @PROG@ in 'progConf', produce a @with-PROG@
-- 'OptionField'.
programConfigurationPaths
  :: ProgramConfiguration
  -> ShowOrParseArgs
  -> (flags -> [(String, FilePath)])
  -> ([(String, FilePath)] -> (flags -> flags))
  -> [OptionField flags]
programConfigurationPaths progConf showOrParseArgs get set =
  programConfigurationPaths' ("with-" ++) progConf showOrParseArgs get set

-- | Like 'programConfigurationPaths', but allows to customise the option name.
programConfigurationPaths'
  :: (String -> String)
  -> ProgramConfiguration
  -> ShowOrParseArgs
  -> (flags -> [(String, FilePath)])
  -> ([(String, FilePath)] -> (flags -> flags))
  -> [OptionField flags]
programConfigurationPaths' mkName progConf showOrParseArgs get set =
  case showOrParseArgs of
    -- we don't want a verbose help text list so we just show a generic one:
    ShowArgs  -> [withProgramPath "PROG"]
    ParseArgs -> map (withProgramPath . programName . fst)
                 (knownPrograms progConf)
  where
    withProgramPath prog =
      option "" [mkName prog]
        ("give the path to " ++ prog)
        get set
        (reqArg' "PATH" (\path -> [(prog, path)])
          (\progPaths -> [ path | (prog', path) <- progPaths, prog==prog' ]))

-- | For each known program @PROG@ in 'progConf', produce a @PROG-option@
-- 'OptionField'.
programConfigurationOption
  :: ProgramConfiguration
  -> ShowOrParseArgs
  -> (flags -> [(String, [String])])
  -> ([(String, [String])] -> (flags -> flags))
  -> [OptionField flags]
programConfigurationOption progConf showOrParseArgs get set =
  case showOrParseArgs of
    -- we don't want a verbose help text list so we just show a generic one:
    ShowArgs  -> [programOption "PROG"]
    ParseArgs -> map (programOption  . programName . fst)
                 (knownPrograms progConf)
  where
    programOption prog =
      option "" [prog ++ "-option"]
        ("give an extra option to " ++ prog ++
         " (no need to quote options containing spaces)")
        get set
        (reqArg' "OPT" (\arg -> [(prog, [arg])])
           (\progArgs -> concat [ args
                                | (prog', args) <- progArgs, prog==prog' ]))

-- | For each known program @PROG@ in 'progConf', produce a @PROG-options@
-- 'OptionField'.
programConfigurationOptions
  :: ProgramConfiguration
  -> ShowOrParseArgs
  -> (flags -> [(String, [String])])
  -> ([(String, [String])] -> (flags -> flags))
  -> [OptionField flags]
programConfigurationOptions progConf showOrParseArgs get set =
  case showOrParseArgs of
    -- we don't want a verbose help text list so we just show a generic one:
    ShowArgs  -> [programOptions  "PROG"]
    ParseArgs -> map (programOptions . programName . fst)
                 (knownPrograms progConf)
  where
    programOptions prog =
      option "" [prog ++ "-options"]
        ("give extra options to " ++ prog)
        get set
        (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) (const []))

-- ------------------------------------------------------------
-- * GetOpt Utils
-- ------------------------------------------------------------

boolOpt :: SFlags -> SFlags
           -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
boolOpt  = Command.boolOpt  flagToMaybe Flag

boolOpt' :: OptFlags -> OptFlags
            -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
boolOpt' = Command.boolOpt' flagToMaybe Flag

trueArg, falseArg :: MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
trueArg  sfT lfT = boolOpt' (sfT, lfT) ([], [])   sfT lfT
falseArg sfF lfF = boolOpt' ([],  [])  (sfF, lfF) sfF lfF

reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description ->
              (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b
reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList

optionDistPref :: (flags -> Flag FilePath)
               -> (Flag FilePath -> flags -> flags)
               -> ShowOrParseArgs
               -> OptionField flags
optionDistPref get set = \showOrParseArgs ->
  option "" (distPrefFlagName showOrParseArgs)
    (   "The directory where Cabal puts generated build files "
     ++ "(default " ++ defaultDistPref ++ ")")
    get set
    (reqArgFlag "DIR")
  where
    distPrefFlagName ShowArgs  = ["builddir"]
    distPrefFlagName ParseArgs = ["builddir", "distdir", "distpref"]

optionVerbosity :: (flags -> Flag Verbosity)
                -> (Flag Verbosity -> flags -> flags)
                -> OptionField flags
optionVerbosity get set =
  option "v" ["verbose"]
    "Control verbosity (n is 0--3, default verbosity level is 1)"
    get set
    (optArg "n" (fmap Flag flagToVerbosity)
                (Flag verbose) -- default Value if no n is given
                (fmap (Just . showForCabal) . flagToList))

optionNumJobs :: (flags -> Flag (Maybe Int))
              -> (Flag (Maybe Int) -> flags -> flags)
              -> OptionField flags
optionNumJobs get set =
  option "j" ["jobs"]
    "Run NUM jobs simultaneously (or '$ncpus' if no NUM is given)."
    get set
    (optArg "NUM" (fmap Flag numJobsParser)
                  (Flag Nothing)
                  (map (Just . maybe "$ncpus" show) . flagToList))
  where
    numJobsParser :: ReadE (Maybe Int)
    numJobsParser = ReadE $ \s ->
      case s of
        "$ncpus" -> Right Nothing
        _        -> case reads s of
          [(n, "")]
            | n < 1     -> Left "The number of jobs should be 1 or more."
            | n > 64    -> Left "You probably don't want that many jobs."
            | otherwise -> Right (Just n)
          _             -> Left "The jobs value should be a number or '$ncpus'"

-- ------------------------------------------------------------
-- * Other Utils
-- ------------------------------------------------------------

-- | Arguments to pass to a @configure@ script, e.g. generated by
-- @autoconf@.
configureArgs :: Bool -> ConfigFlags -> [String]
configureArgs bcHack flags
  = hc_flag
 ++ optFlag  "with-hc-pkg" configHcPkg
 ++ optFlag' "prefix"      prefix
 ++ optFlag' "bindir"      bindir
 ++ optFlag' "libdir"      libdir
 ++ optFlag' "libexecdir"  libexecdir
 ++ optFlag' "datadir"     datadir
 ++ optFlag' "sysconfdir"  sysconfdir
 ++ configConfigureArgs flags
  where
        hc_flag = case (configHcFlavor flags, configHcPath flags) of
                        (_, Flag hc_path) -> [hc_flag_name ++ hc_path]
                        (Flag hc, NoFlag) -> [hc_flag_name ++ display hc]
                        (NoFlag,NoFlag)   -> []
        hc_flag_name
            --TODO kill off thic bc hack when defaultUserHooks is removed.
            | bcHack    = "--with-hc="
            | otherwise = "--with-compiler="
        optFlag name config_field = case config_field flags of
                        Flag p -> ["--" ++ name ++ "=" ++ p]
                        NoFlag -> []
        optFlag' name config_field = optFlag name (fmap fromPathTemplate
                                                 . config_field
                                                 . configInstallDirs)

configureCCompiler :: Verbosity -> ProgramConfiguration
                      -> IO (FilePath, [String])
configureCCompiler verbosity lbi = configureProg verbosity lbi gccProgram

configureLinker :: Verbosity -> ProgramConfiguration -> IO (FilePath, [String])
configureLinker verbosity lbi = configureProg verbosity lbi ldProgram

configureProg :: Verbosity -> ProgramConfiguration -> Program
                 -> IO (FilePath, [String])
configureProg verbosity programConfig prog = do
    (p, _) <- requireProgram verbosity prog programConfig
    let pInv = programInvocation p []
    return (progInvokePath pInv, progInvokeArgs pInv)

-- | Helper function to split a string into a list of arguments.
-- It's supposed to handle quoted things sensibly, eg:
--
-- > splitArgs "--foo=\"C:\Program Files\Bar\" --baz"
-- >   = ["--foo=C:\Program Files\Bar", "--baz"]
--
splitArgs :: String -> [String]
splitArgs  = space []
  where
    space :: String -> String -> [String]
    space w []      = word w []
    space w ( c :s)
        | isSpace c = word w (space [] s)
    space w ('"':s) = string w s
    space w s       = nonstring w s

    string :: String -> String -> [String]
    string w []      = word w []
    string w ('"':s) = space w s
    string w ( c :s) = string (c:w) s

    nonstring :: String -> String -> [String]
    nonstring w  []      = word w []
    nonstring w  ('"':s) = string w s
    nonstring w  ( c :s) = space (c:w) s

    word [] s = s
    word w  s = reverse w : s

-- The test cases kinda have to be rewritten from the ground up... :/
--hunitTests :: [Test]
--hunitTests =
--    let m = [("ghc", GHC), ("nhc98", NHC), ("hugs", Hugs)]
--        (flags, commands', unkFlags, ers)
--               = getOpt Permute options ["configure", "foobar", "--prefix=/foo", "--ghc", "--nhc98", "--hugs", "--with-compiler=/comp", "--unknown1", "--unknown2", "--install-prefix=/foo", "--user", "--global"]
--       in  [TestLabel "very basic option parsing" $ TestList [
--                 "getOpt flags" ~: "failed" ~:
--                 [Prefix "/foo", GhcFlag, NhcFlag, HugsFlag,
--                  WithCompiler "/comp", InstPrefix "/foo", UserFlag, GlobalFlag]
--                 ~=? flags,
--                 "getOpt commands" ~: "failed" ~: ["configure", "foobar"] ~=? commands',
--                 "getOpt unknown opts" ~: "failed" ~:
--                      ["--unknown1", "--unknown2"] ~=? unkFlags,
--                 "getOpt errors" ~: "failed" ~: [] ~=? ers],
--
--               TestLabel "test location of various compilers" $ TestList
--               ["configure parsing for prefix and compiler flag" ~: "failed" ~:
--                    (Right (ConfigCmd (Just comp, Nothing, Just "/usr/local"), []))
--                   ~=? (parseArgs ["--prefix=/usr/local", "--"++name, "configure"])
--                   | (name, comp) <- m],
--
--               TestLabel "find the package tool" $ TestList
--               ["configure parsing for prefix comp flag, withcompiler" ~: "failed" ~:
--                    (Right (ConfigCmd (Just comp, Just "/foo/comp", Just "/usr/local"), []))
--                   ~=? (parseArgs ["--prefix=/usr/local", "--"++name,
--                                   "--with-compiler=/foo/comp", "configure"])
--                   | (name, comp) <- m],
--
--               TestLabel "simpler commands" $ TestList
--               [flag ~: "failed" ~: (Right (flagCmd, [])) ~=? (parseArgs [flag])
--                   | (flag, flagCmd) <- [("build", BuildCmd),
--                                         ("install", InstallCmd Nothing False),
--                                         ("sdist", SDistCmd),
--                                         ("register", RegisterCmd False)]
--                  ]
--               ]

{- Testing ideas:
   * IO to look for hugs and hugs-pkg (which hugs, etc)
   * quickCheck to test permutations of arguments
   * what other options can we over-ride with a command-line flag?
-}