1 -----------------------------------------------------------------------------
5 -- This is an abstract command-line parser used by both StaticFlags and
8 -- (c) The University of Glasgow 2005
10 -----------------------------------------------------------------------------
12 module CmdLineParser (
13 processArgs, OptKind(..),
14 CmdLineP(..), getCmdLineState, putCmdLineState
17 #include "HsVersions.h"
19 import Util ( maybePrefixMatch, notNull, removeSpaces )
21 import Panic ( assertPanic )
25 = NoArg (m ()) -- flag with no argument
26 | HasArg (String -> m ()) -- flag has an argument (maybe prefix)
27 | SepArg (String -> m ()) -- flag has a separate argument
28 | Prefix (String -> m ()) -- flag is a prefix only
29 | OptPrefix (String -> m ()) -- flag may be a prefix
30 | AnySuffix (String -> m ()) -- flag is a prefix, pass whole arg to fn
31 | PassFlag (String -> m ()) -- flag with no arg, pass flag to fn
32 | PrefixPred (String -> Bool) (String -> m ())
33 | AnySuffixPred (String -> Bool) (String -> m ())
35 processArgs :: Monad m
36 => [(String, OptKind m)] -- cmdline parser spec
39 [String], -- spare args
42 processArgs spec args = process spec args [] []
44 process _spec [] spare errs =
45 return (reverse spare, reverse errs)
47 process spec args@(('-':arg):args') spare errs =
48 case findArg spec arg of
50 case processOneArg action rest args of
51 Left err -> process spec args' spare (err:errs)
52 Right (action,rest) -> do
53 action >> process spec rest spare errs
55 process spec args' (('-':arg):spare) errs
57 process spec (arg:args) spare errs =
58 process spec args (arg:spare) errs
61 processOneArg :: OptKind m -> String -> [String]
62 -> Either String (m (), [String])
63 processOneArg action rest (dash_arg@('-':arg):args) =
65 NoArg a -> ASSERT(null rest) Right (a, args)
69 then Right (f rest, args)
71 [] -> missingArgErr dash_arg
72 (arg1:args1) -> Right (f arg1, args1)
76 [] -> unknownFlagErr dash_arg
77 (arg1:args1) -> Right (f arg1, args1)
81 then Right (f rest, args)
82 else unknownFlagErr dash_arg
86 then Right (f rest, args)
87 else unknownFlagErr dash_arg
89 OptPrefix f -> Right (f rest, args)
91 AnySuffix f -> Right (f dash_arg, args)
93 AnySuffixPred p f -> Right (f dash_arg, args)
97 then unknownFlagErr dash_arg
98 else Right (f dash_arg, args)
101 findArg :: [(String,OptKind a)] -> String -> Maybe (String,OptKind a)
103 = case [ (removeSpaces rest, k)
105 Just rest <- [maybePrefixMatch pat arg],
111 arg_ok (NoArg _) rest arg = null rest
112 arg_ok (HasArg _) rest arg = True
113 arg_ok (SepArg _) rest arg = null rest
114 arg_ok (Prefix _) rest arg = notNull rest
115 arg_ok (PrefixPred p _) rest arg = notNull rest && p rest
116 arg_ok (OptPrefix _) rest arg = True
117 arg_ok (PassFlag _) rest arg = null rest
118 arg_ok (AnySuffix _) rest arg = True
119 arg_ok (AnySuffixPred p _) rest arg = p arg
121 unknownFlagErr :: String -> Either String a
122 unknownFlagErr f = Left ("unrecognised flag: " ++ f)
124 missingArgErr :: String -> Either String a
125 missingArgErr f = Left ("missing argument for flag: " ++ f)
127 -- -----------------------------------------------------------------------------
128 -- A state monad for use in the command-line parser
130 newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) }
132 instance Monad (CmdLineP s) where
133 return a = CmdLineP $ \s -> (a, s)
134 m >>= k = CmdLineP $ \s -> let
135 (a, s') = runCmdLine m s
136 in runCmdLine (k a) s'
138 getCmdLineState = CmdLineP $ \s -> (s,s)
139 putCmdLineState s = CmdLineP $ \_ -> ((),s)