{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RecordWildCards #-}
module Stack.Options.GlobalParser
( globalOptsFromMonoid
, globalOptsParser
, initOptsParser
) where
import Options.Applicative
( Parser, auto, completer, help, hidden, internal, long
, metavar, option, strOption, switch, value
)
import Options.Applicative.Builder.Extra
( dirCompleter, fileExtCompleter, firstBoolFlagsFalse
, firstBoolFlagsNoDefault, firstBoolFlagsTrue, optionalFirst
, textArgument
)
import Path.IO ( getCurrentDir, resolveDir', resolveFile' )
import qualified Stack.Docker as Docker
import Stack.Init ( InitOpts (..) )
import Stack.Prelude
import Stack.Options.ConfigParser ( configOptsParser )
import Stack.Options.LogLevelParser ( logLevelOptsParser )
import Stack.Options.ResolverParser
( abstractResolverOptsParser, compilerOptsParser )
import Stack.Options.Utils ( GlobalOptsContext (..), hideMods )
import Stack.Types.Config
( GlobalOpts (..), GlobalOptsMonoid (..)
, LockFileBehavior (..), StackYamlLoc (..), defaultLogLevel
, readLockFileBehavior, readStyles
)
import Stack.Types.Docker ( dockerEntrypointArgName )
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."
)