1{-# LANGUAGE CPP, Rank2Types, ExistentialQuantification #-} 2module Options.Applicative.Types ( 3 ParseError(..), 4 ParserInfo(..), 5 ParserPrefs(..), 6 7 Option(..), 8 OptName(..), 9 isShortName, 10 isLongName, 11 12 OptReader(..), 13 OptProperties(..), 14 OptVisibility(..), 15 Backtracking(..), 16 ReadM(..), 17 readerAsk, 18 readerAbort, 19 readerError, 20 CReader(..), 21 Parser(..), 22 ParserM(..), 23 Completer(..), 24 mkCompleter, 25 CompletionResult(..), 26 ParserFailure(..), 27 ParserResult(..), 28 overFailure, 29 Args, 30 ArgPolicy(..), 31 OptHelpInfo(..), 32 AltNodeType(..), 33 OptTree(..), 34 ParserHelp(..), 35 SomeParser(..), 36 Context(..), 37 IsCmdStart(..), 38 39 fromM, 40 oneM, 41 manyM, 42 someM, 43 44 filterOptional, 45 optVisibility, 46 optMetaVar, 47 optHelp, 48 optShowDefault, 49 optDescMod 50 ) where 51 52import Control.Applicative 53import Control.Monad (ap, liftM, MonadPlus, mzero, mplus) 54import Control.Monad.Trans.Except (Except, throwE) 55import Control.Monad.Trans.Class (lift) 56import Control.Monad.Trans.Reader (ReaderT, ask) 57import qualified Control.Monad.Fail as Fail 58import Data.Semigroup hiding (Option) 59import Prelude 60 61import System.Exit (ExitCode(..)) 62 63import Options.Applicative.Help.Types 64import Options.Applicative.Help.Pretty 65import Options.Applicative.Help.Chunk 66 67 68data ParseError 69 = ErrorMsg String 70 | InfoMsg String 71 | ShowHelpText 72 | UnknownError 73 | MissingError IsCmdStart SomeParser 74 | ExpectsArgError String 75 | UnexpectedError String SomeParser 76 77data IsCmdStart = CmdStart | CmdCont 78 deriving Show 79 80instance Monoid ParseError where 81 mempty = UnknownError 82 mappend = (<>) 83 84instance Semigroup ParseError where 85 m <> UnknownError = m 86 _ <> m = m 87 88-- | A full description for a runnable 'Parser' for a program. 89data ParserInfo a = ParserInfo 90 { infoParser :: Parser a -- ^ the option parser for the program 91 , infoFullDesc :: Bool -- ^ whether the help text should contain full 92 -- documentation 93 , infoProgDesc :: Chunk Doc -- ^ brief parser description 94 , infoHeader :: Chunk Doc -- ^ header of the full parser description 95 , infoFooter :: Chunk Doc -- ^ footer of the full parser description 96 , infoFailureCode :: Int -- ^ exit code for a parser failure 97 , infoPolicy :: ArgPolicy -- ^ allow regular options and flags to occur 98 -- after arguments (default: InterspersePolicy) 99 } 100 101instance Functor ParserInfo where 102 fmap f i = i { infoParser = fmap f (infoParser i) } 103 104data Backtracking 105 = Backtrack 106 | NoBacktrack 107 | SubparserInline 108 deriving (Eq, Show) 109 110-- | Global preferences for a top-level 'Parser'. 111data ParserPrefs = ParserPrefs 112 { prefMultiSuffix :: String -- ^ metavar suffix for multiple options 113 , prefDisambiguate :: Bool -- ^ automatically disambiguate abbreviations 114 -- (default: False) 115 , prefShowHelpOnError :: Bool -- ^ always show help text on parse errors 116 -- (default: False) 117 , prefShowHelpOnEmpty :: Bool -- ^ show the help text for a command or subcommand 118 -- if it fails with no input (default: False) 119 , prefBacktrack :: Backtracking -- ^ backtrack to parent parser when a 120 -- subcommand fails (default: Backtrack) 121 , prefColumns :: Int -- ^ number of columns in the terminal, used to 122 -- format the help page (default: 80) 123 , prefHelpLongEquals :: Bool -- ^ when displaying long names in usage and help, 124 -- use an '=' sign for long names, rather than a 125 -- single space (default: False) 126 } deriving (Eq, Show) 127 128data OptName = OptShort !Char 129 | OptLong !String 130 deriving (Eq, Ord, Show) 131 132isShortName :: OptName -> Bool 133isShortName (OptShort _) = True 134isShortName (OptLong _) = False 135 136isLongName :: OptName -> Bool 137isLongName = not . isShortName 138 139-- | Visibility of an option in the help text. 140data OptVisibility 141 = Internal -- ^ does not appear in the help text at all 142 | Hidden -- ^ only visible in the full description 143 | Visible -- ^ visible both in the full and brief descriptions 144 deriving (Eq, Ord, Show) 145 146-- | Specification for an individual parser option. 147data OptProperties = OptProperties 148 { propVisibility :: OptVisibility -- ^ whether this flag is shown in the brief description 149 , propHelp :: Chunk Doc -- ^ help text for this option 150 , propMetaVar :: String -- ^ metavariable for this option 151 , propShowDefault :: Maybe String -- ^ what to show in the help text as the default 152 , propDescMod :: Maybe ( Doc -> Doc ) -- ^ a function to run over the brief description 153 } 154 155instance Show OptProperties where 156 showsPrec p (OptProperties pV pH pMV pSD _) 157 = showParen (p >= 11) 158 $ showString "OptProperties { propVisibility = " . shows pV 159 . showString ", propHelp = " . shows pH 160 . showString ", propMetaVar = " . shows pMV 161 . showString ", propShowDefault = " . shows pSD 162 . showString ", propDescMod = _ }" 163 164-- | A single option of a parser. 165data Option a = Option 166 { optMain :: OptReader a -- ^ reader for this option 167 , optProps :: OptProperties -- ^ properties of this option 168 } 169 170data SomeParser = forall a . SomeParser (Parser a) 171 172-- | Subparser context, containing the 'name' of the subparser, and its parser info. 173-- Used by parserFailure to display relevant usage information when parsing inside a subparser fails. 174data Context = forall a . Context String (ParserInfo a) 175 176instance Show (Option a) where 177 show opt = "Option {optProps = " ++ show (optProps opt) ++ "}" 178 179instance Functor Option where 180 fmap f (Option m p) = Option (fmap f m) p 181 182-- | A newtype over 'ReaderT String Except', used by option readers. 183newtype ReadM a = ReadM 184 { unReadM :: ReaderT String (Except ParseError) a } 185 186instance Functor ReadM where 187 fmap f (ReadM r) = ReadM (fmap f r) 188 189instance Applicative ReadM where 190 pure = ReadM . pure 191 ReadM x <*> ReadM y = ReadM $ x <*> y 192 193instance Alternative ReadM where 194 empty = mzero 195 (<|>) = mplus 196 197instance Monad ReadM where 198 return = pure 199 ReadM r >>= f = ReadM $ r >>= unReadM . f 200 201#if !(MIN_VERSION_base(4,13,0)) 202 fail = Fail.fail 203#endif 204 205instance Fail.MonadFail ReadM where 206 fail = readerError 207 208instance MonadPlus ReadM where 209 mzero = ReadM mzero 210 mplus (ReadM x) (ReadM y) = ReadM $ mplus x y 211 212-- | Return the value being read. 213readerAsk :: ReadM String 214readerAsk = ReadM ask 215 216-- | Abort option reader by exiting with a 'ParseError'. 217readerAbort :: ParseError -> ReadM a 218readerAbort = ReadM . lift . throwE 219 220-- | Abort option reader by exiting with an error message. 221readerError :: String -> ReadM a 222readerError = readerAbort . ErrorMsg 223 224data CReader a = CReader 225 { crCompleter :: Completer 226 , crReader :: ReadM a } 227 228instance Functor CReader where 229 fmap f (CReader c r) = CReader c (fmap f r) 230 231-- | An 'OptReader' defines whether an option matches an command line argument. 232data OptReader a 233 = OptReader [OptName] (CReader a) (String -> ParseError) 234 -- ^ option reader 235 | FlagReader [OptName] !a 236 -- ^ flag reader 237 | ArgReader (CReader a) 238 -- ^ argument reader 239 | CmdReader (Maybe String) [String] (String -> Maybe (ParserInfo a)) 240 -- ^ command reader 241 242instance Functor OptReader where 243 fmap f (OptReader ns cr e) = OptReader ns (fmap f cr) e 244 fmap f (FlagReader ns x) = FlagReader ns (f x) 245 fmap f (ArgReader cr) = ArgReader (fmap f cr) 246 fmap f (CmdReader n cs g) = CmdReader n cs ((fmap . fmap) f . g) 247 248-- | A @Parser a@ is an option parser returning a value of type 'a'. 249data Parser a 250 = NilP (Maybe a) 251 | OptP (Option a) 252 | forall x . MultP (Parser (x -> a)) (Parser x) 253 | AltP (Parser a) (Parser a) 254 | forall x . BindP (Parser x) (x -> Parser a) 255 256instance Functor Parser where 257 fmap f (NilP x) = NilP (fmap f x) 258 fmap f (OptP opt) = OptP (fmap f opt) 259 fmap f (MultP p1 p2) = MultP (fmap (f.) p1) p2 260 fmap f (AltP p1 p2) = AltP (fmap f p1) (fmap f p2) 261 fmap f (BindP p k) = BindP p (fmap f . k) 262 263instance Applicative Parser where 264 pure = NilP . Just 265 (<*>) = MultP 266 267newtype ParserM r = ParserM 268 { runParserM :: forall x . (r -> Parser x) -> Parser x } 269 270instance Monad ParserM where 271 return = pure 272 ParserM f >>= g = ParserM $ \k -> f (\x -> runParserM (g x) k) 273 274instance Functor ParserM where 275 fmap = liftM 276 277instance Applicative ParserM where 278 pure x = ParserM $ \k -> k x 279 (<*>) = ap 280 281fromM :: ParserM a -> Parser a 282fromM (ParserM f) = f pure 283 284oneM :: Parser a -> ParserM a 285oneM p = ParserM (BindP p) 286 287manyM :: Parser a -> ParserM [a] 288manyM p = do 289 mx <- oneM (optional p) 290 case mx of 291 Nothing -> return [] 292 Just x -> (x:) <$> manyM p 293 294someM :: Parser a -> ParserM [a] 295someM p = (:) <$> oneM p <*> manyM p 296 297instance Alternative Parser where 298 empty = NilP Nothing 299 (<|>) = AltP 300 many p = fromM $ manyM p 301 some p = fromM $ (:) <$> oneM p <*> manyM p 302 303-- | A shell complete function. 304newtype Completer = Completer 305 { runCompleter :: String -> IO [String] } 306 307-- | Smart constructor for a 'Completer' 308mkCompleter :: (String -> IO [String]) -> Completer 309mkCompleter = Completer 310 311instance Semigroup Completer where 312 (Completer c1) <> (Completer c2) = 313 Completer $ \s -> (++) <$> c1 s <*> c2 s 314 315instance Monoid Completer where 316 mempty = Completer $ \_ -> return [] 317 mappend = (<>) 318 319newtype CompletionResult = CompletionResult 320 { execCompletion :: String -> IO String } 321 322instance Show CompletionResult where 323 showsPrec p _ = showParen (p > 10) $ 324 showString "CompletionResult _" 325 326newtype ParserFailure h = ParserFailure 327 { execFailure :: String -> (h, ExitCode, Int) } 328 329instance Show h => Show (ParserFailure h) where 330 showsPrec p (ParserFailure f) 331 = showParen (p > 10) 332 $ showString "ParserFailure " 333 . showsPrec 11 (f "<program>") 334 335instance Functor ParserFailure where 336 fmap f (ParserFailure err) = ParserFailure $ \progn -> 337 let (h, exit, cols) = err progn in (f h, exit, cols) 338 339-- | Result of 'execParserPure'. 340data ParserResult a 341 = Success a 342 | Failure (ParserFailure ParserHelp) 343 | CompletionInvoked CompletionResult 344 deriving Show 345 346instance Functor ParserResult where 347 fmap f (Success a) = Success (f a) 348 fmap _ (Failure f) = Failure f 349 fmap _ (CompletionInvoked c) = CompletionInvoked c 350 351overFailure :: (ParserHelp -> ParserHelp) 352 -> ParserResult a -> ParserResult a 353overFailure f (Failure failure) = Failure $ fmap f failure 354overFailure _ r = r 355 356instance Applicative ParserResult where 357 pure = Success 358 Success f <*> r = fmap f r 359 Failure f <*> _ = Failure f 360 CompletionInvoked c <*> _ = CompletionInvoked c 361 362instance Monad ParserResult where 363 return = pure 364 Success x >>= f = f x 365 Failure f >>= _ = Failure f 366 CompletionInvoked c >>= _ = CompletionInvoked c 367 368type Args = [String] 369 370-- | Policy for how to handle options within the parse 371data ArgPolicy 372 = Intersperse 373 -- ^ The default policy, options and arguments can 374 -- be interspersed. 375 -- A `--` option can be passed to ensure all following 376 -- commands are treated as arguments. 377 | NoIntersperse 378 -- ^ Options must all come before arguments, once a 379 -- single positional argument or subcommand is parsed, 380 -- all remaining arguments are treated as positionals. 381 -- A `--` option can be passed if the first positional 382 -- one needs starts with `-`. 383 | AllPositionals 384 -- ^ No options are parsed at all, all arguments are 385 -- treated as positionals. 386 -- Is the policy used after `--` is encountered. 387 | ForwardOptions 388 -- ^ Options and arguments can be interspersed, but if 389 -- a given option is not found, it is treated as a 390 -- positional argument. This is sometimes useful if 391 -- one is passing through most options to another tool, 392 -- but are supplying just a few of their own options. 393 deriving (Eq, Ord, Show) 394 395data OptHelpInfo = OptHelpInfo 396 { hinfoMulti :: Bool -- ^ Whether this is part of a many or some (approximately) 397 , hinfoUnreachableArgs :: Bool -- ^ If the result is a positional, if it can't be 398 -- accessed in the current parser position ( first arg ) 399 } deriving (Eq, Show) 400 401-- | This type encapsulates whether an 'AltNode' of an 'OptTree' should be displayed 402-- with brackets around it. 403data AltNodeType = MarkDefault | NoDefault 404 deriving (Show, Eq) 405 406data OptTree a 407 = Leaf a 408 | MultNode [OptTree a] 409 | AltNode AltNodeType [OptTree a] 410 deriving Show 411 412filterOptional :: OptTree a -> OptTree a 413filterOptional t = case t of 414 Leaf a 415 -> Leaf a 416 MultNode xs 417 -> MultNode (map filterOptional xs) 418 AltNode MarkDefault _ 419 -> AltNode MarkDefault [] 420 AltNode NoDefault xs 421 -> AltNode NoDefault (map filterOptional xs) 422 423optVisibility :: Option a -> OptVisibility 424optVisibility = propVisibility . optProps 425 426optHelp :: Option a -> Chunk Doc 427optHelp = propHelp . optProps 428 429optMetaVar :: Option a -> String 430optMetaVar = propMetaVar . optProps 431 432optShowDefault :: Option a -> Maybe String 433optShowDefault = propShowDefault . optProps 434 435optDescMod :: Option a -> Maybe ( Doc -> Doc ) 436optDescMod = propDescMod . optProps 437