OptParse.curry 14.7 KB
Newer Older
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26
module OptParse 
  ( Arg
  , Parser
  , ParseSpec
  , ArgProps
  , OptProps
  , Mod
  , long
  , short
  , optional
  , metavar
  , help
  , (<>)
  , (<.>)
  , (<|>)
  , option
  , arg
  , rest
  , flag
  , command
  , commands
  , optParser
  , printUsage
  , renderUsage
  , parse
  ) where
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
27 28 29 30 31 32 33 34

import Debug
import Char (isAscii)
import List (intercalate)
import qualified DetParse as P
import Pretty
import qualified Boxes as B

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
35 36 37 38 39
--- A command line argument. Used to represent a parsed command line.
--- 
--- @cons Flag - a flag, e.g. `-d` or `--enable-debug`
--- @cons Val - a simple value
--- @cons FlagWithValue - an option, e.g. `-v debug` or `--verbosity=debug`
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
40 41 42 43
data Arg = Flag String
         | Val  String
         | FlagWithValue String String

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
44 45 46 47 48 49 50
--- A partial command line parser. 
---
--- @cons OptP - parses an option with a value
--- @cons FlagP - parses a flag
--- @cons ArgP - parses a positional argument
--- @cons RestP - a parses that consumes the rest
--- @cons CmdP - a parser that branches out to command sub-parsers
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
51 52 53
data Parser a = OptP ArgProps OptProps (String -> a)
              | FlagP ArgProps OptProps a
              | ArgP ArgProps (String -> a)
54
              | RestP ArgProps (String -> a)
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
55 56
              | CmdP ArgProps [(String, ArgProps, a, ParseSpec a)]

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
57
--- A parser specification. A collection of parsers.
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
58 59
data ParseSpec a = ParseSpec [Parser a]

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
60
--- Properties that for all parser types.
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
61 62 63 64 65
data ArgProps = ArgProps
  { metavarName :: String
  , helpText :: Maybe String 
  , argOptional :: Bool }

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
66
--- Properties for option/flag parsers.
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
67 68 69 70
data OptProps = OptProps
  { longName :: String
  , shortName :: String }

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
71
--- Modifiers for argument and option properties.
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
72 73 74 75
data Mod = Mod 
  { optMod :: OptProps -> OptProps
  , argMod :: ArgProps -> ArgProps }

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
76
--- Get argument properties from a parser.
77 78 79 80 81 82 83
argProps :: Parser a -> ArgProps
argProps (OptP a _ _) = a
argProps (FlagP a _ _) = a
argProps (ArgP a _) = a
argProps (RestP a _) = a
argProps (CmdP a _) = a

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
84
--- Default argument properties.
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
85 86 87
defaultArgProps :: ArgProps
defaultArgProps = ArgProps "" Nothing False

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
88
--- Default option properties.
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
89 90 91
defaultOptProps :: OptProps
defaultOptProps = OptProps "" ""

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
92 93 94 95 96
--- Identity modifiers.
idm :: Mod
idm = Mod id id

--- Set the long name of an option.
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
97 98 99
long :: String -> Mod
long s = Mod (\o -> o { longName = s }) id

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
100
--- Set the short name of an option.
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
101 102 103
short :: String -> Mod
short s = Mod (\o -> o { shortName = s }) id

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
104
--- Set the optional flag of an argument.
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
105 106 107
optional :: Mod
optional = Mod id (\a -> a { argOptional = True })

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
108 109
--- Set the metavar of an argument. The metavar is used to print usage 
--- information.
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
110 111 112
metavar :: String -> Mod
metavar s = Mod id (\a -> a { metavarName = s })

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
113
--- Set the help text of an argument. Used to print usage information.
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
114 115 116
help :: String -> Mod
help s = Mod id (\a -> a { helpText = Just s })

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
117
--- Combine two modifiers.
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
118 119 120
(<>) :: Mod -> Mod -> Mod
(Mod o1 a1) <> (Mod o2 a2) = Mod (o2 . o1) (a2 . a1)

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
121 122 123 124 125 126 127 128 129 130 131
--- Create an option.
---
--- @param f function that converts the parsed value into a parse result
--- @param m modifiers for this argument
option :: (String -> a) -> Mod -> [Parser a]
option f (Mod o a) = [OptP (a defaultArgProps) (o defaultOptProps) f]

--- Create a positional argument.
---
--- @param f function that converts the parsed value into a parse result
--- @param m modifiers for this argument
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
132 133 134
arg :: (String -> a) -> Mod -> [Parser a]
arg f (Mod _ a) = [ArgP (a defaultArgProps) f]

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
135 136 137 138
--- Create an argument that consumes the rest of the command line.
  ---
--- @param f function that converts the parsed value into a parse result
--- @param m modifiers for this argument
139 140 141
rest :: (String -> a) -> Mod -> [Parser a]
rest f (Mod _ a) = [RestP (a defaultArgProps) f]

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
142 143 144 145
--- Create a flag.
---
--- @param a result of the parser
--- @param m modifiers for this argument
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
146 147 148
flag :: a -> Mod -> [Parser a]
flag f (Mod o a) = [FlagP (a defaultArgProps) (o defaultOptProps) f]

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
149 150 151 152
infixl 4 <.>
infixl 5 <|>

--- Combine two arguments.
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
153 154 155
(<.>) :: [a] -> [a] -> [a]
(<.>) = (++)

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
156
--- Combine command sub parsers.
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
157 158 159
(<|>) :: [a] -> [a] -> [a]
(<|>) = (++)

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
160 161 162 163 164 165
--- Create a sub-parser for a command. Must be used with `commands`.
--- 
--- @param n the name of the command
--- @param m modifiers for this command
--- @param a the result of this parse
--- @param ps parsers for the rest of the command line for this command
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
166 167 168
command :: String -> Mod -> a -> [Parser a] -> [(String, ArgProps, a, ParseSpec a)]
command n (Mod _ a) d ps = [(n, a defaultArgProps, d, ParseSpec ps)]

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
169 170 171
--- Create a parse spec from a list of parsers.
optParser :: [Parser a] -> ParseSpec a
optParser = ParseSpec
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
172

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
173 174 175 176
--- Create a command parser.
---
--- @param m modifiers for this command
--- @param cs command sub-parsers, created by `command`
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
177 178 179
commands :: Mod -> [(String, ArgProps, a, ParseSpec a)] -> [Parser a]
commands (Mod _ a) cmds = [CmdP (a defaultArgProps) cmds]

180 181 182
margin :: Int
margin = 5

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
183 184 185 186 187
--- Print usage information for a command line parser specification.
--- 
--- @param p the name of the current program
--- @param c the maximum number of columns to use
--- @param p the parser specification
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
188 189 190
printUsage :: String -> Int -> ParseSpec a -> IO ()
printUsage prog w spec = B.printBox $ usageBox prog w spec

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
191 192 193 194 195
--- Render usage information to a string.
---
--- @param p the name of the current program
--- @param c the maximum number of columns to use
--- @param p the parser specification
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
196 197 198
renderUsage :: String -> Int -> ParseSpec a -> String
renderUsage prog w spec = B.render $ usageBox prog w spec

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
199 200 201 202 203
--- Create a box for usage information.
---
--- @param p the name of the current program
--- @param c the maximum number of columns to use
--- @param p the parser specification
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
204 205 206 207 208 209
usageBox :: String -> Int -> ParseSpec a -> B.Box
usageBox prog w (ParseSpec ps) = usageLine B./+/ optBox B./+/ argBox B./+/ cmdsBox
 where
  opts = filter isOpt ps
  args = filter isArg ps
  cmds = filter isCmd ps
210 211
  formattedArgs = map formatArgForUsage $ filter (not . isOpt) ps
  usageLine = B.text prog B.<+> (B.text $ intercalate " " $ formattedArgs)
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
212
  maxOptLen = foldl max 0 $ map optLen opts
213 214
  optBox = B.table (map optRow opts) [
    maxOptLen + margin, w - maxOptLen - margin]
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
215
  maxArgLen = foldl max 0 $ map posnLen args
216 217
  argBox = B.table (map argRow args) [
    maxArgLen + margin, w - maxArgLen - margin]
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
218 219 220
  maxCmdsLen = foldl max 0 $ map cmdsLen cmds
  cmdsBox = B.vcat B.left $ (map (cmdsRows maxCmdsLen w) cmds) 

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
221
--- Render an argument for the usage line.
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
222
formatArgForUsage :: Parser a -> String
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
223
formatArgForUsage p = wrap $ argMetavar p
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
224 225 226
 where
  wrap s = if isOptional p then "[" ++ s ++ "]" else s

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
227
--- Render detailed help for an option/flag.
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
228
optRow :: Parser a -> [String]
229
optRow (OptP a o _) = [sh ++ " " ++ lo ++ " " ++ metavarName a, hlp]
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
230
 where 
231 232 233
  sh = "-" ++ (shortName o) ++ (if longName o /= "" then "," else "")
  lo = "--" ++ (longName o)
  hlp = case helpText a of 
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
234 235
    Nothing -> ""
    Just h  -> h
236
optRow (FlagP a o _) = [sh ++ " " ++ lo ++ " " ++ metavarName a, hlp]
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
237
 where 
238 239 240
  sh = "-" ++ (shortName o) ++ (if longName o /= "" then "," else "")
  lo = "--" ++ (longName o)
  hlp = case helpText a of 
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
241 242
    Nothing -> ""
    Just h  -> h
243 244 245
optRow (ArgP _ _)  = error "OptParse.optRow: called on ArgP"
optRow (RestP _ _) = error "OptParse.optRow: called on RestP"
optRow (CmdP _ _)  = error "OptParse.optRow: called on CmdP"
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
246

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
247
--- Render detailed help for a positional argument.
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
248
argRow :: Parser a -> [String]
249
argRow (ArgP a _) = [metavarName a, hlp]
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
250
 where
251
  hlp = case helpText a of
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
252 253
    Nothing -> ""
    Just  h -> h 
254
argRow (RestP a _) = [metavarName a, hlp]
255
 where
256
  hlp = case helpText a of
257 258
    Nothing -> ""
    Just  h -> h 
259 260 261
argRow (OptP _ _ _)  = error "OptParse.argRow: called on OptP"
argRow (FlagP _ _ _) = error "OptParse.argRow: called on FlagP"
argRow (CmdP _ _)    = error "OptParse.argRow: called on CmdP"
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
262

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
263
--- Render detailed help for a command parser.
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
264
cmdsRows :: Int -> Int -> Parser a -> B.Box
265
cmdsRows max w (CmdP a cmds) = hdr B.// tbl
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
266
 where
267 268 269 270
  hdr = B.text $ "Options for " ++ (metavarName a)
  tbl = B.table (map cmdRow cmds) [max + margin, w - max - margin]
  cmdRow (n, x, _, _) = [n, getHelp x]
  getHelp x = case helpText x of
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
271 272
    Nothing -> ""
    Just  h -> h
273 274 275 276
cmdsRows _ _ (OptP _ _ _)  = error "OptParse.cmdsRows: called on OptP"
cmdsRows _ _ (FlagP _ _ _) = error "OptParse.cmdsRows: called on FlagP"
cmdsRows _ _ (ArgP _ _)    = error "OptParse.cmdsRows: called on ArgP"
cmdsRows _ _ (RestP _ _)   = error "OptParse.cmdsRows: called on RestP"
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
277

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
278
--- Calculate maximum command length for a command parser.
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
279
cmdsLen :: Parser a -> Int
280
cmdsLen (CmdP _ cmds) = foldl max 0 $ map cmdsLen' cmds
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
281 282
 where
  cmdsLen' (n, _, _, _) = length n
283 284
cmdsLen (ArgP _ _)    = 0
cmdsLen (OptP _ _ _)  = 0
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
285
cmdsLen (FlagP _ _ _) = 0
286
cmdsLen (RestP _ _)   = 0
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
287

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
288
--- Length of a positional argument name.
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
289
posnLen :: Parser a -> Int
290 291 292
posnLen (ArgP a _)    = length (metavarName a)
posnLen (CmdP _ _)    = 0
posnLen (OptP _ _ _)  = 0
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
293
posnLen (FlagP _ _ _) = 0
294
posnLen (RestP _ _)   = 0
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
295 296

optLen' :: ArgProps -> OptProps -> Int
297 298
optLen' a o = length (shortName o) + 2 + length (longName o) + 3 + 
  length (metavarName a) + 2
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
299

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
300
--- Length needed to represent a option/flag detailed help.
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
301
optLen :: Parser a -> Int
302
optLen (OptP a o _)  = optLen' a o
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
303
optLen (FlagP a o _) = optLen' a o
304 305 306
optLen (ArgP _ _)    = 0
optLen (CmdP _ _)    = 0
optLen (RestP _ _)   = 0 
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
307

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
308 309 310 311 312
--- Parses a command line via a parser spec.
--- 
--- @param l the command line
--- @param s the parser spec
--- @param p the name of the current program
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
313 314 315 316 317
parse :: String -> ParseSpec a -> String -> Either String [a]
parse argv spec prog = case P.parse pArgs argv of
  Nothing -> Left $ parseError prog spec "Couldn't parse command line!"
  Just as -> parseArgs as spec prog

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
318 319 320 321 322 323
--- Renders parsed parts of a command line back to a string.
renderCommandLine :: [Arg] -> String
renderCommandLine [] = []
renderCommandLine ((Val s):as) = s ++ " " ++ (renderCommandLine as)
renderCommandLine ((FlagWithValue n v):as) = 
  "--" ++ n ++ "=" ++ v ++ " " ++ (renderCommandLine as)
324
renderCommandLine ((Flag n):as) = "--" ++ n ++ " " ++ (renderCommandLine as)
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
325 326 327 328 329 330

--- Further parses a parsed command line using a parser spec.
--- 
--- @param as parsed command line
--- @param s parser spec
--- @param p name of the current program
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
331
parseArgs :: [Arg] -> ParseSpec a -> String -> Either String [a]
332
parseArgs args sp@(ParseSpec specs) prog = parse' args rst []
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
333 334
 where
  opts = filter isOpt specs
335
  rst = filter (not . isOpt) specs
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
336
  parse' ((Val s):as) (p:ps) xs = case p of
337
    ArgP _ f    -> parse' as ps ((f s):xs)
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
338
    RestP _ f   -> parse' [] (p:ps) ((f $ renderCommandLine ((Val s):as)):xs)
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
339 340 341 342 343
    CmdP _ cmds -> case findCommand s cmds of
      Nothing -> Left $ parseError prog sp $ "Unknown command '" ++ s ++ "'."
      Just (cmd, _, d, spec) -> case parseArgs as spec (prog ++ " " ++ cmd) of
        Left e -> Left e
        Right xs' -> Right $ xs ++ [d] ++ xs'
344
    OptP _ _ _  -> error "OptP in list of positional candidates"
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
345 346 347
    FlagP _ _ _ -> error "FlagP in list of positional candidates"
  parse' ((FlagWithValue n v):as) ps xs = case filter (optMatches n) opts of
    [] -> Left $ parseError prog sp $ "Unknown option '" ++ n ++ "'."
348 349 350 351 352
    ((OptP _ _ f):_)  -> parse' as ps ((f v):xs)
    ((ArgP _ _):_)    -> error $ "OptParse.parseArgs: ArgP matches opt " ++ n
    ((FlagP _ _ _):_) -> error $ "OptParse.parseArgs: FlagP matches opt " ++ n
    ((RestP _ _):_)   -> error $ "OptParse.parseArgs: RestP matches opt " ++ n
    ((CmdP _ _):_)    -> error $ "OptParse.parseArgs: CmdP matches opt " ++ n
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
353 354 355 356
  parse' ((Flag n):as) ps xs = if n == "h" || n == "help"
    then Left $ parseError prog sp ""
    else case filter (optMatches n) opts of
      [] -> Left $ parseError prog sp $ "Unknown option '" ++ n ++ "'."
357 358
      ((OptP _ _ f):_)  -> case as of
        ((Val v):as')   -> parse' as' ps ((f v):xs)
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
359 360
        _           -> Left $ parseError prog sp $ "Option '" ++ n ++ "' expects a value."
      ((FlagP _ _ f):_) -> parse' as ps (f:xs)
361 362 363 364
      ((ArgP _ _):_)    -> error $ "OptParse.parseArgs: ArgP matches flag " ++ n
      ((RestP _ _):_)   -> error $ "OptParse.parseArgs: RestP matches flag " ++ n
      ((CmdP _ _):_)    -> error $ "OptParse.parseArgs: CmdP matches flag " ++ n
  parse' ((Val _):as) []    xs = parse' as [] xs
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
365 366
  parse' []           (p:ps) xs = if isOptional p
    then parse' [] ps xs
367 368
    else Left $ parseError prog sp $ 
      "Expected " ++ (argMetavar p) ++ ", but there are no arguments left."
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
369 370
  parse' []           []    xs = Right xs

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
371 372 373 374 375
--- Renders a parse error.
--- 
--- @param p name of the current program
--- @param s parser spec
--- @param e error that occured
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
376 377 378
parseError :: String -> ParseSpec a -> String -> String
parseError prog spec err = renderUsage prog 80 spec ++ "\n" ++ err

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
379
--- Gets the metavar from a parser.
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
380
argMetavar :: Parser a -> String
381
argMetavar = metavarName . argProps
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
382

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
383
--- Does an option/flag match a name?
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
384
optMatches :: String -> Parser a -> Bool
385 386 387 388
optMatches _ (ArgP _ _)    = False
optMatches _ (CmdP _ _)    = False
optMatches _ (RestP _ _)   = False
optMatches n (OptP _ o _)  = n == (longName o) || n == (shortName o)
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
389 390
optMatches n (FlagP _ o _) = n == (longName o) || n == (shortName o)

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
391
--- Is the argument optional?
392 393
isOptional :: Parser a -> Bool
isOptional = argOptional . argProps
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
394

Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
395
--- Finds a command in a list of command specs.
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
396 397 398 399 400 401 402 403 404 405 406
findCommand :: String -> [(String, ArgProps, a, ParseSpec a)] -> Maybe (String, ArgProps, a, ParseSpec a)
findCommand s cmds = case cmd of
  [] -> Nothing
  (c:_) -> Just c
 where
  cmd = filter ((== s) . fst3) cmds
  fst3 (a, _, _, _) = a

isOpt :: Parser a -> Bool
isOpt (OptP _ _ _) = True
isOpt (ArgP _ _) = False
407
isOpt (RestP _ _) = False
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
408 409 410 411 412 413
isOpt (CmdP _ _) = False
isOpt (FlagP _ _ _) = True

isArg :: Parser a -> Bool
isArg (OptP _ _ _) = False
isArg (ArgP _ _) = True
414
isArg (RestP _ _) = True
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
415 416 417 418 419 420
isArg (CmdP _ _) = False
isArg (FlagP _ _ _) = False

isCmd :: Parser a -> Bool
isCmd (OptP _ _ _) = False
isCmd (ArgP _ _) = False
421
isCmd (RestP _ _) = False
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
422 423 424 425 426 427 428 429 430 431 432 433 434 435 436
isCmd (CmdP _ _) = True
isCmd (FlagP _ _ _) = False

pArgs :: P.Parser [Arg]
pArgs = (:) P.<$> pArg P.<*> (pWhitespace P.*> pArgs P.<|> P.yield [])

pWhitespace :: P.Parser Char
pWhitespace = P.check (== ' ') P.anyChar

pArg :: P.Parser Arg
pArg = Flag P.<$> pFlagNoValue
  P.<|> pFlagValue
  P.<|> Val P.<$> P.some pNonWhitespace

pFlagValue :: P.Parser Arg
437 438 439
pFlagValue = FlagWithValue 
  P.<$> (P.char '-' P.*> P.char '-' P.*> P.some pNonWhitespace) 
  P.<*> (P.char '=' P.*> P.some pNonWhitespace)
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
440 441

pFlagNoValue :: P.Parser String
442 443
pFlagNoValue = P.char '-' 
  P.*> ((P.char '-' P.*> P.some pNonWhiteEqual) P.<|> pAsciiNonWhitespace)
Jonas Oberschweiber's avatar
Jonas Oberschweiber committed
444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459

pNonWhiteEqual :: P.Parser Char
pNonWhiteEqual = P.check f P.anyChar
 where
  f c = c /= ' ' && c /= '='

pNonWhitespace :: P.Parser Char
pNonWhitespace = P.check (/= ' ') P.anyChar

pAsciiNonWhitespace :: P.Parser String
pAsciiNonWhitespace = (:[]) P.<$> P.check f P.anyChar
 where
  f c = isAscii c && c /= ' '

pAscii :: P.Parser Char
pAscii = P.check isAscii P.anyChar