{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RecordWildCards   #-}

module Stack.Options.GlobalParser where

import           Options.Applicative
import           Options.Applicative.Builder.Extra
import           Path.IO (getCurrentDir, resolveDir', resolveFile')
import qualified Stack.Docker                      as Docker
import           Stack.Init
import           Stack.Prelude
import           Stack.Options.ConfigParser
import           Stack.Options.LogLevelParser
import           Stack.Options.ResolverParser
import           Stack.Options.Utils
import           Stack.Types.Config
import           Stack.Types.Docker

-- | Parser for global command-line options.

globalOptsParser :: FilePath -> GlobalOptsContext -> Maybe LogLevel -> Parser GlobalOptsMonoid
globalOptsParser :: String
-> GlobalOptsContext -> Maybe LogLevel -> Parser GlobalOptsMonoid
globalOptsParser String
currentDir GlobalOptsContext
kind Maybe LogLevel
defLogLevel =
    First String
-> First DockerEntrypoint
-> First LogLevel
-> FirstTrue
-> FirstFalse
-> ConfigMonoid
-> First (Unresolved AbstractResolver)
-> First String
-> First WantedCompiler
-> First Bool
-> StylesUpdate
-> First Int
-> First String
-> First LockFileBehavior
-> GlobalOptsMonoid
GlobalOptsMonoid forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    forall (f :: * -> *) a. Alternative f => f a -> f (First a)
optionalFirst (forall s. IsString s => Mod OptionFields s -> Parser s
strOption (forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
Docker.reExecArgName forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. Mod f a
hidden forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. Mod f a
internal)) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    forall (f :: * -> *) a. Alternative f => f a -> f (First a)
optionalFirst (forall a. ReadM a -> Mod OptionFields a -> Parser a
option forall a. Read a => ReadM a
auto (forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
dockerEntrypointArgName forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. Mod f a
hidden forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. Mod f a
internal)) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    (forall a. Maybe a -> First a
First forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Maybe LogLevel -> Parser (Maybe LogLevel)
logLevelOptsParser Bool
hide0 Maybe LogLevel
defLogLevel) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    String -> String -> Mod FlagFields FirstTrue -> Parser FirstTrue
firstBoolFlagsTrue
        String
"time-in-log"
        String
"inclusion of timings in logs, for the purposes of using diff with logs"
        forall (f :: * -> *) a. Mod f a
hide forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    String -> String -> Mod FlagFields FirstFalse -> Parser FirstFalse
firstBoolFlagsFalse
        String
"rsl-in-log"
        String
"inclusion of raw snapshot layer (rsl) in logs"
        forall (f :: * -> *) a. Mod f a
hide forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    String -> GlobalOptsContext -> Parser ConfigMonoid
configOptsParser String
currentDir GlobalOptsContext
kind forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    forall (f :: * -> *) a. Alternative f => f a -> f (First a)
optionalFirst (Bool -> Parser (Unresolved AbstractResolver)
abstractResolverOptsParser Bool
hide0) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Maybe a -> First a
First forall a. Maybe a
Nothing) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> -- resolver root is only set via the script command

    forall (f :: * -> *) a. Alternative f => f a -> f (First a)
optionalFirst (Bool -> Parser WantedCompiler
compilerOptsParser Bool
hide0) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    String
-> String -> Mod FlagFields (Maybe Bool) -> Parser (First Bool)
firstBoolFlagsNoDefault
        String
"terminal"
        String
"overriding terminal detection in the case of running in a false terminal"
        forall (f :: * -> *) a. Mod f a
hide forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM StylesUpdate
readStyles
         (forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"stack-colors" forall a. Semigroup a => a -> a -> a
<>
          forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"stack-colours" forall a. Semigroup a => a -> a -> a
<>
          forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"STYLES" forall a. Semigroup a => a -> a -> a
<>
          forall (f :: * -> *) a. HasValue f => a -> Mod f a
value forall a. Monoid a => a
mempty forall a. Semigroup a => a -> a -> a
<>
          forall (f :: * -> *) a. String -> Mod f a
help String
"Specify stack's output styles; STYLES is a colon-delimited \
               \sequence of key=value, where 'key' is a style name and 'value' \
               \is a semicolon-delimited list of 'ANSI' SGR (Select Graphic \
               \Rendition) control codes (in decimal). Use 'stack ls \
               \stack-colors --basic' to see the current sequence. In shells \
               \where a semicolon is a command separator, enclose STYLES in \
               \quotes." forall a. Semigroup a => a -> a -> a
<>
          forall (f :: * -> *) a. Mod f a
hide) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    forall (f :: * -> *) a. Alternative f => f a -> f (First a)
optionalFirst (forall a. ReadM a -> Mod OptionFields a -> Parser a
option forall a. Read a => ReadM a
auto
        (forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"terminal-width" forall a. Semigroup a => a -> a -> a
<>
         forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"INT" forall a. Semigroup a => a -> a -> a
<>
         forall (f :: * -> *) a. String -> Mod f a
help String
"Specify the width of the terminal, used for pretty-print messages" forall a. Semigroup a => a -> a -> a
<>
         forall (f :: * -> *) a. Mod f a
hide)) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    forall (f :: * -> *) a. Alternative f => f a -> f (First a)
optionalFirst
        (forall s. IsString s => Mod OptionFields s -> Parser s
strOption
            (forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"stack-yaml" forall a. Semigroup a => a -> a -> a
<>
             forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"STACK-YAML" forall a. Semigroup a => a -> a -> a
<>
             forall (f :: * -> *) a. HasCompleter f => Completer -> Mod f a
completer ([String] -> Completer
fileExtCompleter [String
".yaml"]) forall a. Semigroup a => a -> a -> a
<>
             forall (f :: * -> *) a. String -> Mod f a
help (String
"Override project stack.yaml file " forall a. Semigroup a => a -> a -> a
<>
                   String
"(overrides any STACK_YAML environment variable)") forall a. Semigroup a => a -> a -> a
<>
             forall (f :: * -> *) a. Mod f a
hide)) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
    forall (f :: * -> *) a. Alternative f => f a -> f (First a)
optionalFirst (forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM LockFileBehavior
readLockFileBehavior
        (forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"lock-file" forall a. Semigroup a => a -> a -> a
<>
         forall (f :: * -> *) a. String -> Mod f a
help String
"Specify how to interact with lock files. Default: read/write. If resolver is overridden: read-only" forall a. Semigroup a => a -> a -> a
<>
         forall (f :: * -> *) a. Mod f a
hide))
  where
    hide :: Mod f a
hide = forall (f :: * -> *) a. Bool -> Mod f a
hideMods Bool
hide0
    hide0 :: Bool
hide0 = GlobalOptsContext
kind forall a. Eq a => a -> a -> Bool
/= GlobalOptsContext
OuterGlobalOpts

-- | Create GlobalOpts from GlobalOptsMonoid.

globalOptsFromMonoid :: MonadIO m => Bool -> GlobalOptsMonoid -> m GlobalOpts
globalOptsFromMonoid :: forall (m :: * -> *).
MonadIO m =>
Bool -> GlobalOptsMonoid -> m GlobalOpts
globalOptsFromMonoid Bool
defaultTerminal GlobalOptsMonoid{First Bool
First Int
First String
First (Unresolved AbstractResolver)
First WantedCompiler
First LogLevel
First DockerEntrypoint
First LockFileBehavior
StylesUpdate
FirstFalse
FirstTrue
ConfigMonoid
globalMonoidLockFileBehavior :: GlobalOptsMonoid -> First LockFileBehavior
globalMonoidStackYaml :: GlobalOptsMonoid -> First String
globalMonoidTermWidth :: GlobalOptsMonoid -> First Int
globalMonoidStyles :: GlobalOptsMonoid -> StylesUpdate
globalMonoidTerminal :: GlobalOptsMonoid -> First Bool
globalMonoidCompiler :: GlobalOptsMonoid -> First WantedCompiler
globalMonoidResolverRoot :: GlobalOptsMonoid -> First String
globalMonoidResolver :: GlobalOptsMonoid -> First (Unresolved AbstractResolver)
globalMonoidConfigMonoid :: GlobalOptsMonoid -> ConfigMonoid
globalMonoidRSLInLog :: GlobalOptsMonoid -> FirstFalse
globalMonoidTimeInLog :: GlobalOptsMonoid -> FirstTrue
globalMonoidLogLevel :: GlobalOptsMonoid -> First LogLevel
globalMonoidDockerEntrypoint :: GlobalOptsMonoid -> First DockerEntrypoint
globalMonoidReExecVersion :: GlobalOptsMonoid -> First String
globalMonoidLockFileBehavior :: First LockFileBehavior
globalMonoidStackYaml :: First String
globalMonoidTermWidth :: First Int
globalMonoidStyles :: StylesUpdate
globalMonoidTerminal :: First Bool
globalMonoidCompiler :: First WantedCompiler
globalMonoidResolverRoot :: First String
globalMonoidResolver :: First (Unresolved AbstractResolver)
globalMonoidConfigMonoid :: ConfigMonoid
globalMonoidRSLInLog :: FirstFalse
globalMonoidTimeInLog :: FirstTrue
globalMonoidLogLevel :: First LogLevel
globalMonoidDockerEntrypoint :: First DockerEntrypoint
globalMonoidReExecVersion :: First String
..} = do
  Maybe AbstractResolver
resolver <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (forall a. First a -> Maybe a
getFirst First (Unresolved AbstractResolver)
globalMonoidResolver) forall a b. (a -> b) -> a -> b
$ \Unresolved AbstractResolver
ur -> do
    Path Abs Dir
root <-
      case First String
globalMonoidResolverRoot of
        First Maybe String
Nothing -> forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
        First (Just String
dir) -> forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
resolveDir' String
dir
    forall (m :: * -> *) a.
MonadIO m =>
Maybe (Path Abs Dir) -> Unresolved a -> m a
resolvePaths (forall a. a -> Maybe a
Just Path Abs Dir
root) Unresolved AbstractResolver
ur
  StackYamlLoc
stackYaml <-
    case forall a. First a -> Maybe a
getFirst First String
globalMonoidStackYaml of
      Maybe String
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure StackYamlLoc
SYLDefault
      Just String
fp -> Path Abs File -> StackYamlLoc
SYLOverride forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadIO m => String -> m (Path Abs File)
resolveFile' String
fp
  forall (f :: * -> *) a. Applicative f => a -> f a
pure GlobalOpts
    { globalReExecVersion :: Maybe String
globalReExecVersion = forall a. First a -> Maybe a
getFirst First String
globalMonoidReExecVersion
    , globalDockerEntrypoint :: Maybe DockerEntrypoint
globalDockerEntrypoint = forall a. First a -> Maybe a
getFirst First DockerEntrypoint
globalMonoidDockerEntrypoint
    , globalLogLevel :: LogLevel
globalLogLevel = forall a. a -> First a -> a
fromFirst LogLevel
defaultLogLevel First LogLevel
globalMonoidLogLevel
    , globalTimeInLog :: Bool
globalTimeInLog = FirstTrue -> Bool
fromFirstTrue FirstTrue
globalMonoidTimeInLog
    , globalRSLInLog :: Bool
globalRSLInLog = FirstFalse -> Bool
fromFirstFalse FirstFalse
globalMonoidRSLInLog
    , globalConfigMonoid :: ConfigMonoid
globalConfigMonoid = ConfigMonoid
globalMonoidConfigMonoid
    , globalResolver :: Maybe AbstractResolver
globalResolver = Maybe AbstractResolver
resolver
    , globalCompiler :: Maybe WantedCompiler
globalCompiler = forall a. First a -> Maybe a
getFirst First WantedCompiler
globalMonoidCompiler
    , globalTerminal :: Bool
globalTerminal = forall a. a -> First a -> a
fromFirst Bool
defaultTerminal First Bool
globalMonoidTerminal
    , globalStylesUpdate :: StylesUpdate
globalStylesUpdate = StylesUpdate
globalMonoidStyles
    , globalTermWidth :: Maybe Int
globalTermWidth = forall a. First a -> Maybe a
getFirst First Int
globalMonoidTermWidth
    , globalStackYaml :: StackYamlLoc
globalStackYaml = StackYamlLoc
stackYaml
    , globalLockFileBehavior :: LockFileBehavior
globalLockFileBehavior =
        let defLFB :: LockFileBehavior
defLFB =
              case forall a. First a -> Maybe a
getFirst First (Unresolved AbstractResolver)
globalMonoidResolver of
                Maybe (Unresolved AbstractResolver)
Nothing -> LockFileBehavior
LFBReadWrite
                Maybe (Unresolved AbstractResolver)
_ -> LockFileBehavior
LFBReadOnly
         in forall a. a -> First a -> a
fromFirst LockFileBehavior
defLFB First LockFileBehavior
globalMonoidLockFileBehavior
    }

initOptsParser :: Parser InitOpts
initOptsParser :: Parser InitOpts
initOptsParser =
    [Text] -> Bool -> Bool -> Bool -> InitOpts
InitOpts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [Text]
searchDirs
             forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool
omitPackages
             forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool
overwrite forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not Parser Bool
ignoreSubDirs
  where
    searchDirs :: Parser [Text]
searchDirs =
      forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Mod ArgumentFields Text -> Parser Text
textArgument
              (forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"DIR(S)" forall a. Semigroup a => a -> a -> a
<>
               forall (f :: * -> *) a. HasCompleter f => Completer -> Mod f a
completer Completer
dirCompleter forall a. Semigroup a => a -> a -> a
<>
               forall (f :: * -> *) a. String -> Mod f a
help String
"Directory, or directories, to include in the search for \
                    \.cabal files, when initialising. The default is the \
                    \current directory."))
    ignoreSubDirs :: Parser Bool
ignoreSubDirs = Mod FlagFields Bool -> Parser Bool
switch (forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"ignore-subdirs" forall a. Semigroup a => a -> a -> a
<>
                           forall (f :: * -> *) a. String -> Mod f a
help String
"Do not search for .cabal files in \
                                \subdirectories, when initialising.")
    overwrite :: Parser Bool
overwrite = Mod FlagFields Bool -> Parser Bool
switch (forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"force" forall a. Semigroup a => a -> a -> a
<>
                       forall (f :: * -> *) a. String -> Mod f a
help String
"Force an initialisation that overwrites any \
                            \existing stack.yaml file.")
    omitPackages :: Parser Bool
omitPackages = Mod FlagFields Bool -> Parser Bool
switch (forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"omit-packages" forall a. Semigroup a => a -> a -> a
<>
                           forall (f :: * -> *) a. String -> Mod f a
help String
"Exclude conflicting or incompatible user \
                                \packages, when initialising.")