{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module OptEnvConf.Run
  ( runSettingsParser,
    runParser,
    runParserOn,
    internalParser,
  )
where

import Autodocodec
import Control.Arrow (left)
import Control.Monad.Reader hiding (Reader, reader, runReader)
import Control.Monad.State
import Data.Aeson (parseJSON, (.:?))
import qualified Data.Aeson as JSON
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KeyMap
import qualified Data.Aeson.Types as JSON
import Data.List (find)
import Data.List.NonEmpty (NonEmpty (..), (<|))
import qualified Data.List.NonEmpty as NE
import Data.Maybe
import Data.Set (Set)
import qualified Data.Set as S
import Data.Traversable
import Data.Version
import GHC.Stack (SrcLoc)
import OptEnvConf.Args as Args
import OptEnvConf.Completion
import OptEnvConf.Doc
import OptEnvConf.EnvMap (EnvMap (..))
import qualified OptEnvConf.EnvMap as EnvMap
import OptEnvConf.Error
import OptEnvConf.Lint
import OptEnvConf.NonDet
import OptEnvConf.Parser
import OptEnvConf.Reader
import OptEnvConf.Setting
import OptEnvConf.Validation
import Path
import System.Environment (getArgs, getEnvironment, getProgName)
import System.Exit
import System.IO
import Text.Colour
import Text.Colour.Capabilities.FromEnv

-- | Run 'runParser' on your @Settings@' type's 'settingsParser'.
--
-- __This is most likely the function you want to be using.__
runSettingsParser ::
  (HasParser a) =>
  -- | Program version, get this from Paths_your_package_name
  Version ->
  -- | Program description
  String ->
  IO a
runSettingsParser :: forall a. HasParser a => Version -> [Char] -> IO a
runSettingsParser Version
version [Char]
progDesc =
  Version -> [Char] -> Parser a -> IO a
forall a. Version -> [Char] -> Parser a -> IO a
runParser Version
version [Char]
progDesc Parser a
forall a. HasParser a => Parser a
settingsParser

-- | Run a parser
--
-- This function with exit on:
--
--     * Parse failure: show a nice error message.
--     * @-h|--help@: Show help text
--     * @--version@: Show version information
--     * @--render-man-page@: Render a man page
--     * @--bash-completion-script@: Render a bash completion script
--     * @--zsh-completion-script@: Render a zsh completion script
--     * @--fish-completion-script@: Render a fish completion script
--     * @query-opt-env-conf-completion@: Perform a completion query
--
-- This gets the arguments and environment variables from the current process.
runParser ::
  -- | Program version, get this from Paths_your_package_name
  Version ->
  -- | Program description
  String ->
  Parser a ->
  IO a
runParser :: forall a. Version -> [Char] -> Parser a -> IO a
runParser Version
version [Char]
progDesc Parser a
p = do
  [[Char]]
allArgs <- IO [[Char]]
getArgs
  let argMap' :: Args
argMap' = [[Char]] -> Args
parseArgs [[Char]]
allArgs
  let mArgMap :: Maybe Args
mArgMap = [Dashed] -> Args -> Maybe Args
consumeSwitch [Dashed
"--debug-optparse"] Args
argMap'
  let (Bool
debugMode, Args
argMap) = case Maybe Args
mArgMap of
        Maybe Args
Nothing -> (Bool
False, Args
argMap')
        Just Args
am -> (Bool
True, Args
am)

  [([Char], [Char])]
completeEnv <- IO [([Char], [Char])]
getEnvironment
  let envVars :: EnvMap
envVars = [([Char], [Char])] -> EnvMap
EnvMap.parse [([Char], [Char])]
completeEnv

  case Parser a -> Maybe (NonEmpty LintError)
forall a. Parser a -> Maybe (NonEmpty LintError)
lintParser Parser a
p of
    Just NonEmpty LintError
errs -> do
      TerminalCapabilities
tc <- Handle -> IO TerminalCapabilities
getTerminalCapabilitiesFromHandle Handle
stderr
      TerminalCapabilities -> Handle -> [Chunk] -> IO ()
hPutChunksLocaleWith TerminalCapabilities
tc Handle
stderr ([Chunk] -> IO ()) -> [Chunk] -> IO ()
forall a b. (a -> b) -> a -> b
$ NonEmpty LintError -> [Chunk]
renderLintErrors NonEmpty LintError
errs
      IO a
forall a. IO a
exitFailure
    Maybe (NonEmpty LintError)
Nothing -> do
      let p' :: Parser (Internal a)
p' = Version -> Parser a -> Parser (Internal a)
forall a. Version -> Parser a -> Parser (Internal a)
internalParser Version
version Parser a
p
      let docs :: AnyDocs SetDoc
docs = Parser (Internal a) -> AnyDocs SetDoc
forall a. Parser a -> AnyDocs SetDoc
parserDocs Parser (Internal a)
p'
      Either (NonEmpty ParseError) (Internal a)
errOrResult <-
        Parser (Internal a)
-> Args
-> EnvMap
-> Maybe Object
-> IO (Either (NonEmpty ParseError) (Internal a))
forall a.
Parser a
-> Args
-> EnvMap
-> Maybe Object
-> IO (Either (NonEmpty ParseError) a)
runParserOn
          Parser (Internal a)
p'
          Args
argMap
          EnvMap
envVars
          Maybe Object
forall a. Maybe a
Nothing
      case Either (NonEmpty ParseError) (Internal a)
errOrResult of
        Left NonEmpty ParseError
errs -> do
          TerminalCapabilities
tc <- Handle -> IO TerminalCapabilities
getTerminalCapabilitiesFromHandle Handle
stderr
          let f :: NonEmpty ParseError -> NonEmpty ParseError
f = if Bool
debugMode then NonEmpty ParseError -> NonEmpty ParseError
forall a. a -> a
id else NonEmpty ParseError -> NonEmpty ParseError
forall (f :: * -> *). Functor f => f ParseError -> f ParseError
eraseErrorSrcLocs
          TerminalCapabilities -> Handle -> [Chunk] -> IO ()
hPutChunksLocaleWith TerminalCapabilities
tc Handle
stderr ([Chunk] -> IO ()) -> [Chunk] -> IO ()
forall a b. (a -> b) -> a -> b
$ NonEmpty ParseError -> [Chunk]
renderErrors (NonEmpty ParseError -> [Chunk]) -> NonEmpty ParseError -> [Chunk]
forall a b. (a -> b) -> a -> b
$ NonEmpty ParseError -> NonEmpty ParseError
f NonEmpty ParseError
errs
          IO a
forall a. IO a
exitFailure
        Right Internal a
i -> case Internal a
i of
          Internal a
ShowHelp -> do
            [Char]
progname <- IO [Char]
getProgName
            TerminalCapabilities
tc <- Handle -> IO TerminalCapabilities
getTerminalCapabilitiesFromHandle Handle
stdout
            TerminalCapabilities -> Handle -> [Chunk] -> IO ()
hPutChunksLocaleWith TerminalCapabilities
tc Handle
stdout ([Chunk] -> IO ()) -> [Chunk] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> AnyDocs SetDoc -> [Chunk]
renderHelpPage [Char]
progname [Char]
progDesc AnyDocs SetDoc
docs
            IO a
forall a. IO a
exitSuccess
          Internal a
ShowVersion -> do
            [Char]
progname <- IO [Char]
getProgName
            TerminalCapabilities
tc <- Handle -> IO TerminalCapabilities
getTerminalCapabilitiesFromHandle Handle
stdout
            TerminalCapabilities -> Handle -> [Chunk] -> IO ()
hPutChunksLocaleWith TerminalCapabilities
tc Handle
stdout ([Chunk] -> IO ()) -> [Chunk] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Version -> [Chunk]
renderVersionPage [Char]
progname Version
version
            IO a
forall a. IO a
exitSuccess
          Internal a
RenderMan -> do
            [Char]
progname <- IO [Char]
getProgName
            TerminalCapabilities
tc <- Handle -> IO TerminalCapabilities
getTerminalCapabilitiesFromHandle Handle
stdout
            TerminalCapabilities -> Handle -> [Chunk] -> IO ()
hPutChunksLocaleWith TerminalCapabilities
tc Handle
stdout ([Chunk] -> IO ()) -> [Chunk] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Version -> [Char] -> AnyDocs SetDoc -> [Chunk]
renderManPage [Char]
progname Version
version [Char]
progDesc AnyDocs SetDoc
docs
            IO a
forall a. IO a
exitSuccess
          Internal a
CheckSettings -> do
            let argMap'' :: Args
argMap'' = case [Dashed] -> Args -> Maybe Args
consumeSwitch [NonEmpty Char -> Dashed
DashedLong NonEmpty Char
settingsCheckSwitch] Args
argMap of
                  Maybe Args
Nothing -> [Char] -> Args
forall a. HasCallStack => [Char] -> a
error [Char]
"If you see this there is a bug in opt-env-conf."
                  Just Args
am -> Args
am
            Either (NonEmpty ParseError) a
errOrSets <- Parser a
-> Args
-> EnvMap
-> Maybe Object
-> IO (Either (NonEmpty ParseError) a)
forall a.
Parser a
-> Args
-> EnvMap
-> Maybe Object
-> IO (Either (NonEmpty ParseError) a)
runParserOn Parser a
p Args
argMap'' EnvMap
envVars Maybe Object
forall a. Maybe a
Nothing
            case Either (NonEmpty ParseError) a
errOrSets of
              Left NonEmpty ParseError
errs -> do
                TerminalCapabilities
tc <- Handle -> IO TerminalCapabilities
getTerminalCapabilitiesFromHandle Handle
stderr
                -- Don't erase rcs locs because they'll probably be useful anyway.
                TerminalCapabilities -> Handle -> [Chunk] -> IO ()
hPutChunksLocaleWith TerminalCapabilities
tc Handle
stderr ([Chunk] -> IO ()) -> [Chunk] -> IO ()
forall a b. (a -> b) -> a -> b
$ NonEmpty ParseError -> [Chunk]
renderErrors NonEmpty ParseError
errs
                IO a
forall a. IO a
exitFailure
              Right a
_ -> do
                TerminalCapabilities
tc <- Handle -> IO TerminalCapabilities
getTerminalCapabilitiesFromHandle Handle
stdout
                TerminalCapabilities -> Handle -> [Chunk] -> IO ()
hPutChunksLocaleWith TerminalCapabilities
tc Handle
stdout [Chunk
"Settings parsed successfully."]
                IO a
forall a. IO a
exitSuccess
          BashCompletionScript Path Abs File
progPath -> do
            [Char]
progname <- IO [Char]
getProgName
            Path Abs File -> [Char] -> IO ()
generateBashCompletionScript Path Abs File
progPath [Char]
progname
            IO a
forall a. IO a
exitSuccess
          ZshCompletionScript Path Abs File
progPath -> do
            [Char]
progname <- IO [Char]
getProgName
            Path Abs File -> [Char] -> IO ()
generateZshCompletionScript Path Abs File
progPath [Char]
progname
            IO a
forall a. IO a
exitSuccess
          FishCompletionScript Path Abs File
progPath -> do
            [Char]
progname <- IO [Char]
getProgName
            Path Abs File -> [Char] -> IO ()
generateFishCompletionScript Path Abs File
progPath [Char]
progname
            IO a
forall a. IO a
exitSuccess
          CompletionQuery Bool
enriched Int
index [[Char]]
ws -> do
            Parser (Internal a) -> Bool -> Int -> [[Char]] -> IO ()
forall a. Parser a -> Bool -> Int -> [[Char]] -> IO ()
runCompletionQuery Parser (Internal a)
p' Bool
enriched Int
index [[Char]]
ws
            IO a
forall a. IO a
exitSuccess
          ParsedNormally a
a -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

-- Internal structure to help us do what the framework
-- is supposed to.
data Internal a
  = ShowHelp
  | ShowVersion
  | RenderMan
  | CheckSettings
  | BashCompletionScript (Path Abs File)
  | ZshCompletionScript (Path Abs File)
  | FishCompletionScript (Path Abs File)
  | CompletionQuery
      -- Enriched
      !Bool
      -- Index
      !Int
      -- Args
      ![String]
  | ParsedNormally !a

settingsCheckSwitch :: NonEmpty Char
settingsCheckSwitch :: NonEmpty Char
settingsCheckSwitch =
  -- Pretty long so it probably doesn't collide.
  Char
'r' Char -> [Char] -> NonEmpty Char
forall a. a -> [a] -> NonEmpty a
:| [Char]
"un-settings-check"

internalParser :: Version -> Parser a -> Parser (Internal a)
internalParser :: forall a. Version -> Parser a -> Parser (Internal a)
internalParser Version
version Parser a
p =
  let allowLeftovers :: Parser a -> Parser a
      allowLeftovers :: forall a. Parser a -> Parser a
allowLeftovers Parser a
p' = (a, [[Char]]) -> a
forall a b. (a, b) -> a
fst ((a, [[Char]]) -> a) -> Parser (a, [[Char]]) -> Parser a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((,) (a -> [[Char]] -> (a, [[Char]]))
-> Parser a -> Parser ([[Char]] -> (a, [[Char]]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a
p' Parser ([[Char]] -> (a, [[Char]]))
-> Parser [[Char]] -> Parser (a, [[Char]])
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [Char] -> Parser [[Char]]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ([Builder [Char]] -> Parser [Char]
forall a. HasCallStack => [Builder a] -> Parser a
setting [Reader [Char] -> Builder [Char]
forall a. Reader a -> Builder a
reader Reader [Char]
forall s. IsString s => Reader s
str, Builder [Char]
forall a. Builder a
argument, Builder [Char]
forall a. Builder a
hidden] :: Parser String))
   in [Parser (Internal a)] -> Parser (Internal a)
forall a. HasCallStack => [Parser a] -> Parser a
choice
        [ Parser (Internal a) -> Parser (Internal a)
forall a. Parser a -> Parser a
allowLeftovers (Parser (Internal a) -> Parser (Internal a))
-> Parser (Internal a) -> Parser (Internal a)
forall a b. (a -> b) -> a -> b
$
            [Builder (Internal a)] -> Parser (Internal a)
forall a. HasCallStack => [Builder a] -> Parser a
setting
              [ Internal a -> Builder (Internal a)
forall a. a -> Builder a
switch Internal a
forall a. Internal a
ShowHelp,
                Char -> Builder (Internal a)
forall a. Char -> Builder a
short Char
'h',
                [Char] -> Builder (Internal a)
forall a. [Char] -> Builder a
long [Char]
"help",
                [Char] -> Builder (Internal a)
forall a. [Char] -> Builder a
help [Char]
"Show this help text"
              ],
          Parser (Internal a) -> Parser (Internal a)
forall a. Parser a -> Parser a
allowLeftovers (Parser (Internal a) -> Parser (Internal a))
-> Parser (Internal a) -> Parser (Internal a)
forall a b. (a -> b) -> a -> b
$
            [Builder (Internal a)] -> Parser (Internal a)
forall a. HasCallStack => [Builder a] -> Parser a
setting
              [ Internal a -> Builder (Internal a)
forall a. a -> Builder a
switch Internal a
forall a. Internal a
ShowVersion,
                [Char] -> Builder (Internal a)
forall a. [Char] -> Builder a
long [Char]
"version",
                [Char] -> Builder (Internal a)
forall a. [Char] -> Builder a
help ([Char] -> Builder (Internal a)) -> [Char] -> Builder (Internal a)
forall a b. (a -> b) -> a -> b
$ [Char]
"Output version information: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Version -> [Char]
showVersion Version
version
              ],
          [Builder (Internal a)] -> Parser (Internal a)
forall a. HasCallStack => [Builder a] -> Parser a
setting
            [ Internal a -> Builder (Internal a)
forall a. a -> Builder a
switch Internal a
forall a. Internal a
RenderMan,
              [Char] -> Builder (Internal a)
forall a. [Char] -> Builder a
long [Char]
"render-man-page",
              Builder (Internal a)
forall a. Builder a
hidden,
              [Char] -> Builder (Internal a)
forall a. [Char] -> Builder a
help [Char]
"Show this help text"
            ],
          Parser (Internal a) -> Parser (Internal a)
forall a. Parser a -> Parser a
allowLeftovers (Parser (Internal a) -> Parser (Internal a))
-> Parser (Internal a) -> Parser (Internal a)
forall a b. (a -> b) -> a -> b
$
            [Builder (Internal a)] -> Parser (Internal a)
forall a. HasCallStack => [Builder a] -> Parser a
setting
              [ Internal a -> Builder (Internal a)
forall a. a -> Builder a
switch Internal a
forall a. Internal a
CheckSettings,
                [Char] -> Builder (Internal a)
forall a. [Char] -> Builder a
long ([Char] -> Builder (Internal a)) -> [Char] -> Builder (Internal a)
forall a b. (a -> b) -> a -> b
$ NonEmpty Char -> [Char]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Char
settingsCheckSwitch,
                Builder (Internal a)
forall a. Builder a
hidden,
                [Char] -> Builder (Internal a)
forall a. [Char] -> Builder a
help [Char]
"Run the parser and exit if parsing succeeded."
              ],
          Path Abs File -> Internal a
forall a. Path Abs File -> Internal a
BashCompletionScript
            (Path Abs File -> Internal a)
-> Parser (Path Abs File) -> Parser (Internal a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Char] -> IO (Path Abs File))
-> Parser [Char] -> Parser (Path Abs File)
forall a b. (a -> IO b) -> Parser a -> Parser b
mapIO
              [Char] -> IO (Path Abs File)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Abs File)
parseAbsFile
              ( [Builder [Char]] -> Parser [Char]
forall a. HasCallStack => [Builder a] -> Parser a
setting
                  [ Builder [Char]
forall a. Builder a
option,
                    Reader [Char] -> Builder [Char]
forall a. Reader a -> Builder a
reader Reader [Char]
forall s. IsString s => Reader s
str,
                    [Char] -> Builder [Char]
forall a. [Char] -> Builder a
long [Char]
"bash-completion-script",
                    Builder [Char]
forall a. Builder a
hidden,
                    [Char] -> Builder [Char]
forall a. [Char] -> Builder a
help [Char]
"Render the bash completion script"
                  ]
              ),
          Path Abs File -> Internal a
forall a. Path Abs File -> Internal a
ZshCompletionScript
            (Path Abs File -> Internal a)
-> Parser (Path Abs File) -> Parser (Internal a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Char] -> IO (Path Abs File))
-> Parser [Char] -> Parser (Path Abs File)
forall a b. (a -> IO b) -> Parser a -> Parser b
mapIO
              [Char] -> IO (Path Abs File)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Abs File)
parseAbsFile
              ( [Builder [Char]] -> Parser [Char]
forall a. HasCallStack => [Builder a] -> Parser a
setting
                  [ Builder [Char]
forall a. Builder a
option,
                    Reader [Char] -> Builder [Char]
forall a. Reader a -> Builder a
reader Reader [Char]
forall s. IsString s => Reader s
str,
                    [Char] -> Builder [Char]
forall a. [Char] -> Builder a
long [Char]
"zsh-completion-script",
                    Builder [Char]
forall a. Builder a
hidden,
                    [Char] -> Builder [Char]
forall a. [Char] -> Builder a
help [Char]
"Render the zsh completion script"
                  ]
              ),
          Path Abs File -> Internal a
forall a. Path Abs File -> Internal a
ZshCompletionScript
            (Path Abs File -> Internal a)
-> Parser (Path Abs File) -> Parser (Internal a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Char] -> IO (Path Abs File))
-> Parser [Char] -> Parser (Path Abs File)
forall a b. (a -> IO b) -> Parser a -> Parser b
mapIO
              [Char] -> IO (Path Abs File)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Abs File)
parseAbsFile
              ( [Builder [Char]] -> Parser [Char]
forall a. HasCallStack => [Builder a] -> Parser a
setting
                  [ Builder [Char]
forall a. Builder a
option,
                    Reader [Char] -> Builder [Char]
forall a. Reader a -> Builder a
reader Reader [Char]
forall s. IsString s => Reader s
str,
                    [Char] -> Builder [Char]
forall a. [Char] -> Builder a
long [Char]
"fish-completion-script",
                    Builder [Char]
forall a. Builder a
hidden,
                    [Char] -> Builder [Char]
forall a. [Char] -> Builder a
help [Char]
"Render the fish completion script"
                  ]
              ),
          [Builder (Bool -> Int -> [[Char]] -> Internal a)]
-> Parser (Bool -> Int -> [[Char]] -> Internal a)
forall a. HasCallStack => [Builder a] -> Parser a
setting
            [ [Char] -> Builder (Bool -> Int -> [[Char]] -> Internal a)
forall a. [Char] -> Builder a
help [Char]
"Query completion",
              (Bool -> Int -> [[Char]] -> Internal a)
-> Builder (Bool -> Int -> [[Char]] -> Internal a)
forall a. a -> Builder a
switch Bool -> Int -> [[Char]] -> Internal a
forall a. Bool -> Int -> [[Char]] -> Internal a
CompletionQuery,
              -- Long string that no normal user would ever use.
              [Char] -> Builder (Bool -> Int -> [[Char]] -> Internal a)
forall a. [Char] -> Builder a
long [Char]
"query-opt-env-conf-completion",
              Builder (Bool -> Int -> [[Char]] -> Internal a)
forall a. Builder a
hidden
            ]
            Parser (Bool -> Int -> [[Char]] -> Internal a)
-> Parser Bool -> Parser (Int -> [[Char]] -> Internal a)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Builder Bool] -> Parser Bool
forall a. HasCallStack => [Builder a] -> Parser a
setting
              [ Bool -> Builder Bool
forall a. a -> Builder a
switch Bool
True,
                [Char] -> Builder Bool
forall a. [Char] -> Builder a
long [Char]
"completion-enriched",
                Bool -> Builder Bool
forall a. Show a => a -> Builder a
value Bool
False,
                Builder Bool
forall a. Builder a
hidden,
                [Char] -> Builder Bool
forall a. [Char] -> Builder a
help [Char]
"Whether to enable enriched completion"
              ]
            Parser (Int -> [[Char]] -> Internal a)
-> Parser Int -> Parser ([[Char]] -> Internal a)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Builder Int] -> Parser Int
forall a. HasCallStack => [Builder a] -> Parser a
setting
              [ Builder Int
forall a. Builder a
option,
                Reader Int -> Builder Int
forall a. Reader a -> Builder a
reader Reader Int
forall a. Read a => Reader a
auto,
                [Char] -> Builder Int
forall a. [Char] -> Builder a
long [Char]
"completion-index",
                Builder Int
forall a. Builder a
hidden,
                [Char] -> Builder Int
forall a. [Char] -> Builder a
help [Char]
"The index between the arguments where completion was invoked."
              ]
            Parser ([[Char]] -> Internal a)
-> Parser [[Char]] -> Parser (Internal a)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [Char] -> Parser [[Char]]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many
              ( [Builder [Char]] -> Parser [Char]
forall a. HasCallStack => [Builder a] -> Parser a
setting
                  [ Builder [Char]
forall a. Builder a
option,
                    Reader [Char] -> Builder [Char]
forall a. Reader a -> Builder a
reader Reader [Char]
forall s. IsString s => Reader s
str,
                    [Char] -> Builder [Char]
forall a. [Char] -> Builder a
long [Char]
"completion-word",
                    Builder [Char]
forall a. Builder a
hidden,
                    [Char] -> Builder [Char]
forall a. [Char] -> Builder a
help [Char]
"The words (arguments) that have already been typed"
                  ]
              ),
          a -> Internal a
forall a. a -> Internal a
ParsedNormally (a -> Internal a) -> Parser a -> Parser (Internal a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a
p
        ]

-- | Run a parser on given arguments and environment instead of getting them
-- from the current process.
runParserOn ::
  Parser a ->
  Args ->
  EnvMap ->
  Maybe JSON.Object ->
  IO (Either (NonEmpty ParseError) a)
runParserOn :: forall a.
Parser a
-> Args
-> EnvMap
-> Maybe Object
-> IO (Either (NonEmpty ParseError) a)
runParserOn Parser a
parser Args
args EnvMap
envVars Maybe Object
mConfig = do
  let ppState :: PPState
ppState =
        PPState
          { ppStateArgs :: Args
ppStateArgs = Args
args,
            ppStateParsedSettings :: Set SrcLocHash
ppStateParsedSettings = Set SrcLocHash
forall a. Set a
S.empty
          }
  let ppEnv :: PPEnv
ppEnv =
        PPEnv
          { ppEnvEnv :: EnvMap
ppEnvEnv = EnvMap
envVars,
            ppEnvConf :: Maybe Object
ppEnvConf = Maybe Object
mConfig
          }
  let go' :: ReaderT
  PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
go' = do
        a
result <- Parser a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall a. Parser a -> PP a
go Parser a
parser
        Args
leftoverArgs <- (PPState -> Args)
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) Args
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PPState -> Args
ppStateArgs
        case Args -> Maybe (NonEmpty [Char])
argsLeftovers Args
leftoverArgs of
          Maybe (NonEmpty [Char])
Nothing -> a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall a.
a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result
          Just NonEmpty [Char]
leftovers -> Maybe SrcLoc
-> ParseErrorMessage
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall a. Maybe SrcLoc -> ParseErrorMessage -> PP a
ppError Maybe SrcLoc
forall a. Maybe a
Nothing (ParseErrorMessage
 -> ReaderT
      PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a)
-> ParseErrorMessage
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall a b. (a -> b) -> a -> b
$ NonEmpty [Char] -> ParseErrorMessage
ParseErrorUnrecognised NonEmpty [Char]
leftovers
  Maybe
  ((Validation ParseError a, PPState),
   NonDetT IO (Validation ParseError a, PPState))
mTup <- ReaderT
  PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
-> PPState
-> PPEnv
-> IO
     (Maybe
        ((Validation ParseError a, PPState),
         NonDetT IO (Validation ParseError a, PPState)))
forall a.
PP a
-> PPState
-> PPEnv
-> IO
     (Maybe
        ((Validation ParseError a, PPState),
         NonDetT IO (Validation ParseError a, PPState)))
runPPLazy ReaderT
  PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
go' PPState
ppState PPEnv
ppEnv
  case Maybe
  ((Validation ParseError a, PPState),
   NonDetT IO (Validation ParseError a, PPState))
mTup of
    Maybe
  ((Validation ParseError a, PPState),
   NonDetT IO (Validation ParseError a, PPState))
Nothing -> [Char] -> IO (Either (NonEmpty ParseError) a)
forall a. HasCallStack => [Char] -> a
error [Char]
"TODO figure out when this list can be empty"
    Just ((Validation ParseError a
errOrRes, PPState
_), NonDetT IO (Validation ParseError a, PPState)
nexts) -> case Validation ParseError a
errOrRes of
      Success a
a -> Either (NonEmpty ParseError) a
-> IO (Either (NonEmpty ParseError) a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either (NonEmpty ParseError) a
forall a b. b -> Either a b
Right a
a)
      Failure NonEmpty ParseError
firstErrors ->
        let goNexts :: NonDetT IO (Validation ParseError a, PPState)
-> IO (Either (NonEmpty ParseError) a)
goNexts NonDetT IO (Validation ParseError a, PPState)
ns = do
              -- TODO: Consider keeping around all errors?
              Maybe
  ((Validation ParseError a, PPState),
   NonDetT IO (Validation ParseError a, PPState))
mNext <- NonDetT IO (Validation ParseError a, PPState)
-> IO
     (Maybe
        ((Validation ParseError a, PPState),
         NonDetT IO (Validation ParseError a, PPState)))
forall (m :: * -> *) a.
Monad m =>
NonDetT m a -> m (Maybe (a, NonDetT m a))
runNonDetTLazy NonDetT IO (Validation ParseError a, PPState)
ns
              case Maybe
  ((Validation ParseError a, PPState),
   NonDetT IO (Validation ParseError a, PPState))
mNext of
                Maybe
  ((Validation ParseError a, PPState),
   NonDetT IO (Validation ParseError a, PPState))
Nothing -> Either (NonEmpty ParseError) a
-> IO (Either (NonEmpty ParseError) a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty ParseError -> Either (NonEmpty ParseError) a
forall a b. a -> Either a b
Left NonEmpty ParseError
firstErrors)
                Just ((Validation ParseError a
eOR, PPState
_), NonDetT IO (Validation ParseError a, PPState)
ns') -> case Validation ParseError a
eOR of
                  Success a
a -> Either (NonEmpty ParseError) a
-> IO (Either (NonEmpty ParseError) a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either (NonEmpty ParseError) a
forall a b. b -> Either a b
Right a
a)
                  Failure NonEmpty ParseError
_ -> NonDetT IO (Validation ParseError a, PPState)
-> IO (Either (NonEmpty ParseError) a)
goNexts NonDetT IO (Validation ParseError a, PPState)
ns'
         in NonDetT IO (Validation ParseError a, PPState)
-> IO (Either (NonEmpty ParseError) a)
goNexts NonDetT IO (Validation ParseError a, PPState)
nexts
  where
    go ::
      Parser a ->
      PP a
    go :: forall a. Parser a -> PP a
go = \case
      ParserPure a
a -> a -> PP a
forall a.
a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
      ParserAp Parser (a1 -> a)
ff Parser a1
fa -> Parser (a1 -> a) -> PP (a1 -> a)
forall a. Parser a -> PP a
go Parser (a1 -> a)
ff PP (a1 -> a)
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a1
-> PP a
forall a b.
ReaderT
  PPEnv
  (ValidationT ParseError (StateT PPState (NonDetT IO)))
  (a -> b)
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser a1
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a1
forall a. Parser a -> PP a
go Parser a1
fa
      ParserEmpty Maybe SrcLoc
mLoc -> Maybe SrcLoc -> ParseErrorMessage -> PP a
forall a. Maybe SrcLoc -> ParseErrorMessage -> PP a
ppError Maybe SrcLoc
mLoc ParseErrorMessage
ParseErrorEmpty
      ParserSelect Parser (Either a1 a)
fe Parser (a1 -> a)
ff -> ReaderT
  PPEnv
  (ValidationT ParseError (StateT PPState (NonDetT IO)))
  (Either a1 a)
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (a1 -> a)
-> PP a
forall a b.
ReaderT
  PPEnv
  (ValidationT ParseError (StateT PPState (NonDetT IO)))
  (Either a b)
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (a -> b)
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) b
forall (f :: * -> *) a b.
Selective f =>
f (Either a b) -> f (a -> b) -> f b
select (Parser (Either a1 a)
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (Either a1 a)
forall a. Parser a -> PP a
go Parser (Either a1 a)
fe) (Parser (a1 -> a)
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (a1 -> a)
forall a. Parser a -> PP a
go Parser (a1 -> a)
ff)
      ParserAlt Parser a
p1 Parser a
p2 -> do
        Maybe a
eor <- PP a -> PP (Maybe a)
forall a. PP a -> PP (Maybe a)
tryPP (Parser a -> PP a
forall a. Parser a -> PP a
go Parser a
p1)
        case Maybe a
eor of
          Just a
a -> a -> PP a
forall a.
a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
          Maybe a
Nothing -> Parser a -> PP a
forall a. Parser a -> PP a
go Parser a
p2
      ParserMany Parser a1
p' -> do
        Maybe a1
eor <- PP a1 -> PP (Maybe a1)
forall a. PP a -> PP (Maybe a)
tryPP (PP a1 -> PP (Maybe a1)) -> PP a1 -> PP (Maybe a1)
forall a b. (a -> b) -> a -> b
$ Parser a1 -> PP a1
forall a. Parser a -> PP a
go Parser a1
p'
        case Maybe a1
eor of
          Maybe a1
Nothing -> a -> PP a
forall a.
a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
          Just a1
a -> do
            [a1]
as <- Parser [a1] -> PP [a1]
forall a. Parser a -> PP a
go (Parser a1 -> Parser [a1]
forall a. Parser a -> Parser [a]
ParserMany Parser a1
p')
            pure (a1
a a1 -> [a1] -> [a1]
forall a. a -> [a] -> [a]
: [a1]
as)
      ParserAllOrNothing Maybe SrcLoc
mLoc Parser a
p' -> do
        PPEnv
e <- ReaderT
  PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) PPEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
        PPState
s <- ReaderT
  PPEnv
  (ValidationT ParseError (StateT PPState (NonDetT IO)))
  PPState
forall s (m :: * -> *). MonadState s m => m s
get
        [(Validation ParseError a, PPState)]
results <- IO [(Validation ParseError a, PPState)]
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     [(Validation ParseError a, PPState)]
forall a.
IO a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(Validation ParseError a, PPState)]
 -> ReaderT
      PPEnv
      (ValidationT ParseError (StateT PPState (NonDetT IO)))
      [(Validation ParseError a, PPState)])
-> IO [(Validation ParseError a, PPState)]
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     [(Validation ParseError a, PPState)]
forall a b. (a -> b) -> a -> b
$ PP a -> PPState -> PPEnv -> IO [(Validation ParseError a, PPState)]
forall a.
PP a -> PPState -> PPEnv -> IO [(Validation ParseError a, PPState)]
runPP (Parser a -> PP a
forall a. Parser a -> PP a
go Parser a
p') PPState
s PPEnv
e
        (Validation ParseError a
result, PPState
s') <- [(Validation ParseError a, PPState)]
-> PP (Validation ParseError a, PPState)
forall a. [a] -> PP a
ppNonDetList [(Validation ParseError a, PPState)]
results
        PPState
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put PPState
s'
        case Validation ParseError a
result of
          Success a
a -> a -> PP a
forall a.
a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
          Failure NonEmpty ParseError
errs -> do
            if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (ParseError -> Bool) -> NonEmpty ParseError -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ParseError -> Bool
errorIsForgivable NonEmpty ParseError
errs
              then NonEmpty ParseError -> PP a
forall a. NonEmpty ParseError -> PP a
ppErrors' NonEmpty ParseError
errs
              else do
                -- Settings available below
                let settingsSet :: Set SrcLocHash
settingsSet = Parser a -> Set SrcLocHash
forall a. Parser a -> Set SrcLocHash
parserSettingsSet Parser a
p'
                -- Settings that have been parsed
                Set SrcLocHash
parsedSet <- (PPState -> Set SrcLocHash)
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (Set SrcLocHash)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PPState -> Set SrcLocHash
ppStateParsedSettings
                -- Settings that have been parsed below
                let parsedSettingsSet :: Set SrcLocHash
parsedSettingsSet = Set SrcLocHash
settingsSet Set SrcLocHash -> Set SrcLocHash -> Set SrcLocHash
forall a. Ord a => Set a -> Set a -> Set a
`S.intersection` Set SrcLocHash
parsedSet
                -- If any settings have been parsed below, and parsing still failed
                -- (this is the case because we're in the failure branch)
                -- with only forgivable errors
                -- (this is the case because we're in the branch where that's been checked)
                -- then this should be an unforgivable error.
                if Bool -> Bool
not (Set SrcLocHash -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set SrcLocHash
parsedSettingsSet)
                  then NonEmpty ParseError -> PP a
forall a. NonEmpty ParseError -> PP a
ppErrors' (NonEmpty ParseError -> PP a) -> NonEmpty ParseError -> PP a
forall a b. (a -> b) -> a -> b
$ NonEmpty ParseError
errs NonEmpty ParseError -> NonEmpty ParseError -> NonEmpty ParseError
forall a. Semigroup a => a -> a -> a
<> (Maybe SrcLoc -> ParseErrorMessage -> ParseError
ParseError Maybe SrcLoc
mLoc ParseErrorMessage
ParseErrorAllOrNothing ParseError -> [ParseError] -> NonEmpty ParseError
forall a. a -> [a] -> NonEmpty a
:| [])
                  else NonEmpty ParseError -> PP a
forall a. NonEmpty ParseError -> PP a
ppErrors' NonEmpty ParseError
errs
      ParserCheck Maybe SrcLoc
mLoc Bool
forgivable a1 -> IO (Either [Char] a)
f Parser a1
p' -> do
        a1
a <- Parser a1 -> PP a1
forall a. Parser a -> PP a
go Parser a1
p'
        Either [Char] a
errOrB <- IO (Either [Char] a)
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (Either [Char] a)
forall a.
IO a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either [Char] a)
 -> ReaderT
      PPEnv
      (ValidationT ParseError (StateT PPState (NonDetT IO)))
      (Either [Char] a))
-> IO (Either [Char] a)
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (Either [Char] a)
forall a b. (a -> b) -> a -> b
$ a1 -> IO (Either [Char] a)
f a1
a
        case Either [Char] a
errOrB of
          Left [Char]
err -> Maybe SrcLoc -> ParseErrorMessage -> PP a
forall a. Maybe SrcLoc -> ParseErrorMessage -> PP a
ppError Maybe SrcLoc
mLoc (ParseErrorMessage -> PP a) -> ParseErrorMessage -> PP a
forall a b. (a -> b) -> a -> b
$ Bool -> [Char] -> ParseErrorMessage
ParseErrorCheckFailed Bool
forgivable [Char]
err
          Right a
b -> a -> PP a
forall a.
a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
b
      ParserCommands Maybe SrcLoc
mLoc [Command a]
cs -> do
        Maybe [Char]
mS <- PP (Maybe [Char])
ppArg
        case Maybe [Char]
mS of
          Maybe [Char]
Nothing -> Maybe SrcLoc -> ParseErrorMessage -> PP a
forall a. Maybe SrcLoc -> ParseErrorMessage -> PP a
ppError Maybe SrcLoc
mLoc (ParseErrorMessage -> PP a) -> ParseErrorMessage -> PP a
forall a b. (a -> b) -> a -> b
$ [[Char]] -> ParseErrorMessage
ParseErrorMissingCommand ([[Char]] -> ParseErrorMessage) -> [[Char]] -> ParseErrorMessage
forall a b. (a -> b) -> a -> b
$ (Command a -> [Char]) -> [Command a] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Command a -> [Char]
forall a. Command a -> [Char]
commandArg [Command a]
cs
          Just [Char]
s -> case (Command a -> Bool) -> [Command a] -> Maybe (Command a)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (([Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
s) ([Char] -> Bool) -> (Command a -> [Char]) -> Command a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Command a -> [Char]
forall a. Command a -> [Char]
commandArg) [Command a]
cs of
            Maybe (Command a)
Nothing -> Maybe SrcLoc -> ParseErrorMessage -> PP a
forall a. Maybe SrcLoc -> ParseErrorMessage -> PP a
ppError Maybe SrcLoc
mLoc (ParseErrorMessage -> PP a) -> ParseErrorMessage -> PP a
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]] -> ParseErrorMessage
ParseErrorUnrecognisedCommand [Char]
s ((Command a -> [Char]) -> [Command a] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Command a -> [Char]
forall a. Command a -> [Char]
commandArg [Command a]
cs)
            Just Command a
c -> Parser a -> PP a
forall a. Parser a -> PP a
go (Parser a -> PP a) -> Parser a -> PP a
forall a b. (a -> b) -> a -> b
$ Command a -> Parser a
forall a. Command a -> Parser a
commandParser Command a
c
      ParserWithConfig Parser (Maybe Object)
pc Parser a
pa -> do
        Maybe Object
mNewConfig <- Parser (Maybe Object) -> PP (Maybe Object)
forall a. Parser a -> PP a
go Parser (Maybe Object)
pc
        (PPEnv -> PPEnv) -> PP a -> PP a
forall a.
(PPEnv -> PPEnv)
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\PPEnv
e -> PPEnv
e {ppEnvConf = mNewConfig}) (PP a -> PP a) -> PP a -> PP a
forall a b. (a -> b) -> a -> b
$ Parser a -> PP a
forall a. Parser a -> PP a
go Parser a
pa
      ParserSetting Maybe SrcLoc
mLoc set :: Setting a
set@Setting {Bool
[[Char]]
[Dashed]
[Reader a]
Maybe a
Maybe [Char]
Maybe (NonEmpty [Char])
Maybe (NonEmpty (NonEmpty [Char], DecodingCodec a))
Maybe (a, [Char])
settingDasheds :: [Dashed]
settingReaders :: [Reader a]
settingTryArgument :: Bool
settingSwitchValue :: Maybe a
settingTryOption :: Bool
settingEnvVars :: Maybe (NonEmpty [Char])
settingConfigVals :: Maybe (NonEmpty (NonEmpty [Char], DecodingCodec a))
settingDefaultValue :: Maybe (a, [Char])
settingExamples :: [[Char]]
settingHidden :: Bool
settingMetavar :: Maybe [Char]
settingHelp :: Maybe [Char]
settingDasheds :: forall a. Setting a -> [Dashed]
settingReaders :: forall a. Setting a -> [Reader a]
settingTryArgument :: forall a. Setting a -> Bool
settingSwitchValue :: forall a. Setting a -> Maybe a
settingTryOption :: forall a. Setting a -> Bool
settingEnvVars :: forall a. Setting a -> Maybe (NonEmpty [Char])
settingConfigVals :: forall a.
Setting a -> Maybe (NonEmpty (NonEmpty [Char], DecodingCodec a))
settingDefaultValue :: forall a. Setting a -> Maybe (a, [Char])
settingExamples :: forall a. Setting a -> [[Char]]
settingHidden :: forall a. Setting a -> Bool
settingMetavar :: forall a. Setting a -> Maybe [Char]
settingHelp :: forall a. Setting a -> Maybe [Char]
..} -> do
        let markParsed :: ReaderT
  PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) ()
markParsed = do
              ReaderT
  PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) ()
-> (SrcLoc
    -> ReaderT
         PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) ())
-> Maybe SrcLoc
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                (()
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) ()
forall a.
a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
                ( \SrcLoc
loc -> (PPState -> PPState)
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ((PPState -> PPState)
 -> ReaderT
      PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) ())
-> (PPState -> PPState)
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) ()
forall a b. (a -> b) -> a -> b
$ \PPState
s ->
                    PPState
s
                      { ppStateParsedSettings =
                          S.insert
                            (hashSrcLoc loc)
                            (ppStateParsedSettings s)
                      }
                )
                Maybe SrcLoc
mLoc
        let mOptDoc :: Maybe OptDoc
mOptDoc = Setting a -> Maybe OptDoc
forall a. Setting a -> Maybe OptDoc
settingOptDoc Setting a
set
        ParseResult a
mArg <-
          if Bool
settingTryArgument
            then do
              -- Require readers before finding the argument so the parser
              -- always fails if it's missing a reader.
              NonEmpty (Reader a)
rs <- [Reader a] -> PP (NonEmpty (Reader a))
forall a. [Reader a] -> PP (NonEmpty (Reader a))
requireReaders [Reader a]
settingReaders
              Maybe [Char]
mS <- PP (Maybe [Char])
ppArg
              case Maybe [Char]
mS of
                Maybe [Char]
Nothing -> ParseResult a
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (ParseResult a)
forall a.
a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ParseResult a
forall a. ParseResult a
NotFound
                Just [Char]
argStr -> do
                  case NonEmpty (Reader a) -> [Char] -> Either (NonEmpty [Char]) a
forall a.
NonEmpty (Reader a) -> [Char] -> Either (NonEmpty [Char]) a
tryReaders NonEmpty (Reader a)
rs [Char]
argStr of
                    Left NonEmpty [Char]
errs -> Maybe SrcLoc
-> ParseErrorMessage
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (ParseResult a)
forall a. Maybe SrcLoc -> ParseErrorMessage -> PP a
ppError Maybe SrcLoc
mLoc (ParseErrorMessage
 -> ReaderT
      PPEnv
      (ValidationT ParseError (StateT PPState (NonDetT IO)))
      (ParseResult a))
-> ParseErrorMessage
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (ParseResult a)
forall a b. (a -> b) -> a -> b
$ Maybe OptDoc -> NonEmpty [Char] -> ParseErrorMessage
ParseErrorArgumentRead Maybe OptDoc
mOptDoc NonEmpty [Char]
errs
                    Right a
a -> ParseResult a
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (ParseResult a)
forall a.
a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParseResult a
 -> ReaderT
      PPEnv
      (ValidationT ParseError (StateT PPState (NonDetT IO)))
      (ParseResult a))
-> ParseResult a
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (ParseResult a)
forall a b. (a -> b) -> a -> b
$ a -> ParseResult a
forall a. a -> ParseResult a
Found a
a
            else ParseResult a
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (ParseResult a)
forall a.
a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ParseResult a
forall a. ParseResult a
NotRun

        case ParseResult a
mArg of
          Found a
a -> do
            ReaderT
  PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) ()
markParsed
            pure a
a
          ParseResult a
_ -> do
            -- TODO do this without all the nesting
            ParseResult a
mSwitch <- case Maybe a
settingSwitchValue of
              Maybe a
Nothing -> ParseResult a
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (ParseResult a)
forall a.
a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ParseResult a
forall a. ParseResult a
NotRun
              Just a
a -> do
                Maybe ()
mS <- [Dashed] -> PP (Maybe ())
ppSwitch [Dashed]
settingDasheds
                case Maybe ()
mS of
                  Maybe ()
Nothing -> ParseResult a
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (ParseResult a)
forall a.
a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ParseResult a
forall a. ParseResult a
NotFound
                  Just () -> ParseResult a
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (ParseResult a)
forall a.
a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParseResult a
 -> ReaderT
      PPEnv
      (ValidationT ParseError (StateT PPState (NonDetT IO)))
      (ParseResult a))
-> ParseResult a
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (ParseResult a)
forall a b. (a -> b) -> a -> b
$ a -> ParseResult a
forall a. a -> ParseResult a
Found a
a

            case ParseResult a
mSwitch of
              Found a
a -> do
                ReaderT
  PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) ()
markParsed
                pure a
a
              ParseResult a
_ -> do
                ParseResult a
mOpt <-
                  if Bool
settingTryOption
                    then do
                      -- Require readers before finding the option so the parser
                      -- always fails if it's missing a reader.
                      NonEmpty (Reader a)
rs <- [Reader a] -> PP (NonEmpty (Reader a))
forall a. [Reader a] -> PP (NonEmpty (Reader a))
requireReaders [Reader a]
settingReaders
                      Maybe [Char]
mS <- [Dashed] -> PP (Maybe [Char])
ppOpt [Dashed]
settingDasheds
                      case Maybe [Char]
mS of
                        Maybe [Char]
Nothing -> ParseResult a
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (ParseResult a)
forall a.
a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ParseResult a
forall a. ParseResult a
NotFound
                        Just [Char]
optionStr -> do
                          case NonEmpty (Reader a) -> [Char] -> Either (NonEmpty [Char]) a
forall a.
NonEmpty (Reader a) -> [Char] -> Either (NonEmpty [Char]) a
tryReaders NonEmpty (Reader a)
rs [Char]
optionStr of
                            Left NonEmpty [Char]
err -> Maybe SrcLoc
-> ParseErrorMessage
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (ParseResult a)
forall a. Maybe SrcLoc -> ParseErrorMessage -> PP a
ppError Maybe SrcLoc
mLoc (ParseErrorMessage
 -> ReaderT
      PPEnv
      (ValidationT ParseError (StateT PPState (NonDetT IO)))
      (ParseResult a))
-> ParseErrorMessage
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (ParseResult a)
forall a b. (a -> b) -> a -> b
$ Maybe OptDoc -> NonEmpty [Char] -> ParseErrorMessage
ParseErrorOptionRead Maybe OptDoc
mOptDoc NonEmpty [Char]
err
                            Right a
a -> ParseResult a
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (ParseResult a)
forall a.
a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParseResult a
 -> ReaderT
      PPEnv
      (ValidationT ParseError (StateT PPState (NonDetT IO)))
      (ParseResult a))
-> ParseResult a
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (ParseResult a)
forall a b. (a -> b) -> a -> b
$ a -> ParseResult a
forall a. a -> ParseResult a
Found a
a
                    else ParseResult a
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (ParseResult a)
forall a.
a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ParseResult a
forall a. ParseResult a
NotRun

                case ParseResult a
mOpt of
                  Found a
a -> do
                    ReaderT
  PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) ()
markParsed
                    pure a
a
                  ParseResult a
_ -> do
                    let mEnvDoc :: Maybe EnvDoc
mEnvDoc = Setting a -> Maybe EnvDoc
forall a. Setting a -> Maybe EnvDoc
settingEnvDoc Setting a
set
                    ParseResult a
mEnv <- case Maybe (NonEmpty [Char])
settingEnvVars of
                      Maybe (NonEmpty [Char])
Nothing -> ParseResult a
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (ParseResult a)
forall a.
a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ParseResult a
forall a. ParseResult a
NotRun
                      Just NonEmpty [Char]
ne -> do
                        -- Require readers before finding the env vars so the parser
                        -- always fails if it's missing a reader.
                        NonEmpty (Reader a)
rs <- [Reader a] -> PP (NonEmpty (Reader a))
forall a. [Reader a] -> PP (NonEmpty (Reader a))
requireReaders [Reader a]
settingReaders
                        EnvMap
es <- (PPEnv -> EnvMap)
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) EnvMap
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PPEnv -> EnvMap
ppEnvEnv
                        let founds :: [[Char]]
founds = ([Char] -> Maybe [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([Char] -> EnvMap -> Maybe [Char]
`EnvMap.lookup` EnvMap
es) (NonEmpty [Char] -> [[Char]]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty [Char]
ne)
                        -- Run the parser on all specified env vars before
                        -- returning the first because we want to fail if any
                        -- of them fail, even if they wouldn't be the parse
                        -- result.
                        [a]
results <- [[Char]]
-> ([Char] -> PP a)
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [[Char]]
founds (([Char] -> PP a)
 -> ReaderT
      PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) [a])
-> ([Char] -> PP a)
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) [a]
forall a b. (a -> b) -> a -> b
$ \[Char]
varStr ->
                          case NonEmpty (Reader a) -> [Char] -> Either (NonEmpty [Char]) a
forall a.
NonEmpty (Reader a) -> [Char] -> Either (NonEmpty [Char]) a
tryReaders NonEmpty (Reader a)
rs [Char]
varStr of
                            Left NonEmpty [Char]
errs -> Maybe SrcLoc -> ParseErrorMessage -> PP a
forall a. Maybe SrcLoc -> ParseErrorMessage -> PP a
ppError Maybe SrcLoc
mLoc (ParseErrorMessage -> PP a) -> ParseErrorMessage -> PP a
forall a b. (a -> b) -> a -> b
$ Maybe EnvDoc -> NonEmpty [Char] -> ParseErrorMessage
ParseErrorEnvRead Maybe EnvDoc
mEnvDoc NonEmpty [Char]
errs
                            Right a
a -> a -> PP a
forall a.
a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
                        pure $ ParseResult a -> (a -> ParseResult a) -> Maybe a -> ParseResult a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ParseResult a
forall a. ParseResult a
NotFound a -> ParseResult a
forall a. a -> ParseResult a
Found (Maybe a -> ParseResult a) -> Maybe a -> ParseResult a
forall a b. (a -> b) -> a -> b
$ [a] -> Maybe a
forall a. [a] -> Maybe a
listToMaybe [a]
results

                    case ParseResult a
mEnv of
                      Found a
a -> do
                        ReaderT
  PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) ()
markParsed
                        pure a
a
                      ParseResult a
_ -> do
                        let mConfDoc :: Maybe ConfDoc
mConfDoc = Setting a -> Maybe ConfDoc
forall a. Setting a -> Maybe ConfDoc
settingConfDoc Setting a
set
                        ParseResult a
mConf <- case Maybe (NonEmpty (NonEmpty [Char], DecodingCodec a))
settingConfigVals of
                          Maybe (NonEmpty (NonEmpty [Char], DecodingCodec a))
Nothing -> ParseResult a
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (ParseResult a)
forall a.
a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ParseResult a
forall a. ParseResult a
NotRun
                          Just ((NonEmpty [Char]
ne, DecodingCodec ValueCodec void (Maybe a)
c) :| [(NonEmpty [Char], DecodingCodec a)]
_) -> do
                            -- TODO try parsing with the others
                            Maybe Object
mObj <- (PPEnv -> Maybe Object) -> PP (Maybe Object)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PPEnv -> Maybe Object
ppEnvConf
                            case Maybe Object
mObj of
                              Maybe Object
Nothing -> ParseResult a
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (ParseResult a)
forall a.
a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ParseResult a
forall a. ParseResult a
NotFound
                              Just Object
obj -> do
                                let jsonParser :: JSON.Object -> NonEmpty String -> JSON.Parser (Maybe JSON.Value)
                                    jsonParser :: Object -> NonEmpty [Char] -> Parser (Maybe Value)
jsonParser Object
o ([Char]
k :| [[Char]]
rest) = case [[Char]] -> Maybe (NonEmpty [Char])
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [[Char]]
rest of
                                      Maybe (NonEmpty [Char])
Nothing -> do
                                        case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup ([Char] -> Key
Key.fromString [Char]
k) Object
o of
                                          Maybe Value
Nothing -> Maybe Value -> Parser (Maybe Value)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Value
forall a. Maybe a
Nothing
                                          Just Value
v -> Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Parser Value -> Parser (Maybe Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Value
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
                                      Just NonEmpty [Char]
neRest -> do
                                        Maybe Object
mO' <- Object
o Object -> Key -> Parser (Maybe Object)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? [Char] -> Key
Key.fromString [Char]
k
                                        case Maybe Object
mO' of
                                          Maybe Object
Nothing -> Maybe Value -> Parser (Maybe Value)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Value
forall a. Maybe a
Nothing
                                          Just Object
o' -> Object -> NonEmpty [Char] -> Parser (Maybe Value)
jsonParser Object
o' NonEmpty [Char]
neRest
                                case (NonEmpty [Char] -> Parser (Maybe Value))
-> NonEmpty [Char] -> Either [Char] (Maybe Value)
forall a b. (a -> Parser b) -> a -> Either [Char] b
JSON.parseEither (Object -> NonEmpty [Char] -> Parser (Maybe Value)
jsonParser Object
obj) NonEmpty [Char]
ne of
                                  Left [Char]
err -> Maybe SrcLoc
-> ParseErrorMessage
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (ParseResult a)
forall a. Maybe SrcLoc -> ParseErrorMessage -> PP a
ppError Maybe SrcLoc
mLoc (ParseErrorMessage
 -> ReaderT
      PPEnv
      (ValidationT ParseError (StateT PPState (NonDetT IO)))
      (ParseResult a))
-> ParseErrorMessage
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (ParseResult a)
forall a b. (a -> b) -> a -> b
$ Maybe ConfDoc -> [Char] -> ParseErrorMessage
ParseErrorConfigRead Maybe ConfDoc
mConfDoc [Char]
err
                                  Right Maybe Value
mV -> case Maybe Value
mV of
                                    Maybe Value
Nothing -> ParseResult a
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (ParseResult a)
forall a.
a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ParseResult a
forall a. ParseResult a
NotFound
                                    Just Value
v -> case (Value -> Parser (Maybe a)) -> Value -> Either [Char] (Maybe a)
forall a b. (a -> Parser b) -> a -> Either [Char] b
JSON.parseEither (ValueCodec void (Maybe a) -> Value -> Parser (Maybe a)
forall void a. ValueCodec void a -> Value -> Parser a
parseJSONVia ValueCodec void (Maybe a)
c) Value
v of
                                      Left [Char]
err -> Maybe SrcLoc
-> ParseErrorMessage
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (ParseResult a)
forall a. Maybe SrcLoc -> ParseErrorMessage -> PP a
ppError Maybe SrcLoc
mLoc (ParseErrorMessage
 -> ReaderT
      PPEnv
      (ValidationT ParseError (StateT PPState (NonDetT IO)))
      (ParseResult a))
-> ParseErrorMessage
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (ParseResult a)
forall a b. (a -> b) -> a -> b
$ Maybe ConfDoc -> [Char] -> ParseErrorMessage
ParseErrorConfigRead Maybe ConfDoc
mConfDoc [Char]
err
                                      Right Maybe a
a -> ParseResult a
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (ParseResult a)
forall a.
a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParseResult a
 -> ReaderT
      PPEnv
      (ValidationT ParseError (StateT PPState (NonDetT IO)))
      (ParseResult a))
-> ParseResult a
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (ParseResult a)
forall a b. (a -> b) -> a -> b
$ ParseResult a -> (a -> ParseResult a) -> Maybe a -> ParseResult a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ParseResult a
forall a. ParseResult a
NotFound a -> ParseResult a
forall a. a -> ParseResult a
Found Maybe a
a

                        case ParseResult a
mConf of
                          Found a
a -> do
                            ReaderT
  PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) ()
markParsed
                            pure a
a
                          ParseResult a
_ ->
                            case Maybe (a, [Char])
settingDefaultValue of
                              Just (a
a, [Char]
_) -> a -> PP a
forall a.
a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a -- Don't mark as parsed
                              Maybe (a, [Char])
Nothing -> do
                                let parseResultError :: a -> ParseResult a -> Maybe a
parseResultError a
e ParseResult a
res = case ParseResult a
res of
                                      ParseResult a
NotRun -> Maybe a
forall a. Maybe a
Nothing
                                      ParseResult a
NotFound -> a -> Maybe a
forall a. a -> Maybe a
Just a
e
                                      Found a
_ -> Maybe a
forall a. Maybe a
Nothing -- Should not happen.
                                PP a
-> (NonEmpty ParseErrorMessage -> PP a)
-> Maybe (NonEmpty ParseErrorMessage)
-> PP a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe SrcLoc -> ParseErrorMessage -> PP a
forall a. Maybe SrcLoc -> ParseErrorMessage -> PP a
ppError Maybe SrcLoc
mLoc ParseErrorMessage
ParseErrorEmptySetting) (Maybe SrcLoc -> NonEmpty ParseErrorMessage -> PP a
forall a. Maybe SrcLoc -> NonEmpty ParseErrorMessage -> PP a
ppErrors Maybe SrcLoc
mLoc) (Maybe (NonEmpty ParseErrorMessage) -> PP a)
-> Maybe (NonEmpty ParseErrorMessage) -> PP a
forall a b. (a -> b) -> a -> b
$
                                  [ParseErrorMessage] -> Maybe (NonEmpty ParseErrorMessage)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([ParseErrorMessage] -> Maybe (NonEmpty ParseErrorMessage))
-> [ParseErrorMessage] -> Maybe (NonEmpty ParseErrorMessage)
forall a b. (a -> b) -> a -> b
$
                                    [Maybe ParseErrorMessage] -> [ParseErrorMessage]
forall a. [Maybe a] -> [a]
catMaybes
                                      [ ParseErrorMessage -> ParseResult a -> Maybe ParseErrorMessage
forall {a} {a}. a -> ParseResult a -> Maybe a
parseResultError (Maybe OptDoc -> ParseErrorMessage
ParseErrorMissingArgument Maybe OptDoc
mOptDoc) ParseResult a
mArg,
                                        ParseErrorMessage -> ParseResult a -> Maybe ParseErrorMessage
forall {a} {a}. a -> ParseResult a -> Maybe a
parseResultError (Maybe OptDoc -> ParseErrorMessage
ParseErrorMissingSwitch Maybe OptDoc
mOptDoc) ParseResult a
mSwitch,
                                        ParseErrorMessage -> ParseResult a -> Maybe ParseErrorMessage
forall {a} {a}. a -> ParseResult a -> Maybe a
parseResultError (Maybe OptDoc -> ParseErrorMessage
ParseErrorMissingOption Maybe OptDoc
mOptDoc) ParseResult a
mOpt,
                                        ParseErrorMessage -> ParseResult a -> Maybe ParseErrorMessage
forall {a} {a}. a -> ParseResult a -> Maybe a
parseResultError (Maybe EnvDoc -> ParseErrorMessage
ParseErrorMissingEnvVar Maybe EnvDoc
mEnvDoc) ParseResult a
mEnv,
                                        ParseErrorMessage -> ParseResult a -> Maybe ParseErrorMessage
forall {a} {a}. a -> ParseResult a -> Maybe a
parseResultError (Maybe ConfDoc -> ParseErrorMessage
ParseErrorMissingConfVal Maybe ConfDoc
mConfDoc) ParseResult a
mConf
                                      ]

data ParseResult a
  = NotRun
  | NotFound
  | Found a

requireReaders :: [Reader a] -> PP (NonEmpty (Reader a))
requireReaders :: forall a. [Reader a] -> PP (NonEmpty (Reader a))
requireReaders [Reader a]
rs = case [Reader a] -> Maybe (NonEmpty (Reader a))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Reader a]
rs of
  Maybe (NonEmpty (Reader a))
Nothing -> Maybe SrcLoc -> ParseErrorMessage -> PP (NonEmpty (Reader a))
forall a. Maybe SrcLoc -> ParseErrorMessage -> PP a
ppError Maybe SrcLoc
forall a. Maybe a
Nothing ParseErrorMessage
ParseErrorNoReaders
  Just NonEmpty (Reader a)
ne -> NonEmpty (Reader a) -> PP (NonEmpty (Reader a))
forall a.
a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NonEmpty (Reader a)
ne

-- Try the readers in order
tryReaders :: NonEmpty (Reader a) -> String -> Either (NonEmpty String) a
tryReaders :: forall a.
NonEmpty (Reader a) -> [Char] -> Either (NonEmpty [Char]) a
tryReaders NonEmpty (Reader a)
rs [Char]
s = (NonEmpty [Char] -> NonEmpty [Char])
-> Either (NonEmpty [Char]) a -> Either (NonEmpty [Char]) a
forall b c d. (b -> c) -> Either b d -> Either c d
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left NonEmpty [Char] -> NonEmpty [Char]
forall a. NonEmpty a -> NonEmpty a
NE.reverse (Either (NonEmpty [Char]) a -> Either (NonEmpty [Char]) a)
-> Either (NonEmpty [Char]) a -> Either (NonEmpty [Char]) a
forall a b. (a -> b) -> a -> b
$ NonEmpty (Reader a) -> Either (NonEmpty [Char]) a
go NonEmpty (Reader a)
rs
  where
    go :: NonEmpty (Reader a) -> Either (NonEmpty [Char]) a
go (Reader a
r :| [Reader a]
rl) = case Reader a -> [Char] -> Either [Char] a
forall a. Reader a -> [Char] -> Either [Char] a
runReader Reader a
r [Char]
s of
      Left [Char]
err -> NonEmpty [Char] -> [Reader a] -> Either (NonEmpty [Char]) a
go' ([Char]
err [Char] -> [[Char]] -> NonEmpty [Char]
forall a. a -> [a] -> NonEmpty a
:| []) [Reader a]
rl
      Right a
a -> a -> Either (NonEmpty [Char]) a
forall a b. b -> Either a b
Right a
a
    go' :: NonEmpty [Char] -> [Reader a] -> Either (NonEmpty [Char]) a
go' NonEmpty [Char]
errs = \case
      [] -> NonEmpty [Char] -> Either (NonEmpty [Char]) a
forall a b. a -> Either a b
Left NonEmpty [Char]
errs
      (Reader a
r : [Reader a]
rl) -> case Reader a -> [Char] -> Either [Char] a
forall a. Reader a -> [Char] -> Either [Char] a
runReader Reader a
r [Char]
s of
        Left [Char]
err -> NonEmpty [Char] -> [Reader a] -> Either (NonEmpty [Char]) a
go' ([Char]
err [Char] -> NonEmpty [Char] -> NonEmpty [Char]
forall a. a -> NonEmpty a -> NonEmpty a
<| NonEmpty [Char]
errs) [Reader a]
rl
        Right a
a -> a -> Either (NonEmpty [Char]) a
forall a b. b -> Either a b
Right a
a

type PP a = ReaderT PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a

runPP ::
  PP a ->
  PPState ->
  PPEnv ->
  IO [(Validation ParseError a, PPState)]
runPP :: forall a.
PP a -> PPState -> PPEnv -> IO [(Validation ParseError a, PPState)]
runPP PP a
p PPState
args PPEnv
envVars =
  NonDetT IO (Validation ParseError a, PPState)
-> IO [(Validation ParseError a, PPState)]
forall (m :: * -> *) a. Monad m => NonDetT m a -> m [a]
runNonDetT (StateT PPState (NonDetT IO) (Validation ParseError a)
-> PPState -> NonDetT IO (Validation ParseError a, PPState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (ValidationT ParseError (StateT PPState (NonDetT IO)) a
-> StateT PPState (NonDetT IO) (Validation ParseError a)
forall e (m :: * -> *) a. ValidationT e m a -> m (Validation e a)
runValidationT (PP a
-> PPEnv -> ValidationT ParseError (StateT PPState (NonDetT IO)) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT PP a
p PPEnv
envVars)) PPState
args)

runPPLazy ::
  PP a ->
  PPState ->
  PPEnv ->
  IO
    ( Maybe
        ( (Validation ParseError a, PPState),
          NonDetT IO (Validation ParseError a, PPState)
        )
    )
runPPLazy :: forall a.
PP a
-> PPState
-> PPEnv
-> IO
     (Maybe
        ((Validation ParseError a, PPState),
         NonDetT IO (Validation ParseError a, PPState)))
runPPLazy PP a
p PPState
args PPEnv
envVars =
  NonDetT IO (Validation ParseError a, PPState)
-> IO
     (Maybe
        ((Validation ParseError a, PPState),
         NonDetT IO (Validation ParseError a, PPState)))
forall (m :: * -> *) a.
Monad m =>
NonDetT m a -> m (Maybe (a, NonDetT m a))
runNonDetTLazy (StateT PPState (NonDetT IO) (Validation ParseError a)
-> PPState -> NonDetT IO (Validation ParseError a, PPState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (ValidationT ParseError (StateT PPState (NonDetT IO)) a
-> StateT PPState (NonDetT IO) (Validation ParseError a)
forall e (m :: * -> *) a. ValidationT e m a -> m (Validation e a)
runValidationT (PP a
-> PPEnv -> ValidationT ParseError (StateT PPState (NonDetT IO)) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT PP a
p PPEnv
envVars)) PPState
args)

tryPP :: PP a -> PP (Maybe a)
tryPP :: forall a. PP a -> PP (Maybe a)
tryPP PP a
pp = do
  PPState
s <- ReaderT
  PPEnv
  (ValidationT ParseError (StateT PPState (NonDetT IO)))
  PPState
forall s (m :: * -> *). MonadState s m => m s
get
  PPEnv
e <- ReaderT
  PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) PPEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
  [(Validation ParseError a, PPState)]
results <- IO [(Validation ParseError a, PPState)]
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     [(Validation ParseError a, PPState)]
forall a.
IO a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(Validation ParseError a, PPState)]
 -> ReaderT
      PPEnv
      (ValidationT ParseError (StateT PPState (NonDetT IO)))
      [(Validation ParseError a, PPState)])
-> IO [(Validation ParseError a, PPState)]
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     [(Validation ParseError a, PPState)]
forall a b. (a -> b) -> a -> b
$ PP a -> PPState -> PPEnv -> IO [(Validation ParseError a, PPState)]
forall a.
PP a -> PPState -> PPEnv -> IO [(Validation ParseError a, PPState)]
runPP PP a
pp PPState
s PPEnv
e
  (Validation ParseError a
errOrRes, PPState
s') <- [(Validation ParseError a, PPState)]
-> PP (Validation ParseError a, PPState)
forall a. [a] -> PP a
ppNonDetList [(Validation ParseError a, PPState)]
results
  PPState
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put PPState
s'
  case Validation ParseError a
errOrRes of
    Failure NonEmpty ParseError
errs ->
      if (ParseError -> Bool) -> NonEmpty ParseError -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ParseError -> Bool
errorIsForgivable NonEmpty ParseError
errs
        then Maybe a -> PP (Maybe a)
forall a.
a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
        else NonEmpty ParseError -> PP (Maybe a)
forall a. NonEmpty ParseError -> PP a
ppErrors' NonEmpty ParseError
errs
    Success a
a -> Maybe a -> PP (Maybe a)
forall a.
a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> PP (Maybe a)) -> Maybe a -> PP (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
a

ppNonDet :: NonDetT IO a -> PP a
ppNonDet :: forall a. NonDetT IO a -> PP a
ppNonDet = ValidationT ParseError (StateT PPState (NonDetT IO)) a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall (m :: * -> *) a. Monad m => m a -> ReaderT PPEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ValidationT ParseError (StateT PPState (NonDetT IO)) a
 -> ReaderT
      PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a)
-> (NonDetT IO a
    -> ValidationT ParseError (StateT PPState (NonDetT IO)) a)
-> NonDetT IO a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT PPState (NonDetT IO) a
-> ValidationT ParseError (StateT PPState (NonDetT IO)) a
forall (m :: * -> *) a.
Monad m =>
m a -> ValidationT ParseError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT PPState (NonDetT IO) a
 -> ValidationT ParseError (StateT PPState (NonDetT IO)) a)
-> (NonDetT IO a -> StateT PPState (NonDetT IO) a)
-> NonDetT IO a
-> ValidationT ParseError (StateT PPState (NonDetT IO)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonDetT IO a -> StateT PPState (NonDetT IO) a
forall (m :: * -> *) a. Monad m => m a -> StateT PPState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

ppNonDetList :: [a] -> PP a
ppNonDetList :: forall a. [a] -> PP a
ppNonDetList = NonDetT IO a -> PP a
forall a. NonDetT IO a -> PP a
ppNonDet (NonDetT IO a -> PP a) -> ([a] -> NonDetT IO a) -> [a] -> PP a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> NonDetT IO a
forall (m :: * -> *) a. Applicative m => [a] -> NonDetT m a
liftNonDetTList

data PPState = PPState
  { PPState -> Args
ppStateArgs :: !Args,
    PPState -> Set SrcLocHash
ppStateParsedSettings :: !(Set SrcLocHash)
  }

data PPEnv = PPEnv
  { PPEnv -> EnvMap
ppEnvEnv :: !EnvMap,
    PPEnv -> Maybe Object
ppEnvConf :: !(Maybe JSON.Object)
  }

ppArg :: PP (Maybe String)
ppArg :: PP (Maybe [Char])
ppArg = do
  Args
args <- (PPState -> Args)
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) Args
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PPState -> Args
ppStateArgs
  let consumePossibilities :: [(Maybe [Char], Args)]
consumePossibilities = Args -> [(Maybe [Char], Args)]
Args.consumeArgument Args
args
  (Maybe [Char]
mA, Args
args') <- [(Maybe [Char], Args)] -> PP (Maybe [Char], Args)
forall a. [a] -> PP a
ppNonDetList [(Maybe [Char], Args)]
consumePossibilities
  (PPState -> PPState)
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\PPState
s -> PPState
s {ppStateArgs = args'})
  pure Maybe [Char]
mA

ppOpt :: [Dashed] -> PP (Maybe String)
ppOpt :: [Dashed] -> PP (Maybe [Char])
ppOpt [Dashed]
ds = do
  Args
args <- (PPState -> Args)
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) Args
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PPState -> Args
ppStateArgs
  case [Dashed] -> Args -> Maybe ([Char], Args)
Args.consumeOption [Dashed]
ds Args
args of
    Maybe ([Char], Args)
Nothing -> Maybe [Char] -> PP (Maybe [Char])
forall a.
a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [Char]
forall a. Maybe a
Nothing
    Just ([Char]
a, Args
args') -> do
      (PPState -> PPState)
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\PPState
s -> PPState
s {ppStateArgs = args'})
      pure ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
a)

ppSwitch :: [Dashed] -> PP (Maybe ())
ppSwitch :: [Dashed] -> PP (Maybe ())
ppSwitch [Dashed]
ds = do
  Args
args <- (PPState -> Args)
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) Args
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PPState -> Args
ppStateArgs
  case [Dashed] -> Args -> Maybe Args
Args.consumeSwitch [Dashed]
ds Args
args of
    Maybe Args
Nothing -> Maybe () -> PP (Maybe ())
forall a.
a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ()
forall a. Maybe a
Nothing
    Just Args
args' -> do
      (PPState -> PPState)
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\PPState
s -> PPState
s {ppStateArgs = args'})
      pure (() -> Maybe ()
forall a. a -> Maybe a
Just ())

ppErrors' :: NonEmpty ParseError -> PP a
ppErrors' :: forall a. NonEmpty ParseError -> PP a
ppErrors' = ValidationT ParseError (StateT PPState (NonDetT IO)) a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall (m :: * -> *) a. Monad m => m a -> ReaderT PPEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ValidationT ParseError (StateT PPState (NonDetT IO)) a
 -> ReaderT
      PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a)
-> (NonEmpty ParseError
    -> ValidationT ParseError (StateT PPState (NonDetT IO)) a)
-> NonEmpty ParseError
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT PPState (NonDetT IO) (Validation ParseError a)
-> ValidationT ParseError (StateT PPState (NonDetT IO)) a
forall e (m :: * -> *) a. m (Validation e a) -> ValidationT e m a
ValidationT (StateT PPState (NonDetT IO) (Validation ParseError a)
 -> ValidationT ParseError (StateT PPState (NonDetT IO)) a)
-> (NonEmpty ParseError
    -> StateT PPState (NonDetT IO) (Validation ParseError a))
-> NonEmpty ParseError
-> ValidationT ParseError (StateT PPState (NonDetT IO)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonDetT IO (Validation ParseError a)
-> StateT PPState (NonDetT IO) (Validation ParseError a)
forall (m :: * -> *) a. Monad m => m a -> StateT PPState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (NonDetT IO (Validation ParseError a)
 -> StateT PPState (NonDetT IO) (Validation ParseError a))
-> (NonEmpty ParseError -> NonDetT IO (Validation ParseError a))
-> NonEmpty ParseError
-> StateT PPState (NonDetT IO) (Validation ParseError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validation ParseError a -> NonDetT IO (Validation ParseError a)
forall a. a -> ListT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Validation ParseError a -> NonDetT IO (Validation ParseError a))
-> (NonEmpty ParseError -> Validation ParseError a)
-> NonEmpty ParseError
-> NonDetT IO (Validation ParseError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty ParseError -> Validation ParseError a
forall e a. NonEmpty e -> Validation e a
Failure

ppErrors :: Maybe SrcLoc -> NonEmpty ParseErrorMessage -> PP a
ppErrors :: forall a. Maybe SrcLoc -> NonEmpty ParseErrorMessage -> PP a
ppErrors Maybe SrcLoc
mLoc = NonEmpty ParseError -> PP a
forall a. NonEmpty ParseError -> PP a
ppErrors' (NonEmpty ParseError -> PP a)
-> (NonEmpty ParseErrorMessage -> NonEmpty ParseError)
-> NonEmpty ParseErrorMessage
-> PP a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ParseErrorMessage -> ParseError)
-> NonEmpty ParseErrorMessage -> NonEmpty ParseError
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (Maybe SrcLoc -> ParseErrorMessage -> ParseError
ParseError Maybe SrcLoc
mLoc)

ppError :: Maybe SrcLoc -> ParseErrorMessage -> PP a
ppError :: forall a. Maybe SrcLoc -> ParseErrorMessage -> PP a
ppError Maybe SrcLoc
mLoc = Maybe SrcLoc -> NonEmpty ParseErrorMessage -> PP a
forall a. Maybe SrcLoc -> NonEmpty ParseErrorMessage -> PP a
ppErrors Maybe SrcLoc
mLoc (NonEmpty ParseErrorMessage -> PP a)
-> (ParseErrorMessage -> NonEmpty ParseErrorMessage)
-> ParseErrorMessage
-> PP a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorMessage -> NonEmpty ParseErrorMessage
forall a. a -> NonEmpty a
NE.singleton