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

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

import Autodocodec
import Control.Arrow (left)
import Control.Monad
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 qualified Data.Text as T
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.Nix
import OptEnvConf.NonDet
import OptEnvConf.Output
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 -> String -> IO a
runSettingsParser Version
version String
progDesc =
  Version -> String -> Parser a -> IO a
forall a. Version -> String -> Parser a -> IO a
runParser Version
version String
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 -> String -> Parser a -> IO a
runParser Version
version String
progDesc Parser a
p = do
  [String]
allArgs <- IO [String]
getArgs
  let argMap' :: Args
argMap' = [String] -> Args
parseArgs [String]
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)

  [(String, String)]
completeEnv <- IO [(String, String)]
getEnvironment
  let envVars :: EnvMap
envVars = [(String, String)] -> EnvMap
EnvMap.parse [(String, String)]
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 docs :: AnyDocs (Maybe SetDoc)
docs = Parser a -> AnyDocs (Maybe SetDoc)
forall a. Parser a -> AnyDocs (Maybe SetDoc)
parserDocs Parser a
p

      Maybe TerminalCapabilities
mDebugMode <-
        if Bool
debugMode
          then TerminalCapabilities -> Maybe TerminalCapabilities
forall a. a -> Maybe a
Just (TerminalCapabilities -> Maybe TerminalCapabilities)
-> IO TerminalCapabilities -> IO (Maybe TerminalCapabilities)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO TerminalCapabilities
getTerminalCapabilitiesFromHandle Handle
stderr
          else Maybe TerminalCapabilities -> IO (Maybe TerminalCapabilities)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe TerminalCapabilities
forall a. Maybe a
Nothing

      let mHelpConsumed :: Maybe Args
mHelpConsumed = [Dashed] -> Args -> Maybe Args
consumeSwitch [Dashed
"-h", Dashed
"--help"] Args
argMap
      let (Bool
helpMode, Args
args') = case Maybe Args
mHelpConsumed of
            Maybe Args
Nothing -> (Bool
False, Args
argMap)
            Just Args
am -> (Bool
True, Args
am)

      if Bool
helpMode
        then do
          String
progname <- IO String
getProgName
          Either
  (NonEmpty ParseError) (Maybe ([String], CommandDoc (Maybe SetDoc)))
errOrDocs <- Maybe TerminalCapabilities
-> Args
-> Parser a
-> IO
     (Either
        (NonEmpty ParseError)
        (Maybe ([String], CommandDoc (Maybe SetDoc))))
forall a.
Maybe TerminalCapabilities
-> Args
-> Parser a
-> IO
     (Either
        (NonEmpty ParseError)
        (Maybe ([String], CommandDoc (Maybe SetDoc))))
runHelpParser Maybe TerminalCapabilities
mDebugMode Args
args' Parser a
p
          case Either
  (NonEmpty ParseError) (Maybe ([String], CommandDoc (Maybe SetDoc)))
errOrDocs of
            Left NonEmpty ParseError
errs -> do
              TerminalCapabilities
stderrTc <- Handle -> IO TerminalCapabilities
getTerminalCapabilitiesFromHandle Handle
stderr
              TerminalCapabilities -> Handle -> [Chunk] -> IO ()
hPutChunksLocaleWith TerminalCapabilities
stderrTc 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 Maybe ([String], CommandDoc (Maybe SetDoc))
mCommandDoc -> do
              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
$ case Maybe ([String], CommandDoc (Maybe SetDoc))
mCommandDoc of
                Maybe ([String], CommandDoc (Maybe SetDoc))
Nothing -> String -> Version -> String -> AnyDocs (Maybe SetDoc) -> [Chunk]
renderHelpPage String
progname Version
version String
progDesc AnyDocs (Maybe SetDoc)
docs
                Just ([String]
path, CommandDoc (Maybe SetDoc)
cDoc) -> String -> [String] -> CommandDoc (Maybe SetDoc) -> [Chunk]
renderCommandHelpPage String
progname [String]
path CommandDoc (Maybe SetDoc)
cDoc
              IO a
forall a. IO a
exitSuccess
        else do
          let mCheckConsumed :: Maybe Args
mCheckConsumed = [Dashed] -> Args -> Maybe Args
consumeSwitch [Dashed
"--run-settings-check"] Args
args'
          let (Bool
checkMode, Args
args) = case Maybe Args
mCheckConsumed of
                Maybe Args
Nothing -> (Bool
False, Args
args')
                Just Args
am -> (Bool
True, Args
am)

          if Bool
checkMode
            then do
              TerminalCapabilities
stderrTc <- Handle -> IO TerminalCapabilities
getTerminalCapabilitiesFromHandle Handle
stderr
              Either (NonEmpty ParseError) a
errOrSets <- Maybe TerminalCapabilities
-> Parser a
-> Args
-> EnvMap
-> Maybe Object
-> IO (Either (NonEmpty ParseError) a)
forall a.
Maybe TerminalCapabilities
-> Parser a
-> Args
-> EnvMap
-> Maybe Object
-> IO (Either (NonEmpty ParseError) a)
runParserOn (TerminalCapabilities -> Maybe TerminalCapabilities
forall a. a -> Maybe a
Just TerminalCapabilities
stderrTc) Parser a
p Args
args EnvMap
envVars Maybe Object
forall a. Maybe a
Nothing
              case Either (NonEmpty ParseError) a
errOrSets of
                Left NonEmpty ParseError
errs -> do
                  TerminalCapabilities -> Handle -> [Chunk] -> IO ()
hPutChunksLocaleWith TerminalCapabilities
stderrTc 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
            else do
              let p' :: Parser (Internal a)
p' = Parser a -> Parser (Internal a)
forall a. Parser a -> Parser (Internal a)
internalParser Parser a
p
              Either (NonEmpty ParseError) (Internal a)
errOrResult <-
                Maybe TerminalCapabilities
-> Parser (Internal a)
-> Args
-> EnvMap
-> Maybe Object
-> IO (Either (NonEmpty ParseError) (Internal a))
forall a.
Maybe TerminalCapabilities
-> Parser a
-> Args
-> EnvMap
-> Maybe Object
-> IO (Either (NonEmpty ParseError) a)
runParserOn
                  Maybe TerminalCapabilities
mDebugMode
                  Parser (Internal a)
p'
                  Args
args
                  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
                  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 Internal a
i -> case Internal a
i of
                  Internal a
ShowVersion -> do
                    String
progname <- IO String
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
$ String -> Version -> [Chunk]
renderVersionPage String
progname Version
version
                    IO a
forall a. IO a
exitSuccess
                  Internal a
RenderMan -> do
                    String
progname <- IO String
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
$ String -> Version -> String -> AnyDocs (Maybe SetDoc) -> [Chunk]
renderManPage String
progname Version
version String
progDesc AnyDocs (Maybe SetDoc)
docs
                    IO a
forall a. IO a
exitSuccess
                  Internal a
RenderDocumentation -> do
                    String
progname <- IO String
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
$ String -> AnyDocs (Maybe SetDoc) -> [Chunk]
renderReferenceDocumentation String
progname AnyDocs (Maybe SetDoc)
docs
                    IO a
forall a. IO a
exitSuccess
                  Internal a
RenderNixosOptions -> do
                    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Parser (Internal a) -> Text
forall a. Parser a -> Text
renderParserNixOptions Parser (Internal a)
p'
                    IO a
forall a. IO a
exitSuccess
                  BashCompletionScript Path Abs File
progPath -> do
                    String
progname <- IO String
getProgName
                    Path Abs File -> String -> IO ()
generateBashCompletionScript Path Abs File
progPath String
progname
                    IO a
forall a. IO a
exitSuccess
                  ZshCompletionScript Path Abs File
progPath -> do
                    String
progname <- IO String
getProgName
                    Path Abs File -> String -> IO ()
generateZshCompletionScript Path Abs File
progPath String
progname
                    IO a
forall a. IO a
exitSuccess
                  FishCompletionScript Path Abs File
progPath -> do
                    String
progname <- IO String
getProgName
                    Path Abs File -> String -> IO ()
generateFishCompletionScript Path Abs File
progPath String
progname
                    IO a
forall a. IO a
exitSuccess
                  CompletionQuery Bool
enriched Int
index [String]
ws -> do
                    Parser (Internal a) -> Bool -> Int -> [String] -> IO ()
forall a. Parser a -> Bool -> Int -> [String] -> IO ()
runCompletionQuery Parser (Internal a)
p' Bool
enriched Int
index [String]
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
  = ShowVersion
  | RenderMan
  | RenderDocumentation
  | RenderNixosOptions
  | BashCompletionScript (Path Abs File)
  | ZshCompletionScript (Path Abs File)
  | FishCompletionScript (Path Abs File)
  | CompletionQuery
      -- Enriched
      !Bool
      -- Index
      !Int
      -- Args
      ![String]
  | ParsedNormally !a

internalParser :: Parser a -> Parser (Internal a)
internalParser :: forall a. Parser a -> Parser (Internal a)
internalParser Parser a
p =
  [Parser (Internal a)] -> Parser (Internal a)
forall a. HasCallStack => [Parser a] -> Parser a
choice
    [ [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,
          String -> Builder (Internal a)
forall a. String -> Builder a
long String
"version",
          Builder (Internal a)
forall a. Builder a
hidden
        ],
      [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,
          String -> Builder (Internal a)
forall a. String -> Builder a
long String
"render-man-page",
          Builder (Internal a)
forall a. Builder a
hidden,
          String -> Builder (Internal a)
forall a. String -> Builder a
help String
"Render a manpage"
        ],
      [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
RenderDocumentation,
          String -> Builder (Internal a)
forall a. String -> Builder a
long String
"render-reference-documentation",
          Builder (Internal a)
forall a. Builder a
hidden,
          String -> Builder (Internal a)
forall a. String -> Builder a
help String
"Render reference documentation"
        ],
      [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
RenderNixosOptions,
          String -> Builder (Internal a)
forall a. String -> Builder a
long String
"render-nix-options",
          Builder (Internal a)
forall a. Builder a
hidden,
          String -> Builder (Internal a)
forall a. String -> Builder a
help String
"Render Nix options"
        ],
      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
<$> (String -> IO (Path Abs File))
-> Parser String -> Parser (Path Abs File)
forall a b. HasCallStack => (a -> IO b) -> Parser a -> Parser b
mapIO
          String -> IO (Path Abs File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseAbsFile
          ( [Builder String] -> Parser String
forall a. HasCallStack => [Builder a] -> Parser a
setting
              [ Builder String
forall a. Builder a
option,
                Reader String -> Builder String
forall a. Reader a -> Builder a
reader Reader String
forall s. IsString s => Reader s
str,
                String -> Builder String
forall a. String -> Builder a
long String
"bash-completion-script",
                Builder String
forall a. Builder a
hidden,
                String -> Builder String
forall a. String -> Builder a
help String
"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
<$> (String -> IO (Path Abs File))
-> Parser String -> Parser (Path Abs File)
forall a b. HasCallStack => (a -> IO b) -> Parser a -> Parser b
mapIO
          String -> IO (Path Abs File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseAbsFile
          ( [Builder String] -> Parser String
forall a. HasCallStack => [Builder a] -> Parser a
setting
              [ Builder String
forall a. Builder a
option,
                Reader String -> Builder String
forall a. Reader a -> Builder a
reader Reader String
forall s. IsString s => Reader s
str,
                String -> Builder String
forall a. String -> Builder a
long String
"zsh-completion-script",
                Builder String
forall a. Builder a
hidden,
                String -> Builder String
forall a. String -> Builder a
help String
"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
<$> (String -> IO (Path Abs File))
-> Parser String -> Parser (Path Abs File)
forall a b. HasCallStack => (a -> IO b) -> Parser a -> Parser b
mapIO
          String -> IO (Path Abs File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseAbsFile
          ( [Builder String] -> Parser String
forall a. HasCallStack => [Builder a] -> Parser a
setting
              [ Builder String
forall a. Builder a
option,
                Reader String -> Builder String
forall a. Reader a -> Builder a
reader Reader String
forall s. IsString s => Reader s
str,
                String -> Builder String
forall a. String -> Builder a
long String
"fish-completion-script",
                Builder String
forall a. Builder a
hidden,
                String -> Builder String
forall a. String -> Builder a
help String
"Render the fish completion script"
              ]
          ),
      [Builder (Bool -> Int -> [String] -> Internal a)]
-> Parser (Bool -> Int -> [String] -> Internal a)
forall a. HasCallStack => [Builder a] -> Parser a
setting
        [ String -> Builder (Bool -> Int -> [String] -> Internal a)
forall a. String -> Builder a
help String
"Query completion",
          (Bool -> Int -> [String] -> Internal a)
-> Builder (Bool -> Int -> [String] -> Internal a)
forall a. a -> Builder a
switch Bool -> Int -> [String] -> Internal a
forall a. Bool -> Int -> [String] -> Internal a
CompletionQuery,
          -- Long string that no normal user would ever use.
          String -> Builder (Bool -> Int -> [String] -> Internal a)
forall a. String -> Builder a
long String
"query-opt-env-conf-completion",
          Builder (Bool -> Int -> [String] -> Internal a)
forall a. Builder a
hidden
        ]
        Parser (Bool -> Int -> [String] -> Internal a)
-> Parser Bool -> Parser (Int -> [String] -> 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,
            String -> Builder Bool
forall a. String -> Builder a
long String
"completion-enriched",
            Bool -> Builder Bool
forall a. Show a => a -> Builder a
value Bool
False,
            Builder Bool
forall a. Builder a
hidden,
            String -> Builder Bool
forall a. String -> Builder a
help String
"Whether to enable enriched completion"
          ]
        Parser (Int -> [String] -> Internal a)
-> Parser Int -> Parser ([String] -> 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,
            String -> Builder Int
forall a. String -> Builder a
long String
"completion-index",
            Builder Int
forall a. Builder a
hidden,
            String -> Builder Int
forall a. String -> Builder a
help String
"The index between the arguments where completion was invoked."
          ]
        Parser ([String] -> Internal a)
-> Parser [String] -> 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 String -> Parser [String]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many
          ( [Builder String] -> Parser String
forall a. HasCallStack => [Builder a] -> Parser a
setting
              [ Builder String
forall a. Builder a
option,
                Reader String -> Builder String
forall a. Reader a -> Builder a
reader Reader String
forall s. IsString s => Reader s
str,
                String -> Builder String
forall a. String -> Builder a
long String
"completion-word",
                Builder String
forall a. Builder a
hidden,
                String -> Builder String
forall a. String -> Builder a
help String
"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 ::
  -- DebugMode
  Maybe TerminalCapabilities ->
  Parser a ->
  Args ->
  EnvMap ->
  Maybe JSON.Object ->
  IO (Either (NonEmpty ParseError) a)
runParserOn :: forall a.
Maybe TerminalCapabilities
-> Parser a
-> Args
-> EnvMap
-> Maybe Object
-> IO (Either (NonEmpty ParseError) a)
runParserOn Maybe TerminalCapabilities
mDebugMode 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,
            ppEnvDebug :: Maybe TerminalCapabilities
ppEnvDebug = Maybe TerminalCapabilities
mDebugMode,
            ppEnvIndent :: Int
ppEnvIndent = Int
0
          }
  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 String)
recogniseLeftovers Args
leftoverArgs of
          Maybe (NonEmpty String)
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 String
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 String -> ParseErrorMessage
ParseErrorUnrecognised NonEmpty String
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 -> String -> IO (Either (NonEmpty ParseError) a)
forall a. HasCallStack => String -> a
error String
"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 (Either (NonEmpty ParseError) a
 -> IO (Either (NonEmpty ParseError) a))
-> Either (NonEmpty ParseError) a
-> IO (Either (NonEmpty ParseError) a)
forall a b. (a -> b) -> a -> b
$
                    NonEmpty ParseError -> Either (NonEmpty ParseError) a
forall a b. a -> Either a b
Left (NonEmpty ParseError -> Either (NonEmpty ParseError) a)
-> NonEmpty ParseError -> Either (NonEmpty ParseError) a
forall a b. (a -> b) -> a -> b
$
                      let f :: NonEmpty ParseError -> NonEmpty ParseError
f = case Maybe TerminalCapabilities
mDebugMode of
                            Maybe TerminalCapabilities
Nothing -> NonEmpty ParseError -> NonEmpty ParseError
forall (f :: * -> *). Functor f => f ParseError -> f ParseError
eraseErrorSrcLocs
                            Just TerminalCapabilities
_ -> NonEmpty ParseError -> NonEmpty ParseError
forall a. a -> a
id
                       in NonEmpty ParseError -> NonEmpty ParseError
f 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 -> do
        [Chunk] -> PP ()
debug [String -> Chunk
syntaxChunk String
"pure value"]
        pure a
a
      ParserAp Parser (a1 -> a)
ff Parser a1
fa -> do
        [Chunk] -> PP ()
debug [String -> Chunk
syntaxChunk String
"Ap"]
        PP a -> PP a
forall a. PP a -> PP a
ppIndent (PP a -> PP a) -> PP a -> PP a
forall a b. (a -> b) -> a -> b
$ 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 -> do
        [Chunk] -> PP ()
debug [String -> Chunk
syntaxChunk String
"Empty", Chunk
": ", Maybe SrcLoc -> Chunk
mSrcLocChunk 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 -> do
        [Chunk] -> PP ()
debug [String -> Chunk
syntaxChunk String
"Select"]
        PP a -> PP a
forall a. PP a -> PP a
ppIndent (PP a -> PP a) -> PP a -> PP a
forall a b. (a -> b) -> a -> b
$ 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
        [Chunk] -> PP ()
debug [String -> Chunk
syntaxChunk String
"Alt"]
        PP a -> PP a
forall a. PP a -> PP a
ppIndent (PP a -> PP a) -> PP a -> PP a
forall a b. (a -> b) -> a -> b
$ do
          [Chunk] -> PP ()
debug [Chunk
"Trying left side."]
          Maybe a
eor <- PP (Maybe a) -> PP (Maybe a)
forall a. PP a -> PP a
ppIndent (PP (Maybe a) -> PP (Maybe a)) -> PP (Maybe a) -> PP (Maybe a)
forall a b. (a -> b) -> a -> b
$ 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 -> do
              [Chunk] -> PP ()
debug [Chunk
"Left side succeeded."]
              pure a
a
            Maybe a
Nothing -> do
              [Chunk] -> PP ()
debug [Chunk
"Left side failed, trying right side."]
              PP a -> PP a
forall a. PP a -> PP a
ppIndent (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
p2
      ParserMany Parser a1
p' -> do
        [Chunk] -> PP ()
debug [String -> Chunk
syntaxChunk String
"Many"]
        PP a -> PP a
forall a. PP a -> PP a
ppIndent (PP a -> PP a) -> PP a -> PP a
forall a b. (a -> b) -> a -> b
$ 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)
      ParserSome Parser a1
p' -> do
        [Chunk] -> PP ()
debug [String -> Chunk
syntaxChunk String
"Some"]
        PP a -> PP a
forall a. PP a -> PP a
ppIndent (PP a -> PP a) -> PP a -> PP a
forall a b. (a -> b) -> a -> b
$ do
          a1
a <- Parser a1 -> PP a1
forall a. Parser a -> PP a
go Parser a1
p'
          [Chunk] -> PP ()
debug [Chunk
"First element of some succeeded, continuing with Many"]
          [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] -> NonEmpty a1
forall a. a -> [a] -> NonEmpty a
:| [a1]
as)
      ParserAllOrNothing Maybe SrcLoc
mLoc Parser a
p' -> do
        [Chunk] -> PP ()
debug [String -> Chunk
syntaxChunk String
"AllOrNothing", Chunk
": ", Maybe SrcLoc -> Chunk
mSrcLocChunk Maybe SrcLoc
mLoc]
        PP a -> PP a
forall a. PP a -> PP a
ppIndent (PP a -> PP a) -> PP a -> PP a
forall a b. (a -> b) -> a -> b
$ 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 -> PP ()
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 String a)
f Parser a1
p' -> do
        [Chunk] -> PP ()
debug [String -> Chunk
syntaxChunk String
"Parser with check", Chunk
": ", Maybe SrcLoc -> Chunk
mSrcLocChunk Maybe SrcLoc
mLoc]
        PP a -> PP a
forall a. PP a -> PP a
ppIndent (PP a -> PP a) -> PP a -> PP a
forall a b. (a -> b) -> a -> b
$ do
          [Chunk] -> PP ()
debug [Chunk
"parser"]
          a1
a <- PP a1 -> PP a1
forall a. PP a -> PP a
ppIndent (PP a1 -> PP a1) -> PP a1 -> PP a1
forall a b. (a -> b) -> a -> b
$ Parser a1 -> PP a1
forall a. Parser a -> PP a
go Parser a1
p'
          [Chunk] -> PP ()
debug [Chunk
"check"]
          PP a -> PP a
forall a. PP a -> PP a
ppIndent (PP a -> PP a) -> PP a -> PP a
forall a b. (a -> b) -> a -> b
$ do
            Either String a
errOrB <- IO (Either String a)
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (Either String 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 String a)
 -> ReaderT
      PPEnv
      (ValidationT ParseError (StateT PPState (NonDetT IO)))
      (Either String a))
-> IO (Either String a)
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (Either String a)
forall a b. (a -> b) -> a -> b
$ a1 -> IO (Either String a)
f a1
a
            case Either String a
errOrB of
              Left String
err -> do
                [Chunk] -> PP ()
debug [Chunk
"failed, forgivable: ", Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Bool -> String
forall a. Show a => a -> String
show Bool
forgivable]
                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 -> String -> ParseErrorMessage
ParseErrorCheckFailed Bool
forgivable String
err
              Right a
b -> do
                [Chunk] -> PP ()
debug [Chunk
"succeeded"]
                pure a
b
      ParserCommands Maybe SrcLoc
mLoc Maybe String
mDefault [Command a]
cs -> do
        [Chunk] -> PP ()
debug [String -> Chunk
syntaxChunk String
"Commands", Chunk
": ", Maybe SrcLoc -> Chunk
mSrcLocChunk Maybe SrcLoc
mLoc]
        Maybe String -> (String -> PP ()) -> PP ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe String
mDefault ((String -> PP ()) -> PP ()) -> (String -> PP ()) -> PP ()
forall a b. (a -> b) -> a -> b
$ \String
d -> [Chunk] -> PP ()
debug [Chunk
"default:", Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. Show a => a -> String
show String
d]
        PP a -> PP a
forall a. PP a -> PP a
ppIndent (PP a -> PP a) -> PP a -> PP a
forall a b. (a -> b) -> a -> b
$ do
          PPState
stateBefore <- ReaderT
  PPEnv
  (ValidationT ParseError (StateT PPState (NonDetT IO)))
  PPState
forall s (m :: * -> *). MonadState s m => m s
get
          Maybe String
mS <- PP (Maybe String)
ppArg
          let docsForErrors :: [CommandDoc ()]
docsForErrors = (Command a -> CommandDoc ()) -> [Command a] -> [CommandDoc ()]
forall a b. (a -> b) -> [a] -> [b]
map (CommandDoc (Maybe SetDoc) -> CommandDoc ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (CommandDoc (Maybe SetDoc) -> CommandDoc ())
-> (Command a -> CommandDoc (Maybe SetDoc))
-> Command a
-> CommandDoc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Command a -> CommandDoc (Maybe SetDoc)
forall a. Command a -> CommandDoc (Maybe SetDoc)
commandParserDocs) [Command a]
cs
          let mDefaultCommand :: Maybe (Command a)
mDefaultCommand = do
                String
d <- Maybe String
mDefault
                (Command a -> Bool) -> [Command a] -> Maybe (Command a)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
d) (String -> Bool) -> (Command a -> String) -> Command a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Command a -> String
forall a. Command a -> String
commandArg) [Command a]
cs
          case Maybe String
mS of
            Maybe String
Nothing -> do
              [Chunk] -> PP ()
debug [Chunk
"No argument found for choosing a command."]
              case Maybe (Command a)
mDefaultCommand 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
$ [CommandDoc ()] -> ParseErrorMessage
ParseErrorMissingCommand [CommandDoc ()]
docsForErrors
                Just Command a
dc -> do
                  [Chunk] -> PP ()
debug [Chunk
"Choosing default command: ", String -> Chunk
commandChunk (Command a -> String
forall a. Command a -> String
commandArg Command a
dc)]
                  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
dc
            Just String
s -> do
              case (Command a -> Bool) -> [Command a] -> Maybe (Command a)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
s) (String -> Bool) -> (Command a -> String) -> Command a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Command a -> String
forall a. Command a -> String
commandArg) [Command a]
cs of
                Maybe (Command a)
Nothing -> do
                  [Chunk] -> PP ()
debug [Chunk
"Argument found, but no matching command: ", Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. Show a => a -> String
show String
s]
                  case Maybe (Command a)
mDefaultCommand 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
$ String -> [CommandDoc ()] -> ParseErrorMessage
ParseErrorUnrecognisedCommand String
s [CommandDoc ()]
docsForErrors
                    Just Command a
dc -> do
                      [Chunk] -> PP ()
debug [Chunk
"Choosing default command instead: ", String -> Chunk
commandChunk (Command a -> String
forall a. Command a -> String
commandArg Command a
dc)]
                      -- Put the state back to before we parsed 'ppArg' above
                      -- Maintainer note: We could try to un-parse this arg
                      -- somehow but that sounds more complicated to me.
                      PPState -> PP ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put PPState
stateBefore
                      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
dc
                Just Command a
c -> do
                  [Chunk] -> PP ()
debug [Chunk
"Set command to ", String -> Chunk
commandChunk (Command a -> String
forall a. Command a -> String
commandArg 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 Maybe SrcLoc
mLoc Parser (Maybe Object)
pc Parser a
pa -> do
        [Chunk] -> PP ()
debug [String -> Chunk
syntaxChunk String
"WithConfig", Chunk
": ", Maybe SrcLoc -> Chunk
mSrcLocChunk Maybe SrcLoc
mLoc]
        PP a -> PP a
forall a. PP a -> PP a
ppIndent (PP a -> PP a) -> PP a -> PP a
forall a b. (a -> b) -> a -> b
$ do
          [Chunk] -> PP ()
debug [Chunk
"loading config"]
          Maybe Object
mNewConfig <- PP (Maybe Object) -> PP (Maybe Object)
forall a. PP a -> PP a
ppIndent (PP (Maybe Object) -> PP (Maybe Object))
-> PP (Maybe Object) -> PP (Maybe Object)
forall a b. (a -> b) -> a -> b
$ Parser (Maybe Object) -> PP (Maybe Object)
forall a. Parser a -> PP a
go Parser (Maybe Object)
pc
          [Chunk] -> PP ()
debug [Chunk
"with loaded config"]
          PP a -> PP a
forall a. PP a -> PP a
ppIndent (PP a -> PP a) -> PP a -> PP a
forall a b. (a -> b) -> a -> b
$
            (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
[String]
[Dashed]
[Reader a]
Maybe a
Maybe String
Maybe (NonEmpty String)
Maybe (NonEmpty (ConfigValSetting a))
Maybe (a, String)
settingDasheds :: [Dashed]
settingReaders :: [Reader a]
settingTryArgument :: Bool
settingSwitchValue :: Maybe a
settingTryOption :: Bool
settingEnvVars :: Maybe (NonEmpty String)
settingConfigVals :: Maybe (NonEmpty (ConfigValSetting a))
settingDefaultValue :: Maybe (a, String)
settingExamples :: [String]
settingHidden :: Bool
settingMetavar :: Maybe String
settingHelp :: Maybe String
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 String)
settingConfigVals :: forall a. Setting a -> Maybe (NonEmpty (ConfigValSetting a))
settingDefaultValue :: forall a. Setting a -> Maybe (a, String)
settingExamples :: forall a. Setting a -> [String]
settingHidden :: forall a. Setting a -> Bool
settingMetavar :: forall a. Setting a -> Maybe String
settingHelp :: forall a. Setting a -> Maybe String
..} -> do
        [Chunk] -> PP ()
debug [String -> Chunk
syntaxChunk String
"Setting", Chunk
": ", Maybe SrcLoc -> Chunk
mSrcLocChunk Maybe SrcLoc
mLoc]
        PP a -> PP a
forall a. PP a -> PP a
ppIndent (PP a -> PP a) -> PP a -> PP a
forall a b. (a -> b) -> a -> b
$ do
          let markParsed :: PP ()
markParsed = do
                PP () -> (SrcLoc -> PP ()) -> Maybe SrcLoc -> PP ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                  (() -> PP ()
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) -> PP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ((PPState -> PPState) -> PP ()) -> (PPState -> PPState) -> PP ()
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 String
mS <- PP (Maybe String)
ppArg
                case Maybe String
mS of
                  Maybe String
Nothing -> do
                    [Chunk] -> PP ()
debug [Chunk
"could not set based on argument: no argument"]
                    pure ParseResult a
forall a. ParseResult a
NotFound
                  Just String
argStr -> do
                    case NonEmpty (Reader a) -> String -> Either (NonEmpty String) a
forall a.
NonEmpty (Reader a) -> String -> Either (NonEmpty String) a
tryReaders NonEmpty (Reader a)
rs String
argStr of
                      Left NonEmpty String
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 String -> ParseErrorMessage
ParseErrorArgumentRead Maybe OptDoc
mOptDoc NonEmpty String
errs
                      Right a
a -> do
                        [Chunk] -> PP ()
debug
                          [ Chunk
"set based on argument: ",
                            Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. Show a => a -> String
show String
argStr
                          ]
                        pure $ 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
              PP ()
markParsed
              pure a
a
            ParseResult a
_ -> do
              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 -> do
                      [Chunk] -> PP ()
debug
                        [ Chunk
"could not set based on switch, no switch: ",
                          Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Show a => a -> String
show ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Dashed -> String) -> [Dashed] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Dashed -> String
renderDashed [Dashed]
settingDasheds
                        ]
                      pure ParseResult a
forall a. ParseResult a
NotFound
                    Just () -> do
                      [Chunk] -> PP ()
debug [Chunk
"set based on switch."]
                      pure $ a -> ParseResult a
forall a. a -> ParseResult a
Found a
a

              case ParseResult a
mSwitch of
                Found a
a -> do
                  PP ()
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 String
mS <- [Dashed] -> PP (Maybe String)
ppOpt [Dashed]
settingDasheds
                        case Maybe String
mS of
                          Maybe String
Nothing -> do
                            [Chunk] -> PP ()
debug
                              [ Chunk
"could not set based on options, no option: ",
                                Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Show a => a -> String
show ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Dashed -> String) -> [Dashed] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Dashed -> String
renderDashed [Dashed]
settingDasheds
                              ]
                            pure ParseResult a
forall a. ParseResult a
NotFound
                          Just String
optionStr -> do
                            case NonEmpty (Reader a) -> String -> Either (NonEmpty String) a
forall a.
NonEmpty (Reader a) -> String -> Either (NonEmpty String) a
tryReaders NonEmpty (Reader a)
rs String
optionStr of
                              Left NonEmpty String
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 String -> ParseErrorMessage
ParseErrorOptionRead Maybe OptDoc
mOptDoc NonEmpty String
err
                              Right a
a -> do
                                [Chunk] -> PP ()
debug
                                  [ Chunk
"set based on option: ",
                                    Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. Show a => a -> String
show String
optionStr
                                  ]
                                pure $ 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
                      PP ()
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 String)
settingEnvVars of
                        Maybe (NonEmpty String)
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 String
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 :: [String]
founds = (String -> Maybe String) -> [String] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String -> EnvMap -> Maybe String
`EnvMap.lookup` EnvMap
es) (NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty String
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 <- [String]
-> (String -> 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 [String]
founds ((String -> PP a)
 -> ReaderT
      PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) [a])
-> (String -> PP a)
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) [a]
forall a b. (a -> b) -> a -> b
$ \String
varStr ->
                            case NonEmpty (Reader a) -> String -> Either (NonEmpty String) a
forall a.
NonEmpty (Reader a) -> String -> Either (NonEmpty String) a
tryReaders NonEmpty (Reader a)
rs String
varStr of
                              Left NonEmpty String
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 String -> ParseErrorMessage
ParseErrorEnvRead Maybe EnvDoc
mEnvDoc NonEmpty String
errs
                              Right a
a -> do
                                [Chunk] -> PP ()
debug
                                  [ Chunk
"set based on env: ",
                                    Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. Show a => a -> String
show String
varStr
                                  ]
                                pure a
a
                          case [a] -> Maybe a
forall a. [a] -> Maybe a
listToMaybe [a]
results of
                            Maybe a
Nothing -> do
                              [Chunk] -> PP ()
debug
                                [ Chunk
"could not set based on env vars, no var: ",
                                  Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Show a => a -> String
show ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String]
-> (NonEmpty String -> [String])
-> Maybe (NonEmpty String)
-> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
NE.toList Maybe (NonEmpty String)
settingEnvVars
                                ]
                              pure ParseResult a
forall a. ParseResult a
NotFound
                            Just 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

                      case ParseResult a
mEnv of
                        Found a
a -> do
                          PP ()
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 (ConfigValSetting a))
settingConfigVals of
                            Maybe (NonEmpty (ConfigValSetting 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 (ConfigValSetting a)
confSets -> do
                              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 -> do
                                  [Chunk] -> PP ()
debug [Chunk
"no config object to set from"]
                                  pure ParseResult a
forall a. ParseResult a
NotFound
                                Just Object
obj -> do
                                  let goConfSet :: ConfigValSetting a -> PP (Maybe a)
goConfSet ConfigValSetting {NonEmpty String
ValueCodec void (Maybe a)
configValSettingPath :: NonEmpty String
configValSettingCodec :: ValueCodec void (Maybe a)
configValSettingPath :: forall a. ConfigValSetting a -> NonEmpty String
configValSettingCodec :: ()
..} = do
                                        let jsonParser :: JSON.Object -> NonEmpty String -> JSON.Parser (Maybe JSON.Value)
                                            jsonParser :: Object -> NonEmpty String -> Parser (Maybe Value)
jsonParser Object
o (String
k :| [String]
rest) = case [String] -> Maybe (NonEmpty String)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [String]
rest of
                                              Maybe (NonEmpty String)
Nothing -> do
                                                case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup (String -> Key
Key.fromString String
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 String
neRest -> do
                                                Maybe Object
mO' <- Object
o Object -> Key -> Parser (Maybe Object)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? String -> Key
Key.fromString String
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 String -> Parser (Maybe Value)
jsonParser Object
o' NonEmpty String
neRest
                                        case (NonEmpty String -> Parser (Maybe Value))
-> NonEmpty String -> Either String (Maybe Value)
forall a b. (a -> Parser b) -> a -> Either String b
JSON.parseEither (Object -> NonEmpty String -> Parser (Maybe Value)
jsonParser Object
obj) NonEmpty String
configValSettingPath of
                                          Left String
err -> Maybe SrcLoc -> ParseErrorMessage -> PP (Maybe a)
forall a. Maybe SrcLoc -> ParseErrorMessage -> PP a
ppError Maybe SrcLoc
mLoc (ParseErrorMessage -> PP (Maybe a))
-> ParseErrorMessage -> PP (Maybe a)
forall a b. (a -> b) -> a -> b
$ Maybe ConfDoc -> String -> ParseErrorMessage
ParseErrorConfigRead Maybe ConfDoc
mConfDoc String
err
                                          Right Maybe Value
mV -> case Maybe Value
mV of
                                            Maybe Value
Nothing -> do
                                              [Chunk] -> PP ()
debug
                                                [ Chunk
"could not set based on config value, not configured: ",
                                                  Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Show a => a -> String
show ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty String
configValSettingPath
                                                ]
                                              pure Maybe a
forall a. Maybe a
Nothing
                                            Just Value
v -> case (Value -> Parser (Maybe a)) -> Value -> Either String (Maybe a)
forall a b. (a -> Parser b) -> a -> Either String 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)
configValSettingCodec) Value
v of
                                              Left String
err -> Maybe SrcLoc -> ParseErrorMessage -> PP (Maybe a)
forall a. Maybe SrcLoc -> ParseErrorMessage -> PP a
ppError Maybe SrcLoc
mLoc (ParseErrorMessage -> PP (Maybe a))
-> ParseErrorMessage -> PP (Maybe a)
forall a b. (a -> b) -> a -> b
$ Maybe ConfDoc -> String -> ParseErrorMessage
ParseErrorConfigRead Maybe ConfDoc
mConfDoc String
err
                                              Right Maybe a
mA -> case Maybe a
mA of
                                                Maybe a
Nothing -> do
                                                  [Chunk] -> PP ()
debug
                                                    [ Chunk
"could not set based on config value, configured to nothing: ",
                                                      Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Show a => a -> String
show ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty String
configValSettingPath
                                                    ]
                                                  pure Maybe a
forall a. Maybe a
Nothing
                                                Just a
a -> do
                                                  [Chunk] -> PP ()
debug
                                                    [ Chunk
"set based on config value: ",
                                                      Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Value -> String
forall a. Show a => a -> String
show Value
v
                                                    ]
                                                  pure $ a -> Maybe a
forall a. a -> Maybe a
Just a
a
                                  let toRes :: Maybe a -> ParseResult a
toRes = \case
                                        Maybe a
Nothing -> ParseResult a
forall a. ParseResult a
NotFound
                                        Just a
a -> a -> ParseResult a
forall a. a -> ParseResult a
Found a
a
                                  let goConfSets :: NonEmpty (ConfigValSetting a)
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (ParseResult a)
goConfSets (ConfigValSetting a
confSet :| [ConfigValSetting a]
rest) = case [ConfigValSetting a] -> Maybe (NonEmpty (ConfigValSetting a))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [ConfigValSetting a]
rest of
                                        Maybe (NonEmpty (ConfigValSetting a))
Nothing -> Maybe a -> ParseResult a
forall {a}. Maybe a -> ParseResult a
toRes (Maybe a -> ParseResult a)
-> PP (Maybe a)
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (ParseResult a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConfigValSetting a -> PP (Maybe a)
goConfSet ConfigValSetting a
confSet
                                        Just NonEmpty (ConfigValSetting a)
ne -> do
                                          Maybe a
res <- ConfigValSetting a -> PP (Maybe a)
goConfSet ConfigValSetting a
confSet
                                          case Maybe a
res of
                                            Just 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
                                            Maybe a
Nothing -> NonEmpty (ConfigValSetting a)
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (ParseResult a)
goConfSets NonEmpty (ConfigValSetting a)
ne
                                  NonEmpty (ConfigValSetting a)
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (ParseResult a)
goConfSets NonEmpty (ConfigValSetting a)
confSets
                          case ParseResult a
mConf of
                            Found a
a -> do
                              PP ()
markParsed
                              pure a
a
                            ParseResult a
_ ->
                              case Maybe (a, String)
settingDefaultValue of
                                Just (a
a, String
_) -> do
                                  [Chunk] -> PP ()
debug [Chunk
"set to default value"]
                                  pure a
a -- Don't mark as parsed
                                Maybe (a, String)
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.
                                  [Chunk] -> PP ()
debug [Chunk
"not found"]
                                  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) -> String -> Either (NonEmpty String) a
tryReaders NonEmpty (Reader a)
rs String
s = (NonEmpty String -> NonEmpty String)
-> Either (NonEmpty String) a -> Either (NonEmpty String) 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 String -> NonEmpty String
forall a. NonEmpty a -> NonEmpty a
NE.reverse (Either (NonEmpty String) a -> Either (NonEmpty String) a)
-> Either (NonEmpty String) a -> Either (NonEmpty String) a
forall a b. (a -> b) -> a -> b
$ NonEmpty (Reader a) -> Either (NonEmpty String) a
go NonEmpty (Reader a)
rs
  where
    go :: NonEmpty (Reader a) -> Either (NonEmpty String) a
go (Reader a
r :| [Reader a]
rl) = case Reader a -> String -> Either String a
forall a. Reader a -> String -> Either String a
runReader Reader a
r String
s of
      Left String
err -> NonEmpty String -> [Reader a] -> Either (NonEmpty String) a
go' (String
err String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
:| []) [Reader a]
rl
      Right a
a -> a -> Either (NonEmpty String) a
forall a b. b -> Either a b
Right a
a
    go' :: NonEmpty String -> [Reader a] -> Either (NonEmpty String) a
go' NonEmpty String
errs = \case
      [] -> NonEmpty String -> Either (NonEmpty String) a
forall a b. a -> Either a b
Left NonEmpty String
errs
      (Reader a
r : [Reader a]
rl) -> case Reader a -> String -> Either String a
forall a. Reader a -> String -> Either String a
runReader Reader a
r String
s of
        Left String
err -> NonEmpty String -> [Reader a] -> Either (NonEmpty String) a
go' (String
err String -> NonEmpty String -> NonEmpty String
forall a. a -> NonEmpty a -> NonEmpty a
<| NonEmpty String
errs) [Reader a]
rl
        Right a
a -> a -> Either (NonEmpty String) a
forall a b. b -> Either a b
Right a
a

runHelpParser ::
  -- DebugMode
  Maybe TerminalCapabilities ->
  Args ->
  Parser a ->
  IO (Either (NonEmpty ParseError) (Maybe ([String], CommandDoc (Maybe SetDoc))))
runHelpParser :: forall a.
Maybe TerminalCapabilities
-> Args
-> Parser a
-> IO
     (Either
        (NonEmpty ParseError)
        (Maybe ([String], CommandDoc (Maybe SetDoc))))
runHelpParser Maybe TerminalCapabilities
mDebugMode Args
args Parser a
parser = 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
EnvMap.empty,
            ppEnvConf :: Maybe Object
ppEnvConf = Maybe Object
forall a. Maybe a
Nothing,
            ppEnvDebug :: Maybe TerminalCapabilities
ppEnvDebug = Maybe TerminalCapabilities
mDebugMode,
            ppEnvIndent :: Int
ppEnvIndent = Int
0
          }
  Maybe
  ((Validation
      ParseError (Maybe ([String], CommandDoc (Maybe SetDoc))),
    PPState),
   NonDetT
     IO
     (Validation
        ParseError (Maybe ([String], CommandDoc (Maybe SetDoc))),
      PPState))
mResOrNext <- PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
-> PPState
-> PPEnv
-> IO
     (Maybe
        ((Validation
            ParseError (Maybe ([String], CommandDoc (Maybe SetDoc))),
          PPState),
         NonDetT
           IO
           (Validation
              ParseError (Maybe ([String], CommandDoc (Maybe SetDoc))),
            PPState)))
forall a.
PP a
-> PPState
-> PPEnv
-> IO
     (Maybe
        ((Validation ParseError a, PPState),
         NonDetT IO (Validation ParseError a, PPState)))
runPPLazy ([String]
-> Parser a -> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a.
[String]
-> Parser a -> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
go' [] Parser a
parser) PPState
ppState PPEnv
ppEnv
  case Maybe
  ((Validation
      ParseError (Maybe ([String], CommandDoc (Maybe SetDoc))),
    PPState),
   NonDetT
     IO
     (Validation
        ParseError (Maybe ([String], CommandDoc (Maybe SetDoc))),
      PPState))
mResOrNext of
    Maybe
  ((Validation
      ParseError (Maybe ([String], CommandDoc (Maybe SetDoc))),
    PPState),
   NonDetT
     IO
     (Validation
        ParseError (Maybe ([String], CommandDoc (Maybe SetDoc))),
      PPState))
Nothing -> Either
  (NonEmpty ParseError) (Maybe ([String], CommandDoc (Maybe SetDoc)))
-> IO
     (Either
        (NonEmpty ParseError)
        (Maybe ([String], CommandDoc (Maybe SetDoc))))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   (NonEmpty ParseError) (Maybe ([String], CommandDoc (Maybe SetDoc)))
 -> IO
      (Either
         (NonEmpty ParseError)
         (Maybe ([String], CommandDoc (Maybe SetDoc)))))
-> Either
     (NonEmpty ParseError) (Maybe ([String], CommandDoc (Maybe SetDoc)))
-> IO
     (Either
        (NonEmpty ParseError)
        (Maybe ([String], CommandDoc (Maybe SetDoc))))
forall a b. (a -> b) -> a -> b
$ Maybe ([String], CommandDoc (Maybe SetDoc))
-> Either
     (NonEmpty ParseError) (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a b. b -> Either a b
Right Maybe ([String], CommandDoc (Maybe SetDoc))
forall a. Maybe a
Nothing
    Just ((Validation ParseError (Maybe ([String], CommandDoc (Maybe SetDoc)))
result, PPState
_), NonDetT
  IO
  (Validation
     ParseError (Maybe ([String], CommandDoc (Maybe SetDoc))),
   PPState)
_) -> Either
  (NonEmpty ParseError) (Maybe ([String], CommandDoc (Maybe SetDoc)))
-> IO
     (Either
        (NonEmpty ParseError)
        (Maybe ([String], CommandDoc (Maybe SetDoc))))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   (NonEmpty ParseError) (Maybe ([String], CommandDoc (Maybe SetDoc)))
 -> IO
      (Either
         (NonEmpty ParseError)
         (Maybe ([String], CommandDoc (Maybe SetDoc)))))
-> Either
     (NonEmpty ParseError) (Maybe ([String], CommandDoc (Maybe SetDoc)))
-> IO
     (Either
        (NonEmpty ParseError)
        (Maybe ([String], CommandDoc (Maybe SetDoc))))
forall a b. (a -> b) -> a -> b
$ case Validation ParseError (Maybe ([String], CommandDoc (Maybe SetDoc)))
result of
      Failure NonEmpty ParseError
errs -> NonEmpty ParseError
-> Either
     (NonEmpty ParseError) (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a b. a -> Either a b
Left NonEmpty ParseError
errs
      Success Maybe ([String], CommandDoc (Maybe SetDoc))
mDocs -> Maybe ([String], CommandDoc (Maybe SetDoc))
-> Either
     (NonEmpty ParseError) (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a b. b -> Either a b
Right Maybe ([String], CommandDoc (Maybe SetDoc))
mDocs
  where
    -- We try to parse the commands as deep as possible and ignore everything else.
    go' :: [String] -> Parser a -> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
    go' :: forall a.
[String]
-> Parser a -> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
go' [String]
path =
      let go :: Parser a -> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
          go :: forall a.
Parser a -> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
go = [String]
-> Parser a -> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a.
[String]
-> Parser a -> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
go' [String]
path
       in \case
            ParserPure a
_ -> do
              [Chunk] -> PP ()
debug [String -> Chunk
syntaxChunk String
"pure value"]
              pure Maybe ([String], CommandDoc (Maybe SetDoc))
forall a. Maybe a
Nothing
            ParserAp Parser (a1 -> a)
ff Parser a1
fa -> do
              [Chunk] -> PP ()
debug [String -> Chunk
syntaxChunk String
"Ap"]
              PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
-> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a. PP a -> PP a
ppIndent (PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
 -> PP (Maybe ([String], CommandDoc (Maybe SetDoc))))
-> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
-> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a b. (a -> b) -> a -> b
$ do
                Maybe ([String], CommandDoc (Maybe SetDoc))
mf <- Parser (a1 -> a)
-> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a.
Parser a -> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
go Parser (a1 -> a)
ff
                Maybe ([String], CommandDoc (Maybe SetDoc))
ma <- Parser a1 -> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a.
Parser a -> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
go Parser a1
fa
                pure $ Maybe ([String], CommandDoc (Maybe SetDoc))
ma Maybe ([String], CommandDoc (Maybe SetDoc))
-> Maybe ([String], CommandDoc (Maybe SetDoc))
-> Maybe ([String], CommandDoc (Maybe SetDoc))
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe ([String], CommandDoc (Maybe SetDoc))
mf -- Reverse order
            ParserSelect Parser (Either a1 a)
fe Parser (a1 -> a)
ff -> do
              [Chunk] -> PP ()
debug [String -> Chunk
syntaxChunk String
"Select"]
              PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
-> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a. PP a -> PP a
ppIndent (PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
 -> PP (Maybe ([String], CommandDoc (Maybe SetDoc))))
-> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
-> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a b. (a -> b) -> a -> b
$ do
                Maybe ([String], CommandDoc (Maybe SetDoc))
me <- Parser (Either a1 a)
-> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a.
Parser a -> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
go Parser (Either a1 a)
fe
                Maybe ([String], CommandDoc (Maybe SetDoc))
mf <- Parser (a1 -> a)
-> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a.
Parser a -> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
go Parser (a1 -> a)
ff
                pure $ Maybe ([String], CommandDoc (Maybe SetDoc))
mf Maybe ([String], CommandDoc (Maybe SetDoc))
-> Maybe ([String], CommandDoc (Maybe SetDoc))
-> Maybe ([String], CommandDoc (Maybe SetDoc))
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe ([String], CommandDoc (Maybe SetDoc))
me -- Reverse order
            ParserEmpty Maybe SrcLoc
mLoc -> do
              [Chunk] -> PP ()
debug [String -> Chunk
syntaxChunk String
"Empty", Chunk
": ", Maybe SrcLoc -> Chunk
mSrcLocChunk Maybe SrcLoc
mLoc]
              pure Maybe ([String], CommandDoc (Maybe SetDoc))
forall a. Maybe a
Nothing
            ParserAlt Parser a
p1 Parser a
p2 -> do
              [Chunk] -> PP ()
debug [String -> Chunk
syntaxChunk String
"Alt"]
              PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
-> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a. PP a -> PP a
ppIndent (PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
 -> PP (Maybe ([String], CommandDoc (Maybe SetDoc))))
-> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
-> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a b. (a -> b) -> a -> b
$ do
                [Chunk] -> PP ()
debug [Chunk
"Trying left side."]
                Maybe (Maybe ([String], CommandDoc (Maybe SetDoc)))
eor <- PP (Maybe (Maybe ([String], CommandDoc (Maybe SetDoc))))
-> PP (Maybe (Maybe ([String], CommandDoc (Maybe SetDoc))))
forall a. PP a -> PP a
ppIndent (PP (Maybe (Maybe ([String], CommandDoc (Maybe SetDoc))))
 -> PP (Maybe (Maybe ([String], CommandDoc (Maybe SetDoc)))))
-> PP (Maybe (Maybe ([String], CommandDoc (Maybe SetDoc))))
-> PP (Maybe (Maybe ([String], CommandDoc (Maybe SetDoc))))
forall a b. (a -> b) -> a -> b
$ PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
-> PP (Maybe (Maybe ([String], CommandDoc (Maybe SetDoc))))
forall a. PP a -> PP (Maybe a)
tryPP (Parser a -> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a.
Parser a -> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
go Parser a
p1)
                case Maybe (Maybe ([String], CommandDoc (Maybe SetDoc)))
eor of
                  Just Maybe ([String], CommandDoc (Maybe SetDoc))
a -> do
                    [Chunk] -> PP ()
debug [Chunk
"Left side succeeded."]
                    pure Maybe ([String], CommandDoc (Maybe SetDoc))
a
                  Maybe (Maybe ([String], CommandDoc (Maybe SetDoc)))
Nothing -> do
                    [Chunk] -> PP ()
debug [Chunk
"Left side failed, trying right side."]
                    PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
-> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a. PP a -> PP a
ppIndent (PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
 -> PP (Maybe ([String], CommandDoc (Maybe SetDoc))))
-> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
-> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a b. (a -> b) -> a -> b
$ Parser a -> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a.
Parser a -> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
go Parser a
p2
            ParserMany Parser a1
p' -> do
              [Chunk] -> PP ()
debug [String -> Chunk
syntaxChunk String
"Many"]
              PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
-> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a. PP a -> PP a
ppIndent (PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
 -> PP (Maybe ([String], CommandDoc (Maybe SetDoc))))
-> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
-> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a b. (a -> b) -> a -> b
$ Parser a1 -> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a.
Parser a -> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
go Parser a1
p'
            ParserSome Parser a1
p' -> do
              [Chunk] -> PP ()
debug [String -> Chunk
syntaxChunk String
"Some"]
              PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
-> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a. PP a -> PP a
ppIndent (PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
 -> PP (Maybe ([String], CommandDoc (Maybe SetDoc))))
-> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
-> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a b. (a -> b) -> a -> b
$ Parser a1 -> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a.
Parser a -> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
go Parser a1
p'
            ParserAllOrNothing Maybe SrcLoc
mLoc Parser a
p' -> do
              [Chunk] -> PP ()
debug [String -> Chunk
syntaxChunk String
"AllOrNothing", Chunk
": ", Maybe SrcLoc -> Chunk
mSrcLocChunk Maybe SrcLoc
mLoc]
              PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
-> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a. PP a -> PP a
ppIndent (PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
 -> PP (Maybe ([String], CommandDoc (Maybe SetDoc))))
-> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
-> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a b. (a -> b) -> a -> b
$ Parser a -> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a.
Parser a -> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
go Parser a
p'
            ParserCheck Maybe SrcLoc
mLoc Bool
_ a1 -> IO (Either String a)
_ Parser a1
p' -> do
              [Chunk] -> PP ()
debug [String -> Chunk
syntaxChunk String
"Parser with check", Chunk
": ", Maybe SrcLoc -> Chunk
mSrcLocChunk Maybe SrcLoc
mLoc]
              PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
-> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a. PP a -> PP a
ppIndent (PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
 -> PP (Maybe ([String], CommandDoc (Maybe SetDoc))))
-> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
-> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a b. (a -> b) -> a -> b
$ Parser a1 -> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a.
Parser a -> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
go Parser a1
p'
            ParserWithConfig Maybe SrcLoc
mLoc Parser (Maybe Object)
pc Parser a
pa -> do
              [Chunk] -> PP ()
debug [String -> Chunk
syntaxChunk String
"WithConfig", Chunk
": ", Maybe SrcLoc -> Chunk
mSrcLocChunk Maybe SrcLoc
mLoc]
              PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
-> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a. PP a -> PP a
ppIndent (PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
 -> PP (Maybe ([String], CommandDoc (Maybe SetDoc))))
-> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
-> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a b. (a -> b) -> a -> b
$ do
                Maybe ([String], CommandDoc (Maybe SetDoc))
mNewConfig <- Parser (Maybe Object)
-> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a.
Parser a -> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
go Parser (Maybe Object)
pc
                Maybe ([String], CommandDoc (Maybe SetDoc))
mRes <- Parser a -> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a.
Parser a -> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
go Parser a
pa
                pure $ Maybe ([String], CommandDoc (Maybe SetDoc))
mRes Maybe ([String], CommandDoc (Maybe SetDoc))
-> Maybe ([String], CommandDoc (Maybe SetDoc))
-> Maybe ([String], CommandDoc (Maybe SetDoc))
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe ([String], CommandDoc (Maybe SetDoc))
mNewConfig -- Reverse order
            ParserSetting Maybe SrcLoc
mLoc Setting a
_ -> do
              [Chunk] -> PP ()
debug [String -> Chunk
syntaxChunk String
"Setting", Chunk
": ", Maybe SrcLoc -> Chunk
mSrcLocChunk Maybe SrcLoc
mLoc]
              pure Maybe ([String], CommandDoc (Maybe SetDoc))
forall a. Maybe a
Nothing
            ParserCommands Maybe SrcLoc
mLoc Maybe String
mDefault [Command a]
cs -> do
              [Chunk] -> PP ()
debug [String -> Chunk
syntaxChunk String
"Commands", Chunk
": ", Maybe SrcLoc -> Chunk
mSrcLocChunk Maybe SrcLoc
mLoc]
              Maybe String -> (String -> PP ()) -> PP ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe String
mDefault ((String -> PP ()) -> PP ()) -> (String -> PP ()) -> PP ()
forall a b. (a -> b) -> a -> b
$ \String
d -> [Chunk] -> PP ()
debug [Chunk
"default:", Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. Show a => a -> String
show String
d]
              PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
-> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a. PP a -> PP a
ppIndent (PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
 -> PP (Maybe ([String], CommandDoc (Maybe SetDoc))))
-> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
-> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a b. (a -> b) -> a -> b
$ do
                Maybe String
mS <- PP (Maybe String)
ppArg
                case Maybe String
mS of
                  Maybe String
Nothing -> do
                    [Chunk] -> PP ()
debug [Chunk
"No argument found for choosing a command."]
                    pure Maybe ([String], CommandDoc (Maybe SetDoc))
forall a. Maybe a
Nothing
                  Just String
s -> do
                    case (Command a -> Bool) -> [Command a] -> Maybe (Command a)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
s) (String -> Bool) -> (Command a -> String) -> Command a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Command a -> String
forall a. Command a -> String
commandArg) [Command a]
cs of
                      Maybe (Command a)
Nothing -> do
                        [Chunk] -> PP ()
debug [Chunk
"Argument found, but no matching command: ", Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. Show a => a -> String
show String
s]
                        pure Maybe ([String], CommandDoc (Maybe SetDoc))
forall a. Maybe a
Nothing
                      Just Command a
c -> do
                        [Chunk] -> PP ()
debug [Chunk
"Set command to ", String -> Chunk
commandChunk (Command a -> String
forall a. Command a -> String
commandArg Command a
c)]
                        Maybe ([String], CommandDoc (Maybe SetDoc))
mRes <- [String]
-> Parser a -> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a.
[String]
-> Parser a -> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
go' (Command a -> String
forall a. Command a -> String
commandArg Command a
c String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
path) (Parser a -> PP (Maybe ([String], CommandDoc (Maybe SetDoc))))
-> Parser a -> PP (Maybe ([String], CommandDoc (Maybe SetDoc)))
forall a b. (a -> b) -> a -> b
$ Command a -> Parser a
forall a. Command a -> Parser a
commandParser Command a
c
                        pure $ case Maybe ([String], CommandDoc (Maybe SetDoc))
mRes of
                          Maybe ([String], CommandDoc (Maybe SetDoc))
Nothing -> ([String], CommandDoc (Maybe SetDoc))
-> Maybe ([String], CommandDoc (Maybe SetDoc))
forall a. a -> Maybe a
Just ([String] -> [String]
forall a. [a] -> [a]
reverse [String]
path, Command a -> CommandDoc (Maybe SetDoc)
forall a. Command a -> CommandDoc (Maybe SetDoc)
commandParserDocs Command a
c)
                          Just ([String], CommandDoc (Maybe SetDoc))
res -> ([String], CommandDoc (Maybe SetDoc))
-> Maybe ([String], CommandDoc (Maybe SetDoc))
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String], CommandDoc (Maybe SetDoc))
res

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
  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 do
          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 -> do
      PPState -> PP ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put PPState
s' -- Only set state if parsing succeeded.
      pure $ 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),
    -- Nothing means "not debug mode"
    PPEnv -> Maybe TerminalCapabilities
ppEnvDebug :: !(Maybe TerminalCapabilities),
    PPEnv -> Int
ppEnvIndent :: !Int
  }

debug :: [Chunk] -> PP ()
debug :: [Chunk] -> PP ()
debug [Chunk]
chunks = do
  Maybe TerminalCapabilities
debugMode <- (PPEnv -> Maybe TerminalCapabilities)
-> ReaderT
     PPEnv
     (ValidationT ParseError (StateT PPState (NonDetT IO)))
     (Maybe TerminalCapabilities)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PPEnv -> Maybe TerminalCapabilities
ppEnvDebug
  Maybe TerminalCapabilities
-> (TerminalCapabilities -> PP ()) -> PP ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe TerminalCapabilities
debugMode ((TerminalCapabilities -> PP ()) -> PP ())
-> (TerminalCapabilities -> PP ()) -> PP ()
forall a b. (a -> b) -> a -> b
$ \TerminalCapabilities
tc -> do
    Int
i <- (PPEnv -> Int)
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PPEnv -> Int
ppEnvIndent
    -- Debug mode needs to involve an impure print because parsers can run IO
    -- actions and we need to see their output interleaved with the debug
    -- output
    IO () -> PP ()
forall a.
IO a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PP ()) -> IO () -> PP ()
forall a b. (a -> b) -> a -> b
$
      TerminalCapabilities -> Handle -> [Chunk] -> IO ()
hPutChunksLocaleWith TerminalCapabilities
tc Handle
stderr ([Chunk] -> IO ()) -> [Chunk] -> IO ()
forall a b. (a -> b) -> a -> b
$
        (Int -> Chunk -> [Chunk]
forall a. Int -> a -> [a]
replicate Int
i Chunk
"  " [Chunk] -> [Chunk] -> [Chunk]
forall a. [a] -> [a] -> [a]
++ [Chunk]
chunks)
          [Chunk] -> [Chunk] -> [Chunk]
forall a. [a] -> [a] -> [a]
++ [ Chunk
"\n"
             ]

ppIndent :: PP a -> PP a
ppIndent :: forall a. PP a -> PP a
ppIndent =
  (PPEnv -> PPEnv)
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
-> ReaderT
     PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) 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 {ppEnvIndent = succ (ppEnvIndent e)})

ppArg :: PP (Maybe String)
ppArg :: PP (Maybe String)
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
  [Chunk] -> PP ()
debug [Chunk
"Trying to consume an argument"]
  let consumePossibilities :: [(Maybe String, Args)]
consumePossibilities = Args -> [(Maybe String, Args)]
Args.consumeArgument Args
args
  if [(Maybe String, Args)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Maybe String, Args)]
consumePossibilities
    then [Chunk] -> PP ()
debug [Chunk
"Found no consume possibilities."]
    else do
      [Chunk] -> PP ()
debug [Chunk
"Found these possibilities to consume an argument:"]
      [(Maybe String, Args)] -> ((Maybe String, Args) -> PP ()) -> PP ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Maybe String, Args)]
consumePossibilities (((Maybe String, Args) -> PP ()) -> PP ())
-> ((Maybe String, Args) -> PP ()) -> PP ()
forall a b. (a -> b) -> a -> b
$ \(Maybe String, Args)
p ->
        [Chunk] -> PP ()
debug [Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ (Maybe String, Args) -> String
forall a. Show a => a -> String
show (Maybe String, Args)
p]
  p :: (Maybe String, Args)
p@(Maybe String
mA, Args
args') <- [(Maybe String, Args)] -> PP (Maybe String, Args)
forall a. [a] -> PP a
ppNonDetList [(Maybe String, Args)]
consumePossibilities
  [Chunk] -> PP ()
debug [Chunk
"Considering this posibility: ", Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ (Maybe String, Args) -> String
forall a. Show a => a -> String
show (Maybe String, Args)
p]
  (PPState -> PPState) -> PP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\PPState
s -> PPState
s {ppStateArgs = args'})
  pure Maybe String
mA

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