module Options.Applicative.Types (
ParseError(..),
ParserInfo(..),
ParserPrefs(..),
Option(..),
OptName(..),
OptReader(..),
OptProperties(..),
OptVisibility(..),
ReadM(..),
readerAsk,
readerAbort,
readerError,
CReader(..),
Parser(..),
ParserM(..),
Completer(..),
mkCompleter,
CompletionResult(..),
ParserFailure(..),
ParserResult(..),
overFailure,
Args,
ArgPolicy(..),
OptHelpInfo(..),
OptTree(..),
ParserHelp(..),
SomeParser(..),
Context(..),
IsCmdStart(..),
fromM,
oneM,
manyM,
someM,
optVisibility,
optMetaVar,
optHelp,
optShowDefault,
optDescMod
) where
import Control.Applicative
import Control.Monad (ap, liftM, MonadPlus, mzero, mplus)
import Control.Monad.Trans.Except (Except, throwE)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Reader (ReaderT, ask)
import qualified Control.Monad.Fail as Fail
import Data.Semigroup hiding (Option)
import Prelude
import System.Exit (ExitCode(..))
import Options.Applicative.Help.Types
import Options.Applicative.Help.Pretty
import Options.Applicative.Help.Chunk
data ParseError
= ErrorMsg String
| InfoMsg String
| ShowHelpText
| UnknownError
| MissingError IsCmdStart SomeParser
| ExpectsArgError String
| UnexpectedError String SomeParser
data IsCmdStart = CmdStart | CmdCont
deriving Show
instance Monoid ParseError where
mempty = UnknownError
mappend = (<>)
instance Semigroup ParseError where
m <> UnknownError = m
_ <> m = m
data ParserInfo a = ParserInfo
{ infoParser :: Parser a
, infoFullDesc :: Bool
, infoProgDesc :: Chunk Doc
, infoHeader :: Chunk Doc
, infoFooter :: Chunk Doc
, infoFailureCode :: Int
, infoPolicy :: ArgPolicy
}
instance Functor ParserInfo where
fmap f i = i { infoParser = fmap f (infoParser i) }
data ParserPrefs = ParserPrefs
{ prefMultiSuffix :: String
, prefDisambiguate :: Bool
, prefShowHelpOnError :: Bool
, prefShowHelpOnEmpty :: Bool
, prefBacktrack :: Bool
, prefColumns :: Int
} deriving (Eq, Show)
data OptName = OptShort !Char
| OptLong !String
deriving (Eq, Ord, Show)
data OptVisibility
= Internal
| Hidden
| Visible
deriving (Eq, Ord, Show)
data OptProperties = OptProperties
{ propVisibility :: OptVisibility
, propHelp :: Chunk Doc
, propMetaVar :: String
, propShowDefault :: Maybe String
, propDescMod :: Maybe ( Doc -> Doc )
}
instance Show OptProperties where
showsPrec p (OptProperties pV pH pMV pSD _)
= showParen (p >= 11)
$ showString "OptProperties { propVisibility = " . shows pV
. showString ", propHelp = " . shows pH
. showString ", propMetaVar = " . shows pMV
. showString ", propShowDefault = " . shows pSD
. showString ", propDescMod = _ }"
data Option a = Option
{ optMain :: OptReader a
, optProps :: OptProperties
}
data SomeParser = forall a . SomeParser (Parser a)
data Context = forall a . Context String (ParserInfo a)
instance Show (Option a) where
show opt = "Option {optProps = " ++ show (optProps opt) ++ "}"
instance Functor Option where
fmap f (Option m p) = Option (fmap f m) p
newtype ReadM a = ReadM
{ unReadM :: ReaderT String (Except ParseError) a }
instance Functor ReadM where
fmap f (ReadM r) = ReadM (fmap f r)
instance Applicative ReadM where
pure = ReadM . pure
ReadM x <*> ReadM y = ReadM $ x <*> y
instance Alternative ReadM where
empty = mzero
(<|>) = mplus
instance Monad ReadM where
return = pure
ReadM r >>= f = ReadM $ r >>= unReadM . f
fail = Fail.fail
instance Fail.MonadFail ReadM where
fail = readerError
instance MonadPlus ReadM where
mzero = ReadM mzero
mplus (ReadM x) (ReadM y) = ReadM $ mplus x y
readerAsk :: ReadM String
readerAsk = ReadM ask
readerAbort :: ParseError -> ReadM a
readerAbort = ReadM . lift . throwE
readerError :: String -> ReadM a
readerError = readerAbort . ErrorMsg
data CReader a = CReader
{ crCompleter :: Completer
, crReader :: ReadM a }
instance Functor CReader where
fmap f (CReader c r) = CReader c (fmap f r)
data OptReader a
= OptReader [OptName] (CReader a) (String -> ParseError)
| FlagReader [OptName] !a
| ArgReader (CReader a)
| CmdReader (Maybe String) [String] (String -> Maybe (ParserInfo a))
instance Functor OptReader where
fmap f (OptReader ns cr e) = OptReader ns (fmap f cr) e
fmap f (FlagReader ns x) = FlagReader ns (f x)
fmap f (ArgReader cr) = ArgReader (fmap f cr)
fmap f (CmdReader n cs g) = CmdReader n cs ((fmap . fmap) f . g)
data Parser a
= NilP (Maybe a)
| OptP (Option a)
| forall x . MultP (Parser (x -> a)) (Parser x)
| AltP (Parser a) (Parser a)
| forall x . BindP (Parser x) (x -> Parser a)
instance Functor Parser where
fmap f (NilP x) = NilP (fmap f x)
fmap f (OptP opt) = OptP (fmap f opt)
fmap f (MultP p1 p2) = MultP (fmap (f.) p1) p2
fmap f (AltP p1 p2) = AltP (fmap f p1) (fmap f p2)
fmap f (BindP p k) = BindP p (fmap f . k)
instance Applicative Parser where
pure = NilP . Just
(<*>) = MultP
newtype ParserM r = ParserM
{ runParserM :: forall x . (r -> Parser x) -> Parser x }
instance Monad ParserM where
return = pure
ParserM f >>= g = ParserM $ \k -> f (\x -> runParserM (g x) k)
instance Functor ParserM where
fmap = liftM
instance Applicative ParserM where
pure x = ParserM $ \k -> k x
(<*>) = ap
fromM :: ParserM a -> Parser a
fromM (ParserM f) = f pure
oneM :: Parser a -> ParserM a
oneM p = ParserM (BindP p)
manyM :: Parser a -> ParserM [a]
manyM p = do
mx <- oneM (optional p)
case mx of
Nothing -> return []
Just x -> (x:) <$> manyM p
someM :: Parser a -> ParserM [a]
someM p = (:) <$> oneM p <*> manyM p
instance Alternative Parser where
empty = NilP Nothing
(<|>) = AltP
many p = fromM $ manyM p
some p = fromM $ (:) <$> oneM p <*> manyM p
newtype Completer = Completer
{ runCompleter :: String -> IO [String] }
mkCompleter :: (String -> IO [String]) -> Completer
mkCompleter = Completer
instance Semigroup Completer where
(Completer c1) <> (Completer c2) =
Completer $ \s -> (++) <$> c1 s <*> c2 s
instance Monoid Completer where
mempty = Completer $ \_ -> return []
mappend = (<>)
newtype CompletionResult = CompletionResult
{ execCompletion :: String -> IO String }
instance Show CompletionResult where
showsPrec p _ = showParen (p > 10) $
showString "CompletionResult _"
newtype ParserFailure h = ParserFailure
{ execFailure :: String -> (h, ExitCode, Int) }
instance Show h => Show (ParserFailure h) where
showsPrec p (ParserFailure f)
= showParen (p > 10)
$ showString "ParserFailure "
. showsPrec 11 (f "<program>")
instance Functor ParserFailure where
fmap f (ParserFailure err) = ParserFailure $ \progn ->
let (h, exit, cols) = err progn in (f h, exit, cols)
data ParserResult a
= Success a
| Failure (ParserFailure ParserHelp)
| CompletionInvoked CompletionResult
deriving Show
instance Functor ParserResult where
fmap f (Success a) = Success (f a)
fmap _ (Failure f) = Failure f
fmap _ (CompletionInvoked c) = CompletionInvoked c
overFailure :: (ParserHelp -> ParserHelp)
-> ParserResult a -> ParserResult a
overFailure f (Failure failure) = Failure $ fmap f failure
overFailure _ r = r
instance Applicative ParserResult where
pure = Success
Success f <*> r = fmap f r
Failure f <*> _ = Failure f
CompletionInvoked c <*> _ = CompletionInvoked c
instance Monad ParserResult where
return = pure
Success x >>= f = f x
Failure f >>= _ = Failure f
CompletionInvoked c >>= _ = CompletionInvoked c
type Args = [String]
data ArgPolicy
= Intersperse
| NoIntersperse
| AllPositionals
| ForwardOptions
deriving (Eq, Ord, Show)
data OptHelpInfo = OptHelpInfo
{ hinfoMulti :: Bool
, hinfoDefault :: Bool
, hinfoUnreachableArgs :: Bool
} deriving (Eq, Show)
data OptTree a
= Leaf a
| MultNode [OptTree a]
| AltNode [OptTree a]
deriving Show
optVisibility :: Option a -> OptVisibility
optVisibility = propVisibility . optProps
optHelp :: Option a -> Chunk Doc
optHelp = propHelp . optProps
optMetaVar :: Option a -> String
optMetaVar = propMetaVar . optProps
optShowDefault :: Option a -> Maybe String
optShowDefault = propShowDefault . optProps
optDescMod :: Option a -> Maybe ( Doc -> Doc )
optDescMod = propDescMod . optProps