{-# 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
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
<*>
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
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.")