{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

module OptEnvConf.Run
  ( runParserOn,
    runHelpParser,
  )
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.Map (Map)
import qualified Data.Map as M
import Data.Maybe
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Traversable
import GHC.Stack (SrcLoc)
import OptEnvConf.Args as Args
import OptEnvConf.Capability
import OptEnvConf.Doc
import OptEnvConf.EnvMap (EnvMap (..))
import qualified OptEnvConf.EnvMap as EnvMap
import OptEnvConf.Error
import OptEnvConf.NonDet
import OptEnvConf.Output
import OptEnvConf.Parser
import OptEnvConf.Reader
import OptEnvConf.Setting
import OptEnvConf.Validation
import System.IO
import Text.Colour

-- | Run a parser on given arguments and environment instead of getting them
-- from the current process.
runParserOn ::
  Capabilities ->
  -- DebugMode
  Maybe TerminalCapabilities ->
  Parser a ->
  Args ->
  EnvMap ->
  Maybe JSON.Object ->
  IO (Either (NonEmpty ParseError) a)
runParserOn :: forall a.
Capabilities
-> Maybe TerminalCapabilities
-> Parser a
-> Args
-> EnvMap
-> Maybe Object
-> IO (Either (NonEmpty ParseError) a)
runParserOn Capabilities
capabilities 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 :: Map SettingHash SrcLoc
ppStateParsedSettings = Map SettingHash SrcLoc
forall k a. Map k a
M.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' :: PP a
go' = do
        a
result <- Parser a -> PP a
forall a. Parser a -> PP a
go Parser a
parser
        Args
leftoverArgs <- (PPState -> Args) -> PP 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 -> PP a
forall a. a -> PP a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result
          Just NonEmpty String
leftovers -> Maybe SrcLoc -> ParseErrorMessage -> PP a
forall a. Maybe SrcLoc -> ParseErrorMessage -> PP a
ppError Maybe SrcLoc
forall a. Maybe a
Nothing (ParseErrorMessage -> PP a) -> ParseErrorMessage -> PP 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 <- PP 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 PP 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
$
                      -- Only show source locations in debug mode.
                      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) -> PP a1 -> PP a
forall a b. PP (a -> b) -> PP a -> PP b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser a1 -> PP 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
$ PP (Either a1 a) -> PP (a1 -> a) -> PP a
forall a b. PP (Either a b) -> PP (a -> b) -> PP b
forall (f :: * -> *) a b.
Selective f =>
f (Either a b) -> f (a -> b) -> f b
select (Parser (Either a1 a) -> PP (Either a1 a)
forall a. Parser a -> PP a
go Parser (Either a1 a)
fe) (Parser (a1 -> a) -> PP (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 Maybe SrcLoc
mLoc Parser a1
p' -> do
        [Chunk] -> PP ()
debug [String -> Chunk
syntaxChunk String
"Many", 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
          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 -> PP 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 (Maybe SrcLoc -> Parser a1 -> Parser [a1]
forall a1. Maybe SrcLoc -> Parser a1 -> Parser [a1]
ParserMany Maybe SrcLoc
mLoc Parser a1
p')
              pure (a1
a a1 -> [a1] -> [a1]
forall a. a -> [a] -> [a]
: [a1]
as)
      ParserSome Maybe SrcLoc
mLoc Parser a1
p' -> do
        [Chunk] -> PP ()
debug [String -> Chunk
syntaxChunk String
"Some", 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
          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 (Maybe SrcLoc -> Parser a1 -> Parser [a1]
forall a1. Maybe SrcLoc -> Parser a1 -> Parser [a1]
ParserMany Maybe SrcLoc
mLoc 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 <- PP PPEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
          PPState
s <- PP PPState
forall s (m :: * -> *). MonadState s m => m s
get
          [(Validation ParseError a, PPState)]
results <- IO [(Validation ParseError a, PPState)]
-> PP [(Validation ParseError a, PPState)]
forall a. IO a -> PP a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(Validation ParseError a, PPState)]
 -> PP [(Validation ParseError a, PPState)])
-> IO [(Validation ParseError a, PPState)]
-> PP [(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 -> PP 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 settingsMap :: Map SettingHash SrcLoc
settingsMap = Parser a -> Map SettingHash SrcLoc
forall a. Parser a -> Map SettingHash SrcLoc
parserSettingsMap Parser a
p'
                  -- Settings that have been parsed
                  Map SettingHash SrcLoc
parsedMap <- (PPState -> Map SettingHash SrcLoc) -> PP (Map SettingHash SrcLoc)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PPState -> Map SettingHash SrcLoc
ppStateParsedSettings
                  -- Settings that have been parsed below
                  let parsedSettingsMap :: Map SettingHash SrcLoc
parsedSettingsMap = Map SettingHash SrcLoc
settingsMap Map SettingHash SrcLoc
-> Map SettingHash SrcLoc -> Map SettingHash SrcLoc
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`M.intersection` Map SettingHash SrcLoc
parsedMap
                  -- 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 Map SettingHash SrcLoc -> Bool
forall a. Map SettingHash a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map SettingHash SrcLoc
parsedSettingsMap
                    then NonEmpty ParseError -> PP a
forall a. NonEmpty ParseError -> PP a
ppErrors' NonEmpty ParseError
errs
                    else 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 (Map SettingHash SrcLoc -> ParseErrorMessage
ParseErrorAllOrNothing Map SettingHash SrcLoc
parsedSettingsMap) ParseError -> [ParseError] -> NonEmpty ParseError
forall a. a -> [a] -> NonEmpty a
:| [])
      ParserCheck Maybe SrcLoc
mLoc Bool
forgivable Set Capability
requiredCapabilities 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]
        Bool -> PP () -> PP ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Set Capability -> Bool
forall a. Set a -> Bool
Set.null Set Capability
requiredCapabilities)) (PP () -> PP ()) -> PP () -> PP ()
forall a b. (a -> b) -> a -> b
$
          [Chunk] -> PP ()
debug ([Chunk] -> PP ()) -> [Chunk] -> PP ()
forall a b. (a -> b) -> a -> b
$
            Chunk
"Requires capabilities: "
              Chunk -> [Chunk] -> [Chunk]
forall a. a -> [a] -> [a]
: Set Capability -> [Chunk]
capabilitiesChunks Set Capability
requiredCapabilities

        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"]
          -- Definitely parse below
          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"]
          -- Only perform the check (IO) if capabilities are sufficient
          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
$
            Maybe SrcLoc -> Set Capability -> Capabilities -> PP a -> PP a
forall a.
Maybe SrcLoc -> Set Capability -> Capabilities -> PP a -> PP a
withCapabilities Maybe SrcLoc
mLoc Set Capability
requiredCapabilities Capabilities
capabilities (PP a -> PP a) -> PP a -> PP a
forall a b. (a -> b) -> a -> b
$ do
              Either String a
errOrB <- IO (Either String a) -> PP (Either String a)
forall a. IO a -> PP a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String a) -> PP (Either String a))
-> IO (Either String a) -> PP (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
          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
          case Maybe String
mS of
            Maybe String
Nothing -> do
              [Chunk] -> PP ()
debug [Chunk
"No argument found for choosing a command."]
              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 (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 -> 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
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) -> PP a -> PP 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 (ConfigValSetting a))
Maybe (NonEmpty EnvVarSetting)
Maybe (a, String)
Maybe Completer
Set Capability
settingDasheds :: [Dashed]
settingReaders :: [Reader a]
settingTryArgument :: Bool
settingSwitchValue :: Maybe a
settingTryOption :: Bool
settingEnvVars :: Maybe (NonEmpty EnvVarSetting)
settingConfigVals :: Maybe (NonEmpty (ConfigValSetting a))
settingDefaultValue :: Maybe (a, String)
settingExamples :: [String]
settingHidden :: Bool
settingMetavar :: Maybe String
settingHelp :: Maybe String
settingCompleter :: Maybe Completer
settingRequiredCapabilities :: Set Capability
settingRequiredCapabilities :: forall a. Setting a -> Set Capability
settingCompleter :: forall a. Setting a -> Maybe Completer
settingHelp :: forall a. Setting a -> Maybe String
settingMetavar :: forall a. Setting a -> Maybe String
settingHidden :: forall a. Setting a -> Bool
settingExamples :: forall a. Setting a -> [String]
settingDefaultValue :: forall a. Setting a -> Maybe (a, String)
settingConfigVals :: forall a. Setting a -> Maybe (NonEmpty (ConfigValSetting a))
settingEnvVars :: forall a. Setting a -> Maybe (NonEmpty EnvVarSetting)
settingTryOption :: forall a. Setting a -> Bool
settingSwitchValue :: forall a. Setting a -> Maybe a
settingTryArgument :: forall a. Setting a -> Bool
settingReaders :: forall a. Setting a -> [Reader a]
settingDasheds :: forall a. Setting a -> [Dashed]
..} -> do
        [Chunk] -> PP ()
debug [String -> Chunk
syntaxChunk String
"Setting", Chunk
": ", Maybe SrcLoc -> Chunk
mSrcLocChunk Maybe SrcLoc
mLoc]
        Bool -> PP () -> PP ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Set Capability -> Bool
forall a. Set a -> Bool
Set.null Set Capability
settingRequiredCapabilities)) (PP () -> PP ()) -> PP () -> PP ()
forall a b. (a -> b) -> a -> b
$
          [Chunk] -> PP ()
debug ([Chunk] -> PP ()) -> [Chunk] -> PP ()
forall a b. (a -> b) -> a -> b
$
            Chunk
"Requires capabilities: "
              Chunk -> [Chunk] -> [Chunk]
forall a. a -> [a] -> [a]
: Set Capability -> [Chunk]
capabilitiesChunks Set Capability
settingRequiredCapabilities

        -- Any argument parsing needs to still try to consume the relevant arguments, so we need to put
        -- this helper function after that instead of arround the whole setting parsing.
        -- After all the arguments, options, and switches have been tried, the rest can have a blanket 'cap'.
        let cap :: forall r. PP r -> PP r
            cap :: forall a. PP a -> PP a
cap = Maybe SrcLoc -> Set Capability -> Capabilities -> PP r -> PP r
forall a.
Maybe SrcLoc -> Set Capability -> Capabilities -> PP a -> PP a
withCapabilities Maybe SrcLoc
mLoc Set Capability
settingRequiredCapabilities Capabilities
capabilities

        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 -> PP 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 =
                            M.insert
                              (hashSetting set)
                              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 -> PP (ParseResult a) -> PP (ParseResult a)
cap (PP (ParseResult a) -> PP (ParseResult a))
-> PP (ParseResult a) -> PP (ParseResult a)
forall a b. (a -> b) -> a -> b
$
                    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 -> PP (ParseResult a)
forall a. Maybe SrcLoc -> ParseErrorMessage -> PP a
ppError Maybe SrcLoc
mLoc (ParseErrorMessage -> PP (ParseResult a))
-> ParseErrorMessage -> PP (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 -> PP (ParseResult a)
forall a. a -> PP 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 -> PP (ParseResult a)
forall a. a -> PP 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 () -> PP (ParseResult a) -> PP (ParseResult a)
cap (PP (ParseResult a) -> PP (ParseResult a))
-> PP (ParseResult a) -> PP (ParseResult a)
forall a b. (a -> b) -> a -> b
$ 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 -> PP (ParseResult a) -> PP (ParseResult a)
cap (PP (ParseResult a) -> PP (ParseResult a))
-> PP (ParseResult a) -> PP (ParseResult a)
forall a b. (a -> b) -> a -> b
$
                            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 -> PP (ParseResult a)
forall a. Maybe SrcLoc -> ParseErrorMessage -> PP a
ppError Maybe SrcLoc
mLoc (ParseErrorMessage -> PP (ParseResult a))
-> ParseErrorMessage -> PP (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 -> PP (ParseResult a)
forall a. a -> PP 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 <- PP (ParseResult a) -> PP (ParseResult a)
cap (PP (ParseResult a) -> PP (ParseResult a))
-> PP (ParseResult a) -> PP (ParseResult a)
forall a b. (a -> b) -> a -> b
$ case Maybe (NonEmpty EnvVarSetting)
settingEnvVars of
                        Maybe (NonEmpty EnvVarSetting)
Nothing -> ParseResult a -> PP (ParseResult a)
forall a. a -> PP a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ParseResult a
forall a. ParseResult a
NotRun
                        Just NonEmpty EnvVarSetting
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) -> PP EnvMap
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PPEnv -> EnvMap
ppEnvEnv
                          let founds :: [String]
founds = (EnvVarSetting -> Maybe String) -> [EnvVarSetting] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((String -> EnvMap -> Maybe String
`EnvMap.lookup` EnvMap
es) (String -> Maybe String)
-> (EnvVarSetting -> String) -> EnvVarSetting -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnvVarSetting -> String
envVarSettingVar) (NonEmpty EnvVarSetting -> [EnvVarSetting]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty EnvVarSetting
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) -> PP [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [String]
founds ((String -> PP a) -> PP [a]) -> (String -> PP a) -> PP [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
$ [EnvVarSetting] -> String
forall a. Show a => a -> String
show ([EnvVarSetting] -> String) -> [EnvVarSetting] -> String
forall a b. (a -> b) -> a -> b
$ [EnvVarSetting]
-> (NonEmpty EnvVarSetting -> [EnvVarSetting])
-> Maybe (NonEmpty EnvVarSetting)
-> [EnvVarSetting]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] NonEmpty EnvVarSetting -> [EnvVarSetting]
forall a. NonEmpty a -> [a]
NE.toList Maybe (NonEmpty EnvVarSetting)
settingEnvVars
                                ]
                              pure ParseResult a
forall a. ParseResult a
NotFound
                            Just a
a -> ParseResult a -> PP (ParseResult a)
forall a. a -> PP a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParseResult a -> PP (ParseResult a))
-> ParseResult a -> PP (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 -> PP (ParseResult a)
forall a. a -> PP 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 {Bool
NonEmpty String
ValueCodec void (Maybe a)
configValSettingPath :: NonEmpty String
configValSettingAllowPrefix :: Bool
configValSettingCodec :: ValueCodec void (Maybe a)
configValSettingCodec :: ()
configValSettingAllowPrefix :: forall a. ConfigValSetting a -> Bool
configValSettingPath :: forall a. ConfigValSetting a -> NonEmpty String
..} = 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) -> PP (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) -> PP (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 -> PP (ParseResult a)
forall a. a -> PP a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParseResult a -> PP (ParseResult a))
-> ParseResult a -> PP (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) -> PP (ParseResult a)
goConfSets NonEmpty (ConfigValSetting a)
ne
                                  NonEmpty (ConfigValSetting a) -> PP (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
                                        ]

withCapabilities ::
  Maybe SrcLoc ->
  Set Capability ->
  Capabilities ->
  PP a ->
  PP a
withCapabilities :: forall a.
Maybe SrcLoc -> Set Capability -> Capabilities -> PP a -> PP a
withCapabilities Maybe SrcLoc
mLoc Set Capability
requiredCapabilities Capabilities
capabilities PP a
func =
  case Capabilities -> Set Capability -> Maybe (NonEmpty Capability)
missingCapabilities Capabilities
capabilities Set Capability
requiredCapabilities of
    Just NonEmpty Capability
missings -> do
      [Chunk] -> PP ()
debug ([Chunk] -> PP ()) -> [Chunk] -> PP ()
forall a b. (a -> b) -> a -> b
$
        Chunk
"Missing capabilities: "
          Chunk -> [Chunk] -> [Chunk]
forall a. a -> [a] -> [a]
: Set Capability -> [Chunk]
capabilitiesChunks ([Capability] -> Set Capability
forall a. Ord a => [a] -> Set a
Set.fromList (NonEmpty Capability -> [Capability]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Capability
missings))
      Maybe SrcLoc -> NonEmpty ParseErrorMessage -> PP a
forall a. Maybe SrcLoc -> NonEmpty ParseErrorMessage -> PP a
ppErrors Maybe SrcLoc
mLoc (NonEmpty ParseErrorMessage -> PP a)
-> NonEmpty ParseErrorMessage -> PP a
forall a b. (a -> b) -> a -> b
$ (Capability -> ParseErrorMessage)
-> NonEmpty Capability -> NonEmpty ParseErrorMessage
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map Capability -> ParseErrorMessage
ParseErrorMissingCapability NonEmpty Capability
missings
    Maybe (NonEmpty Capability)
Nothing -> PP a
func

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 -> PP 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 :: Map SettingHash SrcLoc
ppStateParsedSettings = Map SettingHash SrcLoc
forall k a. Map k a
M.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 Maybe SrcLoc
mLoc Parser a1
p' -> do
              [Chunk] -> PP ()
debug [String -> Chunk
syntaxChunk String
"Many", 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'
            ParserSome Maybe SrcLoc
mLoc Parser a1
p' -> do
              [Chunk] -> PP ()
debug [String -> Chunk
syntaxChunk String
"Some", 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'
            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
_ Set Capability
_ 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

newtype PP a = PP (ReaderT PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a)
  deriving
    ( (forall a b. (a -> b) -> PP a -> PP b)
-> (forall a b. a -> PP b -> PP a) -> Functor PP
forall a b. a -> PP b -> PP a
forall a b. (a -> b) -> PP a -> PP b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> PP a -> PP b
fmap :: forall a b. (a -> b) -> PP a -> PP b
$c<$ :: forall a b. a -> PP b -> PP a
<$ :: forall a b. a -> PP b -> PP a
Functor,
      Functor PP
Functor PP =>
(forall a. a -> PP a)
-> (forall a b. PP (a -> b) -> PP a -> PP b)
-> (forall a b c. (a -> b -> c) -> PP a -> PP b -> PP c)
-> (forall a b. PP a -> PP b -> PP b)
-> (forall a b. PP a -> PP b -> PP a)
-> Applicative PP
forall a. a -> PP a
forall a b. PP a -> PP b -> PP a
forall a b. PP a -> PP b -> PP b
forall a b. PP (a -> b) -> PP a -> PP b
forall a b c. (a -> b -> c) -> PP a -> PP b -> PP c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> PP a
pure :: forall a. a -> PP a
$c<*> :: forall a b. PP (a -> b) -> PP a -> PP b
<*> :: forall a b. PP (a -> b) -> PP a -> PP b
$cliftA2 :: forall a b c. (a -> b -> c) -> PP a -> PP b -> PP c
liftA2 :: forall a b c. (a -> b -> c) -> PP a -> PP b -> PP c
$c*> :: forall a b. PP a -> PP b -> PP b
*> :: forall a b. PP a -> PP b -> PP b
$c<* :: forall a b. PP a -> PP b -> PP a
<* :: forall a b. PP a -> PP b -> PP a
Applicative,
      Applicative PP
Applicative PP =>
(forall a b. PP (Either a b) -> PP (a -> b) -> PP b)
-> Selective PP
forall a b. PP (Either a b) -> PP (a -> b) -> PP b
forall (f :: * -> *).
Applicative f =>
(forall a b. f (Either a b) -> f (a -> b) -> f b) -> Selective f
$cselect :: forall a b. PP (Either a b) -> PP (a -> b) -> PP b
select :: forall a b. PP (Either a b) -> PP (a -> b) -> PP b
Selective,
      Applicative PP
Applicative PP =>
(forall a b. PP a -> (a -> PP b) -> PP b)
-> (forall a b. PP a -> PP b -> PP b)
-> (forall a. a -> PP a)
-> Monad PP
forall a. a -> PP a
forall a b. PP a -> PP b -> PP b
forall a b. PP a -> (a -> PP b) -> PP b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. PP a -> (a -> PP b) -> PP b
>>= :: forall a b. PP a -> (a -> PP b) -> PP b
$c>> :: forall a b. PP a -> PP b -> PP b
>> :: forall a b. PP a -> PP b -> PP b
$creturn :: forall a. a -> PP a
return :: forall a. a -> PP a
Monad,
      Monad PP
Monad PP => (forall a. IO a -> PP a) -> MonadIO PP
forall a. IO a -> PP a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> PP a
liftIO :: forall a. IO a -> PP a
MonadIO,
      MonadReader PPEnv,
      MonadState PPState
    )

runPP ::
  PP a ->
  PPState ->
  PPEnv ->
  IO [(Validation ParseError a, PPState)]
runPP :: forall a.
PP a -> PPState -> PPEnv -> IO [(Validation ParseError a, PPState)]
runPP (PP ReaderT
  PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) 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 (ReaderT
  PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
-> PPEnv -> ValidationT ParseError (StateT PPState (NonDetT IO)) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT
  PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) 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 ReaderT
  PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) 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 (ReaderT
  PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
-> PPEnv -> ValidationT ParseError (StateT PPState (NonDetT IO)) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT
  PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) 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 <- PP PPState
forall s (m :: * -> *). MonadState s m => m s
get
  PPEnv
e <- PP PPEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
  [(Validation ParseError a, PPState)]
results <- IO [(Validation ParseError a, PPState)]
-> PP [(Validation ParseError a, PPState)]
forall a. IO a -> PP a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(Validation ParseError a, PPState)]
 -> PP [(Validation ParseError a, PPState)])
-> IO [(Validation ParseError a, PPState)]
-> PP [(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 -> PP 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 = ReaderT
  PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
-> PP a
forall a.
ReaderT
  PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
-> PP a
PP (ReaderT
   PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
 -> PP a)
-> (NonDetT IO a
    -> ReaderT
         PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a)
-> NonDetT IO a
-> PP a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 -> Map SettingHash SrcLoc
ppStateParsedSettings :: !(Map SettingHash SrcLoc)
  }

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)
-> PP (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) -> PP 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 -> PP 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) -> PP a -> PP a
forall a. (PPEnv -> PPEnv) -> PP a -> PP 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) -> PP 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) -> PP 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 -> PP 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) -> PP 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 -> PP 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' = ReaderT
  PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
-> PP a
forall a.
ReaderT
  PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
-> PP a
PP (ReaderT
   PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a
 -> PP a)
-> (NonEmpty ParseError
    -> ReaderT
         PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a)
-> NonEmpty ParseError
-> PP a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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