{-# LANGUAGE Rank2Types, ExistentialQuantification #-}
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(..),
fromM,
oneM,
manyM,
someM,
optVisibility,
optMetaVar,
optHelp,
optShowDefault
) where
import Control.Applicative
(Applicative(..), Alternative(..), (<$>), optional)
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 Data.Monoid (Monoid(..))
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 (OptTree (Chunk Doc))
deriving Show
instance Monoid ParseError where
mempty = UnknownError
mappend m UnknownError = m
mappend _ m = m
-- | A full description for a runnable 'Parser' for a program.
data ParserInfo a = ParserInfo
{ infoParser :: Parser a -- ^ the option parser for the program
, infoFullDesc :: Bool -- ^ whether the help text should contain full
-- documentation
, infoProgDesc :: Chunk Doc -- ^ brief parser description
, infoHeader :: Chunk Doc -- ^ header of the full parser description
, infoFooter :: Chunk Doc -- ^ footer of the full parser description
, infoFailureCode :: Int -- ^ exit code for a parser failure
, infoIntersperse :: Bool -- ^ allow regular options and flags to occur
-- after arguments (default: True)
}
instance Functor ParserInfo where
fmap f i = i { infoParser = fmap f (infoParser i) }
-- | Global preferences for a top-level 'Parser'.
data ParserPrefs = ParserPrefs
{ prefMultiSuffix :: String -- ^ metavar suffix for multiple options
, prefDisambiguate :: Bool -- ^ automatically disambiguate abbreviations
-- (default: False)
, prefShowHelpOnError :: Bool -- ^ always show help text on parse errors
-- (default: False)
, prefBacktrack :: Bool -- ^ backtrack to parent parser when a
-- subcommand fails (default: True)
, prefColumns :: Int -- ^ number of columns in the terminal, used to
-- format the help page (default: 80)
} deriving (Eq, Show)
data OptName = OptShort !Char
| OptLong !String
deriving (Eq, Ord, Show)
-- | Visibility of an option in the help text.
data OptVisibility
= Internal -- ^ does not appear in the help text at all
| Hidden -- ^ only visible in the full description
| Visible -- ^ visible both in the full and brief descriptions
deriving (Eq, Ord, Show)
-- | Specification for an individual parser option.
data OptProperties = OptProperties
{ propVisibility :: OptVisibility -- ^ whether this flag is shown is the brief description
, propHelp :: Chunk Doc -- ^ help text for this option
, propMetaVar :: String -- ^ metavariable for this option
, propShowDefault :: Maybe String -- ^ what to show in the help text as the default
} deriving Show
-- | A single option of a parser.
data Option a = Option
{ optMain :: OptReader a -- ^ reader for this option
, optProps :: OptProperties -- ^ properties of this option
}
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
-- | A newtype over 'ReaderT String Except', used by option readers.
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 = readerError
instance MonadPlus ReadM where
mzero = ReadM mzero
mplus (ReadM x) (ReadM y) = ReadM $ mplus x y
-- | Return the value being read.
readerAsk :: ReadM String
readerAsk = ReadM ask
-- | Abort option reader by exiting with a 'ParseError'.
readerAbort :: ParseError -> ReadM a
readerAbort = ReadM . lift . throwE
-- | Abort option reader by exiting with an error message.
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)
-- | An 'OptReader' defines whether an option matches an command line argument.
data OptReader a
= OptReader [OptName] (CReader a) ParseError -- ^ option reader
| FlagReader [OptName] !a -- ^ flag reader
| ArgReader (CReader a) -- ^ argument reader
| CmdReader [String] (String -> Maybe (ParserInfo a)) -- ^ command reader
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 cs g) = CmdReader cs ((fmap . fmap) f . g)
-- | A @Parser a@ is an option parser returning a value of type 'a'.
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 x = ParserM $ \k -> k x
ParserM f >>= g = ParserM $ \k -> f (\x -> runParserM (g x) k)
instance Functor ParserM where
fmap = liftM
instance Applicative ParserM where
pure = return
(<*>) = 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 Monoid Completer where
mempty = Completer $ \_ -> return []
mappend (Completer c1) (Completer c2) =
Completer $ \s -> (++) <$> c1 s <*> c2 s
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)
-- | Result of 'execParserPure'.
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
= SkipOpts
| AllowOpts
deriving (Eq, Show)
data OptHelpInfo = OptHelpInfo
{ hinfoMulti :: Bool
, hinfoDefault :: 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