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,
15 Flag(..), Deprecated(..),
19 #include "HsVersions.h"
28 flagName :: String, -- flag, without the leading -
29 flagOptKind :: (OptKind m), -- what to do if we see it
30 flagDeprecated :: Deprecated -- is the flag deprecated?
33 data Deprecated = Supported | Deprecated String
35 data OptKind m -- Suppose the flag is -f
36 = NoArg (m ()) -- -f all by itself
37 | HasArg (String -> m ()) -- -farg or -f arg
38 | SepArg (String -> m ()) -- -f arg
39 | Prefix (String -> m ()) -- -farg
40 | OptPrefix (String -> m ()) -- -f or -farg (i.e. the arg is optional)
41 | OptIntSuffix (Maybe Int -> m ()) -- -f or -f=n; pass n to fn
42 | IntSuffix (Int -> m ()) -- -f or -f=n; pass n to fn
43 | PassFlag (String -> m ()) -- -f; pass "-f" fn
44 | AnySuffix (String -> m ()) -- -f or -farg; pass entire "-farg" to fn
45 | PrefixPred (String -> Bool) (String -> m ())
46 | AnySuffixPred (String -> Bool) (String -> m ())
48 processArgs :: Monad m
49 => [Flag m] -- cmdline parser spec
50 -> [Located String] -- args
52 [Located String], -- spare args
53 [Located String], -- errors
54 [Located String] -- warnings
56 processArgs spec args = process spec args [] [] []
58 process _spec [] spare errs warns =
59 return (reverse spare, reverse errs, reverse warns)
61 process spec (locArg@(L loc dash_arg@('-' : arg)) : args) spare errs warns =
62 case findArg spec arg of
63 Just (rest, action, deprecated) ->
64 let warns' = case deprecated of
66 L loc ("Warning: " ++ dash_arg ++ " is deprecated: " ++ warning) : warns
68 in case processOneArg action rest arg args of
69 Left err -> process spec args spare (L loc err : errs) warns'
70 Right (action,rest) -> do action
71 process spec rest spare errs warns'
72 Nothing -> process spec args (locArg : spare) errs warns
74 process spec (arg : args) spare errs warns =
75 process spec args (arg : spare) errs warns
78 processOneArg :: OptKind m -> String -> String -> [Located String]
79 -> Either String (m (), [Located String])
80 processOneArg action rest arg args
81 = let dash_arg = '-' : arg
82 rest_no_eq = dropEq rest
84 NoArg a -> ASSERT(null rest) Right (a, args)
86 HasArg f | notNull rest_no_eq -> Right (f rest_no_eq, args)
87 | otherwise -> case args of
88 [] -> missingArgErr dash_arg
89 (L _ arg1:args1) -> Right (f arg1, args1)
91 SepArg f -> case args of
92 [] -> unknownFlagErr dash_arg
93 (L _ arg1:args1) -> Right (f arg1, args1)
95 Prefix f | notNull rest_no_eq -> Right (f rest_no_eq, args)
96 | otherwise -> unknownFlagErr dash_arg
98 PrefixPred _ f | notNull rest_no_eq -> Right (f rest_no_eq, args)
99 | otherwise -> unknownFlagErr dash_arg
101 PassFlag f | notNull rest -> unknownFlagErr dash_arg
102 | otherwise -> Right (f dash_arg, args)
104 OptIntSuffix f | null rest -> Right (f Nothing, args)
105 | Just n <- parseInt rest_no_eq -> Right (f (Just n), args)
106 | otherwise -> Left ("malformed integer argument in " ++ dash_arg)
108 IntSuffix f | Just n <- parseInt rest_no_eq -> Right (f n, args)
109 | otherwise -> Left ("malformed integer argument in " ++ dash_arg)
111 OptPrefix f -> Right (f rest_no_eq, args)
112 AnySuffix f -> Right (f dash_arg, args)
113 AnySuffixPred _ f -> Right (f dash_arg, args)
116 findArg :: [Flag m] -> String -> Maybe (String, OptKind m, Deprecated)
118 = case [ (removeSpaces rest, optKind, flagDeprecated flag)
120 let optKind = flagOptKind flag,
121 Just rest <- [maybePrefixMatch (flagName flag) arg],
122 arg_ok optKind rest arg ]
127 arg_ok :: OptKind t -> [Char] -> String -> Bool
128 arg_ok (NoArg _) rest _ = null rest
129 arg_ok (HasArg _) _ _ = True
130 arg_ok (SepArg _) rest _ = null rest
131 arg_ok (Prefix _) rest _ = notNull rest
132 arg_ok (PrefixPred p _) rest _ = notNull rest && p (dropEq rest)
133 arg_ok (OptIntSuffix _) _ _ = True
134 arg_ok (IntSuffix _) _ _ = True
135 arg_ok (OptPrefix _) _ _ = True
136 arg_ok (PassFlag _) rest _ = null rest
137 arg_ok (AnySuffix _) _ _ = True
138 arg_ok (AnySuffixPred p _) _ arg = p arg
140 parseInt :: String -> Maybe Int
141 -- Looks for "433" or "=342", with no trailing gubbins
143 -- gibberish => Nothing
144 parseInt s = case reads s of
148 dropEq :: String -> String
149 -- Discards a leading equals sign
153 unknownFlagErr :: String -> Either String a
154 unknownFlagErr f = Left ("unrecognised flag: " ++ f)
156 missingArgErr :: String -> Either String a
157 missingArgErr f = Left ("missing argument for flag: " ++ f)
159 -- -----------------------------------------------------------------------------
160 -- A state monad for use in the command-line parser
162 newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) }
164 instance Monad (CmdLineP s) where
165 return a = CmdLineP $ \s -> (a, s)
166 m >>= k = CmdLineP $ \s -> let
167 (a, s') = runCmdLine m s
168 in runCmdLine (k a) s'
170 getCmdLineState :: CmdLineP s s
171 getCmdLineState = CmdLineP $ \s -> (s,s)
172 putCmdLineState :: s -> CmdLineP s ()
173 putCmdLineState s = CmdLineP $ \_ -> ((),s)
175 -- ---------------------------------------------------------------------
178 errorsToGhcException :: [Located String] -> GhcException
179 errorsToGhcException errs =
180 let errors = vcat [ ppr l <> text ": " <> text e | L l e <- errs ]
181 in UsageError (showSDoc errors)