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 ArgumentReachability(..), 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 (Maybe String) 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 , prefHelpShowGlobal :: Bool -- ^ when displaying subparsers' usage help, 127 -- show parent options under a "global options" 128 -- section (default: True) 129 } deriving (Eq, Show) 130 131data OptName = OptShort !Char 132 | OptLong !String 133 deriving (Eq, Ord, Show) 134 135isShortName :: OptName -> Bool 136isShortName (OptShort _) = True 137isShortName (OptLong _) = False 138 139isLongName :: OptName -> Bool 140isLongName = not . isShortName 141 142-- | Visibility of an option in the help text. 143data OptVisibility 144 = Internal -- ^ does not appear in the help text at all 145 | Hidden -- ^ only visible in the full description 146 | Visible -- ^ visible both in the full and brief descriptions 147 deriving (Eq, Ord, Show) 148 149-- | Specification for an individual parser option. 150data OptProperties = OptProperties 151 { propVisibility :: OptVisibility -- ^ whether this flag is shown in the brief description 152 , propHelp :: Chunk Doc -- ^ help text for this option 153 , propMetaVar :: String -- ^ metavariable for this option 154 , propShowDefault :: Maybe String -- ^ what to show in the help text as the default 155 , propShowGlobal :: Bool -- ^ whether the option is presented in global options text 156 , propDescMod :: Maybe ( Doc -> Doc ) -- ^ a function to run over the brief description 157 } 158 159instance Show OptProperties where 160 showsPrec p (OptProperties pV pH pMV pSD pSG _) 161 = showParen (p >= 11) 162 $ showString "OptProperties { propVisibility = " . shows pV 163 . showString ", propHelp = " . shows pH 164 . showString ", propMetaVar = " . shows pMV 165 . showString ", propShowDefault = " . shows pSD 166 . showString ", propShowGlobal = " . shows pSG 167 . showString ", propDescMod = _ }" 168 169-- | A single option of a parser. 170data Option a = Option 171 { optMain :: OptReader a -- ^ reader for this option 172 , optProps :: OptProperties -- ^ properties of this option 173 } 174 175data SomeParser = forall a . SomeParser (Parser a) 176 177-- | Subparser context, containing the 'name' of the subparser and its parser info. 178-- Used by parserFailure to display relevant usage information when parsing inside a subparser fails. 179data Context = forall a. Context String (ParserInfo a) 180 181instance Show (Option a) where 182 show opt = "Option {optProps = " ++ show (optProps opt) ++ "}" 183 184instance Functor Option where 185 fmap f (Option m p) = Option (fmap f m) p 186 187-- | A newtype over 'ReaderT String Except', used by option readers. 188newtype ReadM a = ReadM 189 { unReadM :: ReaderT String (Except ParseError) a } 190 191instance Functor ReadM where 192 fmap f (ReadM r) = ReadM (fmap f r) 193 194instance Applicative ReadM where 195 pure = ReadM . pure 196 ReadM x <*> ReadM y = ReadM $ x <*> y 197 198instance Alternative ReadM where 199 empty = mzero 200 (<|>) = mplus 201 202instance Monad ReadM where 203 return = pure 204 ReadM r >>= f = ReadM $ r >>= unReadM . f 205 206#if !(MIN_VERSION_base(4,13,0)) 207 fail = Fail.fail 208#endif 209 210instance Fail.MonadFail ReadM where 211 fail = readerError 212 213instance MonadPlus ReadM where 214 mzero = ReadM mzero 215 mplus (ReadM x) (ReadM y) = ReadM $ mplus x y 216 217-- | Return the value being read. 218readerAsk :: ReadM String 219readerAsk = ReadM ask 220 221-- | Abort option reader by exiting with a 'ParseError'. 222readerAbort :: ParseError -> ReadM a 223readerAbort = ReadM . lift . throwE 224 225-- | Abort option reader by exiting with an error message. 226readerError :: String -> ReadM a 227readerError = readerAbort . ErrorMsg 228 229data CReader a = CReader 230 { crCompleter :: Completer 231 , crReader :: ReadM a } 232 233instance Functor CReader where 234 fmap f (CReader c r) = CReader c (fmap f r) 235 236-- | An 'OptReader' defines whether an option matches an command line argument. 237data OptReader a 238 = OptReader [OptName] (CReader a) (String -> ParseError) 239 -- ^ option reader 240 | FlagReader [OptName] !a 241 -- ^ flag reader 242 | ArgReader (CReader a) 243 -- ^ argument reader 244 | CmdReader (Maybe String) [String] (String -> Maybe (ParserInfo a)) 245 -- ^ command reader 246 247instance Functor OptReader where 248 fmap f (OptReader ns cr e) = OptReader ns (fmap f cr) e 249 fmap f (FlagReader ns x) = FlagReader ns (f x) 250 fmap f (ArgReader cr) = ArgReader (fmap f cr) 251 fmap f (CmdReader n cs g) = CmdReader n cs ((fmap . fmap) f . g) 252 253-- | A @Parser a@ is an option parser returning a value of type 'a'. 254data Parser a 255 = NilP (Maybe a) 256 | OptP (Option a) 257 | forall x . MultP (Parser (x -> a)) (Parser x) 258 | AltP (Parser a) (Parser a) 259 | forall x . BindP (Parser x) (x -> Parser a) 260 261instance Functor Parser where 262 fmap f (NilP x) = NilP (fmap f x) 263 fmap f (OptP opt) = OptP (fmap f opt) 264 fmap f (MultP p1 p2) = MultP (fmap (f.) p1) p2 265 fmap f (AltP p1 p2) = AltP (fmap f p1) (fmap f p2) 266 fmap f (BindP p k) = BindP p (fmap f . k) 267 268instance Applicative Parser where 269 pure = NilP . Just 270 (<*>) = MultP 271 272newtype ParserM r = ParserM 273 { runParserM :: forall x . (r -> Parser x) -> Parser x } 274 275instance Monad ParserM where 276 return = pure 277 ParserM f >>= g = ParserM $ \k -> f (\x -> runParserM (g x) k) 278 279instance Functor ParserM where 280 fmap = liftM 281 282instance Applicative ParserM where 283 pure x = ParserM $ \k -> k x 284 (<*>) = ap 285 286fromM :: ParserM a -> Parser a 287fromM (ParserM f) = f pure 288 289oneM :: Parser a -> ParserM a 290oneM p = ParserM (BindP p) 291 292manyM :: Parser a -> ParserM [a] 293manyM p = do 294 mx <- oneM (optional p) 295 case mx of 296 Nothing -> return [] 297 Just x -> (x:) <$> manyM p 298 299someM :: Parser a -> ParserM [a] 300someM p = (:) <$> oneM p <*> manyM p 301 302instance Alternative Parser where 303 empty = NilP Nothing 304 (<|>) = AltP 305 many = fromM . manyM 306 some = fromM . someM 307 308-- | A shell complete function. 309newtype Completer = Completer 310 { runCompleter :: String -> IO [String] } 311 312-- | Smart constructor for a 'Completer' 313mkCompleter :: (String -> IO [String]) -> Completer 314mkCompleter = Completer 315 316instance Semigroup Completer where 317 (Completer c1) <> (Completer c2) = 318 Completer $ \s -> (++) <$> c1 s <*> c2 s 319 320instance Monoid Completer where 321 mempty = Completer $ \_ -> return [] 322 mappend = (<>) 323 324newtype CompletionResult = CompletionResult 325 { execCompletion :: String -> IO String } 326 327instance Show CompletionResult where 328 showsPrec p _ = showParen (p > 10) $ 329 showString "CompletionResult _" 330 331newtype ParserFailure h = ParserFailure 332 { execFailure :: String -> (h, ExitCode, Int) } 333 334instance Show h => Show (ParserFailure h) where 335 showsPrec p (ParserFailure f) 336 = showParen (p > 10) 337 $ showString "ParserFailure" 338 . showsPrec 11 (f "<program>") 339 340instance Functor ParserFailure where 341 fmap f (ParserFailure err) = ParserFailure $ \progn -> 342 let (h, exit, cols) = err progn in (f h, exit, cols) 343 344-- | Result of 'execParserPure'. 345data ParserResult a 346 = Success a 347 | Failure (ParserFailure ParserHelp) 348 | CompletionInvoked CompletionResult 349 deriving Show 350 351instance Functor ParserResult where 352 fmap f (Success a) = Success (f a) 353 fmap _ (Failure f) = Failure f 354 fmap _ (CompletionInvoked c) = CompletionInvoked c 355 356overFailure :: (ParserHelp -> ParserHelp) 357 -> ParserResult a -> ParserResult a 358overFailure f (Failure failure) = Failure $ fmap f failure 359overFailure _ r = r 360 361instance Applicative ParserResult where 362 pure = Success 363 Success f <*> r = fmap f r 364 Failure f <*> _ = Failure f 365 CompletionInvoked c <*> _ = CompletionInvoked c 366 367instance Monad ParserResult where 368 return = pure 369 Success x >>= f = f x 370 Failure f >>= _ = Failure f 371 CompletionInvoked c >>= _ = CompletionInvoked c 372 373type Args = [String] 374 375-- | Policy for how to handle options within the parse 376data ArgPolicy 377 = Intersperse 378 -- ^ The default policy, options and arguments can 379 -- be interspersed. 380 -- A `--` option can be passed to ensure all following 381 -- commands are treated as arguments. 382 | NoIntersperse 383 -- ^ Options must all come before arguments, once a 384 -- single positional argument or subcommand is parsed, 385 -- all remaining arguments are treated as positionals. 386 -- A `--` option can be passed if the first positional 387 -- one needs starts with `-`. 388 | AllPositionals 389 -- ^ No options are parsed at all, all arguments are 390 -- treated as positionals. 391 -- Is the policy used after `--` is encountered. 392 | ForwardOptions 393 -- ^ Options and arguments can be interspersed, but if 394 -- a given option is not found, it is treated as a 395 -- positional argument. This is sometimes useful if 396 -- one is passing through most options to another tool, 397 -- but are supplying just a few of their own options. 398 deriving (Eq, Ord, Show) 399 400newtype ArgumentReachability = ArgumentReachability 401 { argumentIsUnreachable :: Bool -- ^ If the result is a positional, if it can't be 402 -- accessed in the current parser position ( first arg ) 403 } deriving (Eq, Show) 404 405-- | This type encapsulates whether an 'AltNode' of an 'OptTree' should be displayed 406-- with brackets around it. 407data AltNodeType = MarkDefault | NoDefault 408 deriving (Show, Eq) 409 410data OptTree a 411 = Leaf a 412 | MultNode [OptTree a] 413 | AltNode AltNodeType [OptTree a] 414 | BindNode (OptTree a) 415 deriving Show 416 417filterOptional :: OptTree a -> OptTree a 418filterOptional t = case t of 419 Leaf a 420 -> Leaf a 421 MultNode xs 422 -> MultNode (map filterOptional xs) 423 AltNode MarkDefault _ 424 -> AltNode MarkDefault [] 425 AltNode NoDefault xs 426 -> AltNode NoDefault (map filterOptional xs) 427 BindNode xs 428 -> BindNode (filterOptional xs) 429 430optVisibility :: Option a -> OptVisibility 431optVisibility = propVisibility . optProps 432 433optHelp :: Option a -> Chunk Doc 434optHelp = propHelp . optProps 435 436optMetaVar :: Option a -> String 437optMetaVar = propMetaVar . optProps 438 439optShowDefault :: Option a -> Maybe String 440optShowDefault = propShowDefault . optProps 441 442optDescMod :: Option a -> Maybe ( Doc -> Doc ) 443optDescMod = propDescMod . optProps 444