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

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

-- |
-- Module      :  Distribution.Simple.Setup.Global
-- Copyright   :  Isaac Jones 2003-2004
--                Duncan Coutts 2007
-- License     :  BSD3
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- Definition of the global command-line options.
-- See: @Distribution.Simple.Setup@
module Distribution.Simple.Setup.Global
  ( GlobalFlags (..)
  , emptyGlobalFlags
  , defaultGlobalFlags
  , globalCommand
  ) where

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

import Distribution.Simple.Command hiding (boolOpt, boolOpt')
import Distribution.Simple.Flag
import Distribution.Simple.Setup.Common
import Distribution.Utils.Path

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

-- * 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
  { GlobalFlags -> Flag Bool
globalVersion :: Flag Bool
  , GlobalFlags -> Flag Bool
globalNumericVersion :: Flag Bool
  , GlobalFlags -> Flag (SymbolicPath CWD ('Dir Pkg))
globalWorkingDir :: Flag (SymbolicPath CWD (Dir Pkg))
  }
  deriving ((forall x. GlobalFlags -> Rep GlobalFlags x)
-> (forall x. Rep GlobalFlags x -> GlobalFlags)
-> Generic GlobalFlags
forall x. Rep GlobalFlags x -> GlobalFlags
forall x. GlobalFlags -> Rep GlobalFlags x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. GlobalFlags -> Rep GlobalFlags x
from :: forall x. GlobalFlags -> Rep GlobalFlags x
$cto :: forall x. Rep GlobalFlags x -> GlobalFlags
to :: forall x. Rep GlobalFlags x -> GlobalFlags
Generic, Typeable)

defaultGlobalFlags :: GlobalFlags
defaultGlobalFlags :: GlobalFlags
defaultGlobalFlags =
  GlobalFlags
    { globalVersion :: Flag Bool
globalVersion = Bool -> Flag Bool
forall a. a -> Flag a
Flag Bool
False
    , globalNumericVersion :: Flag Bool
globalNumericVersion = Bool -> Flag Bool
forall a. a -> Flag a
Flag Bool
False
    , globalWorkingDir :: Flag (SymbolicPath CWD ('Dir Pkg))
globalWorkingDir = Flag (SymbolicPath CWD ('Dir Pkg))
forall a. Flag a
NoFlag
    }

globalCommand :: [Command action] -> CommandUI GlobalFlags
globalCommand :: forall action. [Command action] -> CommandUI GlobalFlags
globalCommand [Command action]
commands =
  CommandUI
    { commandName :: String
commandName = String
""
    , commandSynopsis :: String
commandSynopsis = String
""
    , commandUsage :: String -> String
commandUsage = \String
pname ->
        String
"This Setup program uses the Haskell Cabal Infrastructure.\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"See http://www.haskell.org/cabal/ for more information.\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Usage: "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" [GLOBAL FLAGS] [COMMAND [FLAGS]]\n"
    , commandDescription :: Maybe (String -> String)
commandDescription = (String -> String) -> Maybe (String -> String)
forall a. a -> Maybe a
Just ((String -> String) -> Maybe (String -> String))
-> (String -> String) -> Maybe (String -> String)
forall a b. (a -> b) -> a -> b
$ \String
pname ->
        let
          commands' :: [Command action]
commands' = [Command action]
commands [Command action] -> [Command action] -> [Command action]
forall a. [a] -> [a] -> [a]
++ [CommandUI () -> (() -> [String] -> action) -> Command action
forall flags action.
CommandUI flags -> (flags -> [String] -> action) -> Command action
commandAddAction CommandUI ()
helpCommandUI () -> [String] -> action
forall a. HasCallStack => a
undefined]
          cmdDescs :: [(String, String)]
cmdDescs = [Command action] -> [(String, String)]
forall action. [Command action] -> [(String, String)]
getNormalCommandDescriptions [Command action]
commands'
          maxlen :: Int
maxlen = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ [String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
name | (String
name, String
_) <- [(String, String)]
cmdDescs]
          align :: String -> String
align String
str = String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
maxlen Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str) Char
' '
         in
          String
"Commands:\n"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines
              [ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
align String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"    " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
descr
              | (String
name, String
descr) <- [(String, String)]
cmdDescs
              ]
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"For more information about a command use\n"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" COMMAND --help\n\n"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Typical steps for installing Cabal packages:\n"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
              [ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
              | String
x <- [String
"configure", String
"build", String
"install"]
              ]
    , commandNotes :: Maybe (String -> String)
commandNotes = Maybe (String -> String)
forall a. Maybe a
Nothing
    , commandDefaultFlags :: GlobalFlags
commandDefaultFlags = GlobalFlags
defaultGlobalFlags
    , commandOptions :: ShowOrParseArgs -> [OptionField GlobalFlags]
commandOptions = \ShowOrParseArgs
_ ->
        [ String
-> [String]
-> String
-> (GlobalFlags -> Flag Bool)
-> (Flag Bool -> GlobalFlags -> GlobalFlags)
-> MkOptDescr
     (GlobalFlags -> Flag Bool)
     (Flag Bool -> GlobalFlags -> GlobalFlags)
     GlobalFlags
-> OptionField GlobalFlags
forall get set a.
String
-> [String]
-> String
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option
            [Char
'V']
            [String
"version"]
            String
"Print version information"
            GlobalFlags -> Flag Bool
globalVersion
            (\Flag Bool
v GlobalFlags
flags -> GlobalFlags
flags{globalVersion = v})
            MkOptDescr
  (GlobalFlags -> Flag Bool)
  (Flag Bool -> GlobalFlags -> GlobalFlags)
  GlobalFlags
forall a. MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
trueArg
        , String
-> [String]
-> String
-> (GlobalFlags -> Flag Bool)
-> (Flag Bool -> GlobalFlags -> GlobalFlags)
-> MkOptDescr
     (GlobalFlags -> Flag Bool)
     (Flag Bool -> GlobalFlags -> GlobalFlags)
     GlobalFlags
-> OptionField GlobalFlags
forall get set a.
String
-> [String]
-> String
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option
            []
            [String
"numeric-version"]
            String
"Print just the version number"
            GlobalFlags -> Flag Bool
globalNumericVersion
            (\Flag Bool
v GlobalFlags
flags -> GlobalFlags
flags{globalNumericVersion = v})
            MkOptDescr
  (GlobalFlags -> Flag Bool)
  (Flag Bool -> GlobalFlags -> GlobalFlags)
  GlobalFlags
forall a. MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
trueArg
        , String
-> [String]
-> String
-> (GlobalFlags -> Flag (SymbolicPath CWD ('Dir Pkg)))
-> (Flag (SymbolicPath CWD ('Dir Pkg))
    -> GlobalFlags -> GlobalFlags)
-> MkOptDescr
     (GlobalFlags -> Flag (SymbolicPath CWD ('Dir Pkg)))
     (Flag (SymbolicPath CWD ('Dir Pkg)) -> GlobalFlags -> GlobalFlags)
     GlobalFlags
-> OptionField GlobalFlags
forall get set a.
String
-> [String]
-> String
-> get
-> set
-> MkOptDescr get set a
-> OptionField a
option
            String
""
            [String
"working-dir"]
            String
"Set working directory"
            GlobalFlags -> Flag (SymbolicPath CWD ('Dir Pkg))
globalWorkingDir
            (\Flag (SymbolicPath CWD ('Dir Pkg))
v GlobalFlags
flags -> GlobalFlags
flags{globalWorkingDir = v})
            (String
-> MkOptDescr
     (GlobalFlags -> Flag (SymbolicPath CWD ('Dir Pkg)))
     (Flag (SymbolicPath CWD ('Dir Pkg)) -> GlobalFlags -> GlobalFlags)
     GlobalFlags
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")
        ]
    }

emptyGlobalFlags :: GlobalFlags
emptyGlobalFlags :: GlobalFlags
emptyGlobalFlags = GlobalFlags
forall a. Monoid a => a
mempty

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

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