{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}

-----------------------------------------------------------------------------

-- |
-- Module      :  Distribution.Simple.Setup.Common
-- Copyright   :  Isaac Jones 2003-2004
--                Duncan Coutts 2007
-- License     :  BSD3
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- Common utilities for defining command-line options.
-- See: @Distribution.Simple.Setup@
module Distribution.Simple.Setup.Common
  ( CommonSetupFlags (..)
  , defaultCommonSetupFlags
  , withCommonSetupOptions
  , CopyDest (..)
  , configureCCompiler
  , configureLinker
  , programDbOption
  , programDbOptions
  , programDbPaths
  , programDbPaths'
  , programFlagsDescription
  , splitArgs
  , testOrBenchmarkHelpText
  , defaultDistPref
  , extraCompilationArtifacts
  , optionDistPref
  , Flag (..)
  , toFlag
  , fromFlag
  , fromFlagOrDefault
  , flagToMaybe
  , flagToList
  , maybeToFlag
  , BooleanFlag (..)
  , boolOpt
  , boolOpt'
  , trueArg
  , falseArg
  , reqArgFlag
  , reqSymbolicPathArgFlag
  , optionVerbosity
  , optionNumJobs
  ) where

import Distribution.Compat.Prelude hiding (get)
import Prelude ()

import Distribution.ReadE
import Distribution.Simple.Command hiding (boolOpt, boolOpt')
import qualified Distribution.Simple.Command as Command
import Distribution.Simple.Flag
import Distribution.Simple.InstallDirs
import Distribution.Simple.Program
import Distribution.Simple.Utils
import Distribution.Utils.Path
import Distribution.Verbosity

--------------------------------------------------------------------------------

-- | A datatype that stores common flags for different invocations
-- of a @Setup@ executable, e.g. configure, build, install.
data CommonSetupFlags = CommonSetupFlags
  { CommonSetupFlags -> Flag Verbosity
setupVerbosity :: !(Flag Verbosity)
  -- ^ Verbosity
  , CommonSetupFlags -> Flag (SymbolicPath CWD ('Dir Pkg))
setupWorkingDir :: !(Flag (SymbolicPath CWD (Dir Pkg)))
  -- ^ Working directory (optional)
  , CommonSetupFlags -> Flag (SymbolicPath Pkg ('Dir Dist))
setupDistPref :: !(Flag (SymbolicPath Pkg (Dir Dist)))
  -- ^ Build directory
  , CommonSetupFlags -> Flag (SymbolicPath Pkg 'File)
setupCabalFilePath :: !(Flag (SymbolicPath Pkg File))
  -- ^ Which Cabal file to use (optional)
  , CommonSetupFlags -> [String]
setupTargets :: [String]
  -- ^ Which targets is this Setup invocation relative to?
  --
  -- TODO: this one should not be here, it's just that the silly
  -- UserHooks stop us from passing extra info in other ways
  }
  deriving (CommonSetupFlags -> CommonSetupFlags -> Bool
(CommonSetupFlags -> CommonSetupFlags -> Bool)
-> (CommonSetupFlags -> CommonSetupFlags -> Bool)
-> Eq CommonSetupFlags
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CommonSetupFlags -> CommonSetupFlags -> Bool
== :: CommonSetupFlags -> CommonSetupFlags -> Bool
$c/= :: CommonSetupFlags -> CommonSetupFlags -> Bool
/= :: CommonSetupFlags -> CommonSetupFlags -> Bool
Eq, Int -> CommonSetupFlags -> ShowS
[CommonSetupFlags] -> ShowS
CommonSetupFlags -> String
(Int -> CommonSetupFlags -> ShowS)
-> (CommonSetupFlags -> String)
-> ([CommonSetupFlags] -> ShowS)
-> Show CommonSetupFlags
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CommonSetupFlags -> ShowS
showsPrec :: Int -> CommonSetupFlags -> ShowS
$cshow :: CommonSetupFlags -> String
show :: CommonSetupFlags -> String
$cshowList :: [CommonSetupFlags] -> ShowS
showList :: [CommonSetupFlags] -> ShowS
Show, ReadPrec [CommonSetupFlags]
ReadPrec CommonSetupFlags
Int -> ReadS CommonSetupFlags
ReadS [CommonSetupFlags]
(Int -> ReadS CommonSetupFlags)
-> ReadS [CommonSetupFlags]
-> ReadPrec CommonSetupFlags
-> ReadPrec [CommonSetupFlags]
-> Read CommonSetupFlags
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS CommonSetupFlags
readsPrec :: Int -> ReadS CommonSetupFlags
$creadList :: ReadS [CommonSetupFlags]
readList :: ReadS [CommonSetupFlags]
$creadPrec :: ReadPrec CommonSetupFlags
readPrec :: ReadPrec CommonSetupFlags
$creadListPrec :: ReadPrec [CommonSetupFlags]
readListPrec :: ReadPrec [CommonSetupFlags]
Read, (forall x. CommonSetupFlags -> Rep CommonSetupFlags x)
-> (forall x. Rep CommonSetupFlags x -> CommonSetupFlags)
-> Generic CommonSetupFlags
forall x. Rep CommonSetupFlags x -> CommonSetupFlags
forall x. CommonSetupFlags -> Rep CommonSetupFlags x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CommonSetupFlags -> Rep CommonSetupFlags x
from :: forall x. CommonSetupFlags -> Rep CommonSetupFlags x
$cto :: forall x. Rep CommonSetupFlags x -> CommonSetupFlags
to :: forall x. Rep CommonSetupFlags x -> CommonSetupFlags
Generic)

instance Binary CommonSetupFlags
instance Structured CommonSetupFlags

instance Semigroup CommonSetupFlags where
  <> :: CommonSetupFlags -> CommonSetupFlags -> CommonSetupFlags
(<>) = CommonSetupFlags -> CommonSetupFlags -> CommonSetupFlags
forall a. (Generic a, GSemigroup (Rep a)) => a -> a -> a
gmappend

instance Monoid CommonSetupFlags where
  mempty :: CommonSetupFlags
mempty = CommonSetupFlags
forall a. (Generic a, GMonoid (Rep a)) => a
gmempty
  mappend :: CommonSetupFlags -> CommonSetupFlags -> CommonSetupFlags
mappend = CommonSetupFlags -> CommonSetupFlags -> CommonSetupFlags
forall a. Semigroup a => a -> a -> a
(<>)

defaultCommonSetupFlags :: CommonSetupFlags
defaultCommonSetupFlags :: CommonSetupFlags
defaultCommonSetupFlags =
  CommonSetupFlags
    { setupVerbosity :: Flag Verbosity
setupVerbosity = Verbosity -> Flag Verbosity
forall a. a -> Flag a
Flag Verbosity
normal
    , setupWorkingDir :: Flag (SymbolicPath CWD ('Dir Pkg))
setupWorkingDir = Flag (SymbolicPath CWD ('Dir Pkg))
forall a. Flag a
NoFlag
    , setupDistPref :: Flag (SymbolicPath Pkg ('Dir Dist))
setupDistPref = Flag (SymbolicPath Pkg ('Dir Dist))
forall a. Flag a
NoFlag
    , setupCabalFilePath :: Flag (SymbolicPath Pkg 'File)
setupCabalFilePath = Flag (SymbolicPath Pkg 'File)
forall a. Flag a
NoFlag
    , setupTargets :: [String]
setupTargets = []
    }

commonSetupOptions :: ShowOrParseArgs -> [OptionField CommonSetupFlags]
commonSetupOptions :: ShowOrParseArgs -> [OptionField CommonSetupFlags]
commonSetupOptions ShowOrParseArgs
showOrParseArgs =
  [ (CommonSetupFlags -> Flag Verbosity)
-> (Flag Verbosity -> CommonSetupFlags -> CommonSetupFlags)
-> OptionField CommonSetupFlags
forall flags.
(flags -> Flag Verbosity)
-> (Flag Verbosity -> flags -> flags) -> OptionField flags
optionVerbosity
      CommonSetupFlags -> Flag Verbosity
setupVerbosity
      (\Flag Verbosity
v CommonSetupFlags
flags -> CommonSetupFlags
flags{setupVerbosity = v})
  , (CommonSetupFlags -> Flag (SymbolicPath Pkg ('Dir Dist)))
-> (Flag (SymbolicPath Pkg ('Dir Dist))
    -> CommonSetupFlags -> CommonSetupFlags)
-> ShowOrParseArgs
-> OptionField CommonSetupFlags
forall flags.
(flags -> Flag (SymbolicPath Pkg ('Dir Dist)))
-> (Flag (SymbolicPath Pkg ('Dir Dist)) -> flags -> flags)
-> ShowOrParseArgs
-> OptionField flags
optionDistPref
      CommonSetupFlags -> Flag (SymbolicPath Pkg ('Dir Dist))
setupDistPref
      (\Flag (SymbolicPath Pkg ('Dir Dist))
d CommonSetupFlags
flags -> CommonSetupFlags
flags{setupDistPref = d})
      ShowOrParseArgs
showOrParseArgs
  , String
-> [String]
-> String
-> (CommonSetupFlags -> Flag (SymbolicPath Pkg 'File))
-> (Flag (SymbolicPath Pkg 'File)
    -> CommonSetupFlags -> CommonSetupFlags)
-> MkOptDescr
     (CommonSetupFlags -> Flag (SymbolicPath Pkg 'File))
     (Flag (SymbolicPath Pkg 'File)
      -> CommonSetupFlags -> CommonSetupFlags)
     CommonSetupFlags
-> OptionField CommonSetupFlags
forall get set a.
String
-> [String]
-> String
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option
      String
""
      [String
"cabal-file"]
      String
"use this Cabal file"
      CommonSetupFlags -> Flag (SymbolicPath Pkg 'File)
setupCabalFilePath
      (\Flag (SymbolicPath Pkg 'File)
v CommonSetupFlags
flags -> CommonSetupFlags
flags{setupCabalFilePath = v})
      (String
-> MkOptDescr
     (CommonSetupFlags -> Flag (SymbolicPath Pkg 'File))
     (Flag (SymbolicPath Pkg 'File)
      -> CommonSetupFlags -> CommonSetupFlags)
     CommonSetupFlags
forall b from (to :: FileOrDir).
String
-> String
-> [String]
-> String
-> (b -> Flag (SymbolicPath from to))
-> (Flag (SymbolicPath from to) -> b -> b)
-> OptDescr b
reqSymbolicPathArgFlag String
"PATH")
      -- NB: no --working-dir flag, as that value is populated using the
      -- global flag (see Distribution.Simple.Setup.Global.globalCommand).
  ]

withCommonSetupOptions
  :: (flags -> CommonSetupFlags)
  -> (CommonSetupFlags -> flags -> flags)
  -> ShowOrParseArgs
  -> [OptionField flags]
  -> [OptionField flags]
withCommonSetupOptions :: forall flags.
(flags -> CommonSetupFlags)
-> (CommonSetupFlags -> flags -> flags)
-> ShowOrParseArgs
-> [OptionField flags]
-> [OptionField flags]
withCommonSetupOptions flags -> CommonSetupFlags
getCommon CommonSetupFlags -> flags -> flags
setCommon ShowOrParseArgs
showOrParseArgs [OptionField flags]
opts =
  (OptionField CommonSetupFlags -> OptionField flags)
-> [OptionField CommonSetupFlags] -> [OptionField flags]
forall a b. (a -> b) -> [a] -> [b]
map OptionField CommonSetupFlags -> OptionField flags
fmapOptionField (ShowOrParseArgs -> [OptionField CommonSetupFlags]
commonSetupOptions ShowOrParseArgs
showOrParseArgs) [OptionField flags] -> [OptionField flags] -> [OptionField flags]
forall a. [a] -> [a] -> [a]
++ [OptionField flags]
opts
  where
    fmapOptionField :: OptionField CommonSetupFlags -> OptionField flags
fmapOptionField (OptionField String
nm [OptDescr CommonSetupFlags]
descr) =
      String -> [OptDescr flags] -> OptionField flags
forall a. String -> [OptDescr a] -> OptionField a
OptionField String
nm ((OptDescr CommonSetupFlags -> OptDescr flags)
-> [OptDescr CommonSetupFlags] -> [OptDescr flags]
forall a b. (a -> b) -> [a] -> [b]
map ((flags -> CommonSetupFlags)
-> (CommonSetupFlags -> flags -> flags)
-> OptDescr CommonSetupFlags
-> OptDescr flags
forall a b. (b -> a) -> (a -> b -> b) -> OptDescr a -> OptDescr b
fmapOptDescr flags -> CommonSetupFlags
getCommon CommonSetupFlags -> flags -> flags
setCommon) [OptDescr CommonSetupFlags]
descr)

--------------------------------------------------------------------------------

-- FIXME Not sure where this should live
defaultDistPref :: SymbolicPath Pkg (Dir Dist)
defaultDistPref :: SymbolicPath Pkg ('Dir Dist)
defaultDistPref = String -> SymbolicPath Pkg ('Dir Dist)
forall from (to :: FileOrDir). String -> SymbolicPath from to
makeSymbolicPath String
"dist"

-- | The name of the directory where optional compilation artifacts
-- go, such as ghc plugins and .hie files.
extraCompilationArtifacts :: RelativePath Build (Dir Artifacts)
extraCompilationArtifacts :: RelativePath Build ('Dir Artifacts)
extraCompilationArtifacts = String -> RelativePath Build ('Dir Artifacts)
forall from (to :: FileOrDir).
HasCallStack =>
String -> RelativePath from to
makeRelativePathEx String
"extra-compilation-artifacts"

-- | Help text for @test@ and @bench@ commands.
testOrBenchmarkHelpText
  :: String
  -- ^ Either @"test"@ or @"benchmark"@.
  -> String
  -- ^ Help text.
testOrBenchmarkHelpText :: ShowS
testOrBenchmarkHelpText String
s =
  [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
    ([String] -> String) -> [[String]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map
      [String] -> String
unwords
      [
        [ String
"The package must have been build with configuration"
        , [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"flag `--enable-", String
s, String
"s`."]
        ]
      , [] -- blank line
      ,
        [ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"Note that additional dependencies of the ", String
s, String
"s"]
        , String
"must have already been installed."
        ]
      , []
      ,
        [ String
"By defining UserHooks in a custom Setup.hs, the package can define"
        , [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"actions to be executed before and after running ", String
s, String
"s."]
        ]
      ]

-- ------------------------------------------------------------

-- * Shared options utils

-- ------------------------------------------------------------

programFlagsDescription :: ProgramDb -> String
programFlagsDescription :: ProgramDb -> String
programFlagsDescription ProgramDb
progDb =
  String
"The flags --with-PROG and --PROG-option(s) can be used with"
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" the following programs:"
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ (([String] -> String) -> [[String]] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\[String]
line -> String
"\n  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
line) ([[String]] -> String)
-> ([String] -> [[String]]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [String] -> [[String]]
wrapLine Int
77 ([String] -> [[String]])
-> ([String] -> [String]) -> [String] -> [[String]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. Ord a => [a] -> [a]
sort)
      [Program -> String
programName Program
prog | (Program
prog, Maybe ConfiguredProgram
_) <- ProgramDb -> [(Program, Maybe ConfiguredProgram)]
knownPrograms ProgramDb
progDb]
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"

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

-- | Like 'programDbPaths', but allows to customise the option name.
programDbPaths'
  :: (String -> String)
  -> ProgramDb
  -> ShowOrParseArgs
  -> (flags -> [(String, FilePath)])
  -> ([(String, FilePath)] -> (flags -> flags))
  -> [OptionField flags]
programDbPaths' :: forall flags.
ShowS
-> ProgramDb
-> ShowOrParseArgs
-> (flags -> [(String, String)])
-> ([(String, String)] -> flags -> flags)
-> [OptionField flags]
programDbPaths' ShowS
mkName ProgramDb
progDb ShowOrParseArgs
showOrParseArgs flags -> [(String, String)]
get [(String, String)] -> flags -> flags
set =
  case ShowOrParseArgs
showOrParseArgs of
    -- we don't want a verbose help text list so we just show a generic one:
    ShowOrParseArgs
ShowArgs -> [String -> OptionField flags
withProgramPath String
"PROG"]
    ShowOrParseArgs
ParseArgs ->
      ((Program, Maybe ConfiguredProgram) -> OptionField flags)
-> [(Program, Maybe ConfiguredProgram)] -> [OptionField flags]
forall a b. (a -> b) -> [a] -> [b]
map
        (String -> OptionField flags
withProgramPath (String -> OptionField flags)
-> ((Program, Maybe ConfiguredProgram) -> String)
-> (Program, Maybe ConfiguredProgram)
-> OptionField flags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Program -> String
programName (Program -> String)
-> ((Program, Maybe ConfiguredProgram) -> Program)
-> (Program, Maybe ConfiguredProgram)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Program, Maybe ConfiguredProgram) -> Program
forall a b. (a, b) -> a
fst)
        (ProgramDb -> [(Program, Maybe ConfiguredProgram)]
knownPrograms ProgramDb
progDb)
  where
    withProgramPath :: String -> OptionField flags
withProgramPath String
prog =
      String
-> [String]
-> String
-> (flags -> [(String, String)])
-> ([(String, String)] -> flags -> flags)
-> MkOptDescr
     (flags -> [(String, String)])
     ([(String, String)] -> flags -> flags)
     flags
-> OptionField flags
forall get set a.
String
-> [String]
-> String
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option
        String
""
        [ShowS
mkName String
prog]
        (String
"give the path to " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
prog)
        flags -> [(String, String)]
get
        [(String, String)] -> flags -> flags
set
        ( String
-> (String -> [(String, String)])
-> ([(String, String)] -> [String])
-> MkOptDescr
     (flags -> [(String, String)])
     ([(String, String)] -> flags -> flags)
     flags
forall b a.
Monoid b =>
String
-> (String -> b)
-> (b -> [String])
-> MkOptDescr (a -> b) (b -> a -> a) a
reqArg'
            String
"PATH"
            (\String
path -> [(String
prog, String
path)])
            (\[(String, String)]
progPaths -> [String
path | (String
prog', String
path) <- [(String, String)]
progPaths, String
prog String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
prog'])
        )

-- | For each known program @PROG@ in 'progDb', produce a @PROG-option@
-- 'OptionField'.
programDbOption
  :: ProgramDb
  -> ShowOrParseArgs
  -> (flags -> [(String, [String])])
  -> ([(String, [String])] -> (flags -> flags))
  -> [OptionField flags]
programDbOption :: forall flags.
ProgramDb
-> ShowOrParseArgs
-> (flags -> [(String, [String])])
-> ([(String, [String])] -> flags -> flags)
-> [OptionField flags]
programDbOption ProgramDb
progDb ShowOrParseArgs
showOrParseArgs flags -> [(String, [String])]
get [(String, [String])] -> flags -> flags
set =
  case ShowOrParseArgs
showOrParseArgs of
    -- we don't want a verbose help text list so we just show a generic one:
    ShowOrParseArgs
ShowArgs -> [String -> OptionField flags
programOption String
"PROG"]
    ShowOrParseArgs
ParseArgs ->
      ((Program, Maybe ConfiguredProgram) -> OptionField flags)
-> [(Program, Maybe ConfiguredProgram)] -> [OptionField flags]
forall a b. (a -> b) -> [a] -> [b]
map
        (String -> OptionField flags
programOption (String -> OptionField flags)
-> ((Program, Maybe ConfiguredProgram) -> String)
-> (Program, Maybe ConfiguredProgram)
-> OptionField flags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Program -> String
programName (Program -> String)
-> ((Program, Maybe ConfiguredProgram) -> Program)
-> (Program, Maybe ConfiguredProgram)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Program, Maybe ConfiguredProgram) -> Program
forall a b. (a, b) -> a
fst)
        (ProgramDb -> [(Program, Maybe ConfiguredProgram)]
knownPrograms ProgramDb
progDb)
  where
    programOption :: String -> OptionField flags
programOption String
prog =
      String
-> [String]
-> String
-> (flags -> [(String, [String])])
-> ([(String, [String])] -> flags -> flags)
-> MkOptDescr
     (flags -> [(String, [String])])
     ([(String, [String])] -> flags -> flags)
     flags
-> OptionField flags
forall get set a.
String
-> [String]
-> String
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option
        String
""
        [String
prog String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-option"]
        ( String
"give an extra option to "
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
prog
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (no need to quote options containing spaces)"
        )
        flags -> [(String, [String])]
get
        [(String, [String])] -> flags -> flags
set
        ( String
-> (String -> [(String, [String])])
-> ([(String, [String])] -> [String])
-> MkOptDescr
     (flags -> [(String, [String])])
     ([(String, [String])] -> flags -> flags)
     flags
forall b a.
Monoid b =>
String
-> (String -> b)
-> (b -> [String])
-> MkOptDescr (a -> b) (b -> a -> a) a
reqArg'
            String
"OPT"
            (\String
arg -> [(String
prog, [String
arg])])
            ( \[(String, [String])]
progArgs ->
                [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                  [ [String]
args
                  | (String
prog', [String]
args) <- [(String, [String])]
progArgs
                  , String
prog String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
prog'
                  ]
            )
        )

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

-- ------------------------------------------------------------

-- * GetOpt Utils

-- ------------------------------------------------------------

boolOpt
  :: SFlags
  -> SFlags
  -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
boolOpt :: forall a.
String
-> String -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
boolOpt = (Flag Bool -> Maybe Bool)
-> (Bool -> Flag Bool)
-> String
-> String
-> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
forall b a.
(b -> Maybe Bool)
-> (Bool -> b)
-> String
-> String
-> MkOptDescr (a -> b) (b -> a -> a) a
Command.boolOpt Flag Bool -> Maybe Bool
forall a. Flag a -> Maybe a
flagToMaybe Bool -> Flag Bool
forall a. a -> Flag a
Flag

boolOpt'
  :: OptFlags
  -> OptFlags
  -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
boolOpt' :: forall a.
(String, [String])
-> (String, [String])
-> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
boolOpt' = (Flag Bool -> Maybe Bool)
-> (Bool -> Flag Bool)
-> (String, [String])
-> (String, [String])
-> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
forall b a.
(b -> Maybe Bool)
-> (Bool -> b)
-> (String, [String])
-> (String, [String])
-> MkOptDescr (a -> b) (b -> a -> a) a
Command.boolOpt' Flag Bool -> Maybe Bool
forall a. Flag a -> Maybe a
flagToMaybe Bool -> Flag Bool
forall a. a -> Flag a
Flag

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

reqArgFlag
  :: ArgPlaceHolder
  -> SFlags
  -> LFlags
  -> Description
  -> (b -> Flag String)
  -> (Flag String -> b -> b)
  -> OptDescr b
reqArgFlag :: forall b.
String
-> String
-> [String]
-> String
-> (b -> Flag String)
-> (Flag String -> b -> b)
-> OptDescr b
reqArgFlag String
ad = String
-> ReadE (Flag String)
-> (Flag String -> [String])
-> MkOptDescr (b -> Flag String) (Flag String -> b -> b) b
forall b a.
Monoid b =>
String
-> ReadE b
-> (b -> [String])
-> MkOptDescr (a -> b) (b -> a -> a) a
reqArg String
ad ((String -> Flag String) -> ReadE (Flag String)
forall a. (String -> a) -> ReadE a
succeedReadE String -> Flag String
forall a. a -> Flag a
Flag) Flag String -> [String]
forall a. Flag a -> [a]
flagToList

optionDistPref
  :: (flags -> Flag (SymbolicPath Pkg (Dir Dist)))
  -> (Flag (SymbolicPath Pkg (Dir Dist)) -> flags -> flags)
  -> ShowOrParseArgs
  -> OptionField flags
optionDistPref :: forall flags.
(flags -> Flag (SymbolicPath Pkg ('Dir Dist)))
-> (Flag (SymbolicPath Pkg ('Dir Dist)) -> flags -> flags)
-> ShowOrParseArgs
-> OptionField flags
optionDistPref flags -> Flag (SymbolicPath Pkg ('Dir Dist))
get Flag (SymbolicPath Pkg ('Dir Dist)) -> flags -> flags
set = \ShowOrParseArgs
showOrParseArgs ->
  String
-> [String]
-> String
-> (flags -> Flag (SymbolicPath Pkg ('Dir Dist)))
-> (Flag (SymbolicPath Pkg ('Dir Dist)) -> flags -> flags)
-> MkOptDescr
     (flags -> Flag (SymbolicPath Pkg ('Dir Dist)))
     (Flag (SymbolicPath Pkg ('Dir Dist)) -> flags -> flags)
     flags
-> OptionField flags
forall get set a.
String
-> [String]
-> String
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option
    String
""
    (ShowOrParseArgs -> [String]
distPrefFlagName ShowOrParseArgs
showOrParseArgs)
    ( String
"The directory where Cabal puts generated build files "
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"(default "
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ SymbolicPath Pkg ('Dir Dist) -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath SymbolicPath Pkg ('Dir Dist)
defaultDistPref
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
    )
    flags -> Flag (SymbolicPath Pkg ('Dir Dist))
get
    Flag (SymbolicPath Pkg ('Dir Dist)) -> flags -> flags
set
    (String
-> MkOptDescr
     (flags -> Flag (SymbolicPath Pkg ('Dir Dist)))
     (Flag (SymbolicPath Pkg ('Dir Dist)) -> flags -> flags)
     flags
forall b from (to :: FileOrDir).
String
-> String
-> [String]
-> String
-> (b -> Flag (SymbolicPath from to))
-> (Flag (SymbolicPath from to) -> b -> b)
-> OptDescr b
reqSymbolicPathArgFlag String
"DIR")
  where
    distPrefFlagName :: ShowOrParseArgs -> [String]
distPrefFlagName ShowOrParseArgs
ShowArgs = [String
"builddir"]
    distPrefFlagName ShowOrParseArgs
ParseArgs = [String
"builddir", String
"distdir", String
"distpref"]

reqSymbolicPathArgFlag
  :: ArgPlaceHolder
  -> SFlags
  -> LFlags
  -> Description
  -> (b -> Flag (SymbolicPath from to))
  -> (Flag (SymbolicPath from to) -> b -> b)
  -> OptDescr b
reqSymbolicPathArgFlag :: forall b from (to :: FileOrDir).
String
-> String
-> [String]
-> String
-> (b -> Flag (SymbolicPath from to))
-> (Flag (SymbolicPath from to) -> b -> b)
-> OptDescr b
reqSymbolicPathArgFlag String
title String
sf [String]
lf String
d b -> Flag (SymbolicPath from to)
get Flag (SymbolicPath from to) -> b -> b
set =
  String
-> String
-> [String]
-> String
-> (b -> Flag String)
-> (Flag String -> b -> b)
-> OptDescr b
forall b.
String
-> String
-> [String]
-> String
-> (b -> Flag String)
-> (Flag String -> b -> b)
-> OptDescr b
reqArgFlag
    String
title
    String
sf
    [String]
lf
    String
d
    ((SymbolicPath from to -> String)
-> Flag (SymbolicPath from to) -> Flag String
forall a b. (a -> b) -> Flag a -> Flag b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SymbolicPath from to -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath (Flag (SymbolicPath from to) -> Flag String)
-> (b -> Flag (SymbolicPath from to)) -> b -> Flag String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Flag (SymbolicPath from to)
get)
    (Flag (SymbolicPath from to) -> b -> b
set (Flag (SymbolicPath from to) -> b -> b)
-> (Flag String -> Flag (SymbolicPath from to))
-> Flag String
-> b
-> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> SymbolicPath from to)
-> Flag String -> Flag (SymbolicPath from to)
forall a b. (a -> b) -> Flag a -> Flag b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> SymbolicPath from to
forall from (to :: FileOrDir). String -> SymbolicPath from to
makeSymbolicPath)

optionVerbosity
  :: (flags -> Flag Verbosity)
  -> (Flag Verbosity -> flags -> flags)
  -> OptionField flags
optionVerbosity :: forall flags.
(flags -> Flag Verbosity)
-> (Flag Verbosity -> flags -> flags) -> OptionField flags
optionVerbosity flags -> Flag Verbosity
get Flag Verbosity -> flags -> flags
set =
  String
-> [String]
-> String
-> (flags -> Flag Verbosity)
-> (Flag Verbosity -> flags -> flags)
-> MkOptDescr
     (flags -> Flag Verbosity) (Flag Verbosity -> flags -> flags) flags
-> OptionField flags
forall get set a.
String
-> [String]
-> String
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option
    String
"v"
    [String
"verbose"]
    String
"Control verbosity (n is 0--3, default verbosity level is 1)"
    flags -> Flag Verbosity
get
    Flag Verbosity -> flags -> flags
set
    ( String
-> ReadE (Flag Verbosity)
-> (String, Flag Verbosity)
-> (Flag Verbosity -> [Maybe String])
-> MkOptDescr
     (flags -> Flag Verbosity) (Flag Verbosity -> flags -> flags) flags
forall b a.
Monoid b =>
String
-> ReadE b
-> (String, b)
-> (b -> [Maybe String])
-> MkOptDescr (a -> b) (b -> a -> a) a
optArg
        String
"n"
        ((Verbosity -> Flag Verbosity)
-> ReadE Verbosity -> ReadE (Flag Verbosity)
forall a b. (a -> b) -> ReadE a -> ReadE b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Verbosity -> Flag Verbosity
forall a. a -> Flag a
Flag ReadE Verbosity
flagToVerbosity)
        (Verbosity -> String
forall a. Show a => a -> String
show Verbosity
verbose, Verbosity -> Flag Verbosity
forall a. a -> Flag a
Flag Verbosity
verbose) -- default Value if no n is given
        ((Verbosity -> Maybe String) -> [Verbosity] -> [Maybe String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> (Verbosity -> String) -> Verbosity -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> String
showForCabal) ([Verbosity] -> [Maybe String])
-> (Flag Verbosity -> [Verbosity])
-> Flag Verbosity
-> [Maybe String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag Verbosity -> [Verbosity]
forall a. Flag a -> [a]
flagToList)
    )

optionNumJobs
  :: (flags -> Flag (Maybe Int))
  -> (Flag (Maybe Int) -> flags -> flags)
  -> OptionField flags
optionNumJobs :: forall flags.
(flags -> Flag (Maybe Int))
-> (Flag (Maybe Int) -> flags -> flags) -> OptionField flags
optionNumJobs flags -> Flag (Maybe Int)
get Flag (Maybe Int) -> flags -> flags
set =
  String
-> [String]
-> String
-> (flags -> Flag (Maybe Int))
-> (Flag (Maybe Int) -> flags -> flags)
-> MkOptDescr
     (flags -> Flag (Maybe Int))
     (Flag (Maybe Int) -> flags -> flags)
     flags
-> OptionField flags
forall get set a.
String
-> [String]
-> String
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option
    String
"j"
    [String
"jobs"]
    String
"Run NUM jobs simultaneously (or '$ncpus' if no NUM is given)."
    flags -> Flag (Maybe Int)
get
    Flag (Maybe Int) -> flags -> flags
set
    ( String
-> ReadE (Flag (Maybe Int))
-> (String, Flag (Maybe Int))
-> (Flag (Maybe Int) -> [Maybe String])
-> MkOptDescr
     (flags -> Flag (Maybe Int))
     (Flag (Maybe Int) -> flags -> flags)
     flags
forall b a.
Monoid b =>
String
-> ReadE b
-> (String, b)
-> (b -> [Maybe String])
-> MkOptDescr (a -> b) (b -> a -> a) a
optArg
        String
"NUM"
        ((Maybe Int -> Flag (Maybe Int))
-> ReadE (Maybe Int) -> ReadE (Flag (Maybe Int))
forall a b. (a -> b) -> ReadE a -> ReadE b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe Int -> Flag (Maybe Int)
forall a. a -> Flag a
Flag ReadE (Maybe Int)
numJobsParser)
        (String
"$ncpus", Maybe Int -> Flag (Maybe Int)
forall a. a -> Flag a
Flag Maybe Int
forall a. Maybe a
Nothing)
        ((Maybe Int -> Maybe String) -> [Maybe Int] -> [Maybe String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> (Maybe Int -> String) -> Maybe Int -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (Int -> String) -> Maybe Int -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"$ncpus" Int -> String
forall a. Show a => a -> String
show) ([Maybe Int] -> [Maybe String])
-> (Flag (Maybe Int) -> [Maybe Int])
-> Flag (Maybe Int)
-> [Maybe String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flag (Maybe Int) -> [Maybe Int]
forall a. Flag a -> [a]
flagToList)
    )
  where
    numJobsParser :: ReadE (Maybe Int)
    numJobsParser :: ReadE (Maybe Int)
numJobsParser = (String -> Either String (Maybe Int)) -> ReadE (Maybe Int)
forall a. (String -> Either String a) -> ReadE a
ReadE ((String -> Either String (Maybe Int)) -> ReadE (Maybe Int))
-> (String -> Either String (Maybe Int)) -> ReadE (Maybe Int)
forall a b. (a -> b) -> a -> b
$ \String
s ->
      case String
s of
        String
"$ncpus" -> Maybe Int -> Either String (Maybe Int)
forall a b. b -> Either a b
Right Maybe Int
forall a. Maybe a
Nothing
        String
_ -> case ReadS Int
forall a. Read a => ReadS a
reads String
s of
          [(Int
n, String
"")]
            | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 -> String -> Either String (Maybe Int)
forall a b. a -> Either a b
Left String
"The number of jobs should be 1 or more."
            | Bool
otherwise -> Maybe Int -> Either String (Maybe Int)
forall a b. b -> Either a b
Right (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n)
          [(Int, String)]
_ -> String -> Either String (Maybe Int)
forall a b. a -> Either a b
Left String
"The jobs value should be a number or '$ncpus'"

-- ------------------------------------------------------------

-- * Other Utils

-- ------------------------------------------------------------

configureCCompiler
  :: Verbosity
  -> ProgramDb
  -> IO (FilePath, [String])
configureCCompiler :: Verbosity -> ProgramDb -> IO (String, [String])
configureCCompiler Verbosity
verbosity ProgramDb
progdb = Verbosity -> ProgramDb -> Program -> IO (String, [String])
configureProg Verbosity
verbosity ProgramDb
progdb Program
gccProgram

configureLinker :: Verbosity -> ProgramDb -> IO (FilePath, [String])
configureLinker :: Verbosity -> ProgramDb -> IO (String, [String])
configureLinker Verbosity
verbosity ProgramDb
progdb = Verbosity -> ProgramDb -> Program -> IO (String, [String])
configureProg Verbosity
verbosity ProgramDb
progdb Program
ldProgram

configureProg
  :: Verbosity
  -> ProgramDb
  -> Program
  -> IO (FilePath, [String])
configureProg :: Verbosity -> ProgramDb -> Program -> IO (String, [String])
configureProg Verbosity
verbosity ProgramDb
programDb Program
prog = do
  (p, _) <- Verbosity
-> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
requireProgram Verbosity
verbosity Program
prog ProgramDb
programDb
  let pInv = ConfiguredProgram -> [String] -> ProgramInvocation
programInvocation ConfiguredProgram
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 "\"-DMSGSTR=\\\"foo bar\\\"\" --baz"
-- >   = ["-DMSGSTR=\"foo bar\"","--baz"]
splitArgs :: String -> [String]
splitArgs :: String -> [String]
splitArgs = String -> String -> [String]
space []
  where
    space :: String -> String -> [String]
    space :: String -> String -> [String]
space String
w [] = String -> [String] -> [String]
forall {a}. [a] -> [[a]] -> [[a]]
word String
w []
    space String
w (Char
c : String
s)
      | Char -> Bool
isSpace Char
c = String -> [String] -> [String]
forall {a}. [a] -> [[a]] -> [[a]]
word String
w (String -> String -> [String]
space [] String
s)
    space String
w (Char
'"' : String
s) = String -> String -> [String]
string String
w String
s
    space String
w String
s = String -> String -> [String]
nonstring String
w String
s

    string :: String -> String -> [String]
    string :: String -> String -> [String]
string String
w [] = String -> [String] -> [String]
forall {a}. [a] -> [[a]] -> [[a]]
word String
w []
    string String
w (Char
'"' : String
s) = String -> String -> [String]
space String
w String
s
    string String
w (Char
'\\' : Char
'"' : String
s) = String -> String -> [String]
string (Char
'"' Char -> ShowS
forall a. a -> [a] -> [a]
: String
w) String
s
    string String
w (Char
c : String
s) = String -> String -> [String]
string (Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: String
w) String
s

    nonstring :: String -> String -> [String]
    nonstring :: String -> String -> [String]
nonstring String
w [] = String -> [String] -> [String]
forall {a}. [a] -> [[a]] -> [[a]]
word String
w []
    nonstring String
w (Char
'"' : String
s) = String -> String -> [String]
string String
w String
s
    nonstring String
w (Char
c : String
s) = String -> String -> [String]
space (Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: String
w) String
s

    word :: [a] -> [[a]] -> [[a]]
word [] [[a]]
s = [[a]]
s
    word [a]
w [[a]]
s = [a] -> [a]
forall a. [a] -> [a]
reverse [a]
w [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]]
s