Add dump flag for timing output
[ghc.git] / compiler / main / CmdLineParser.hs
1 {-# LANGUAGE CPP #-}
2
3 -------------------------------------------------------------------------------
4 --
5 -- | Command-line parser
6 --
7 -- This is an abstract command-line parser used by DynFlags.
8 --
9 -- (c) The University of Glasgow 2005
10 --
11 -------------------------------------------------------------------------------
12
13 module CmdLineParser
14 (
15 processArgs, OptKind(..), GhcFlagMode(..),
16 CmdLineP(..), getCmdLineState, putCmdLineState,
17 Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag,
18 errorsToGhcException,
19
20 Err(..), Warn(..), WarnReason(..),
21
22 EwM, runEwM, addErr, addWarn, addFlagWarn, getArg, getCurLoc, liftEwM,
23 deprecate
24 ) where
25
26 #include "HsVersions.h"
27
28 import GhcPrelude
29
30 import Util
31 import Outputable
32 import Panic
33 import Bag
34 import SrcLoc
35 import Json
36
37 import Data.Function
38 import Data.List
39
40 import Control.Monad (liftM, ap)
41
42 --------------------------------------------------------
43 -- The Flag and OptKind types
44 --------------------------------------------------------
45
46 data Flag m = Flag
47 { flagName :: String, -- Flag, without the leading "-"
48 flagOptKind :: OptKind m, -- What to do if we see it
49 flagGhcMode :: GhcFlagMode -- Which modes this flag affects
50 }
51
52 defFlag :: String -> OptKind m -> Flag m
53 defFlag name optKind = Flag name optKind AllModes
54
55 defGhcFlag :: String -> OptKind m -> Flag m
56 defGhcFlag name optKind = Flag name optKind OnlyGhc
57
58 defGhciFlag :: String -> OptKind m -> Flag m
59 defGhciFlag name optKind = Flag name optKind OnlyGhci
60
61 defHiddenFlag :: String -> OptKind m -> Flag m
62 defHiddenFlag name optKind = Flag name optKind HiddenFlag
63
64 -- | GHC flag modes describing when a flag has an effect.
65 data GhcFlagMode
66 = OnlyGhc -- ^ The flag only affects the non-interactive GHC
67 | OnlyGhci -- ^ The flag only affects the interactive GHC
68 | AllModes -- ^ The flag affects multiple ghc modes
69 | HiddenFlag -- ^ This flag should not be seen in cli completion
70
71 data OptKind m -- Suppose the flag is -f
72 = NoArg (EwM m ()) -- -f all by itself
73 | HasArg (String -> EwM m ()) -- -farg or -f arg
74 | SepArg (String -> EwM m ()) -- -f arg
75 | Prefix (String -> EwM m ()) -- -farg
76 | OptPrefix (String -> EwM m ()) -- -f or -farg (i.e. the arg is optional)
77 | OptIntSuffix (Maybe Int -> EwM m ()) -- -f or -f=n; pass n to fn
78 | IntSuffix (Int -> EwM m ()) -- -f or -f=n; pass n to fn
79 | FloatSuffix (Float -> EwM m ()) -- -f or -f=n; pass n to fn
80 | PassFlag (String -> EwM m ()) -- -f; pass "-f" fn
81 | AnySuffix (String -> EwM m ()) -- -f or -farg; pass entire "-farg" to fn
82 | PrefixPred (String -> Bool) (String -> EwM m ())
83 | AnySuffixPred (String -> Bool) (String -> EwM m ())
84
85
86 --------------------------------------------------------
87 -- The EwM monad
88 --------------------------------------------------------
89
90 -- | Used when filtering warnings: if a reason is given
91 -- it can be filtered out when displaying.
92 data WarnReason
93 = NoReason
94 | ReasonDeprecatedFlag
95 | ReasonUnrecognisedFlag
96 deriving (Eq, Show)
97
98 instance Outputable WarnReason where
99 ppr = text . show
100
101 instance ToJson WarnReason where
102 json NoReason = JSNull
103 json reason = JSString $ show reason
104
105 -- | A command-line error message
106 newtype Err = Err { errMsg :: Located String }
107
108 -- | A command-line warning message and the reason it arose
109 data Warn = Warn
110 { warnReason :: WarnReason,
111 warnMsg :: Located String
112 }
113
114 type Errs = Bag Err
115 type Warns = Bag Warn
116
117 -- EwM ("errors and warnings monad") is a monad
118 -- transformer for m that adds an (err, warn) state
119 newtype EwM m a = EwM { unEwM :: Located String -- Current parse arg
120 -> Errs -> Warns
121 -> m (Errs, Warns, a) }
122
123 instance Monad m => Functor (EwM m) where
124 fmap = liftM
125
126 instance Monad m => Applicative (EwM m) where
127 pure v = EwM (\_ e w -> return (e, w, v))
128 (<*>) = ap
129
130 instance Monad m => Monad (EwM m) where
131 (EwM f) >>= k = EwM (\l e w -> do (e', w', r) <- f l e w
132 unEwM (k r) l e' w')
133
134 runEwM :: EwM m a -> m (Errs, Warns, a)
135 runEwM action = unEwM action (panic "processArgs: no arg yet") emptyBag emptyBag
136
137 setArg :: Located String -> EwM m () -> EwM m ()
138 setArg l (EwM f) = EwM (\_ es ws -> f l es ws)
139
140 addErr :: Monad m => String -> EwM m ()
141 addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` Err (L loc e), ws, ()))
142
143 addWarn :: Monad m => String -> EwM m ()
144 addWarn = addFlagWarn NoReason
145
146 addFlagWarn :: Monad m => WarnReason -> String -> EwM m ()
147 addFlagWarn reason msg = EwM $
148 (\(L loc _) es ws -> return (es, ws `snocBag` Warn reason (L loc msg), ()))
149
150 deprecate :: Monad m => String -> EwM m ()
151 deprecate s = do
152 arg <- getArg
153 addFlagWarn ReasonDeprecatedFlag (arg ++ " is deprecated: " ++ s)
154
155 getArg :: Monad m => EwM m String
156 getArg = EwM (\(L _ arg) es ws -> return (es, ws, arg))
157
158 getCurLoc :: Monad m => EwM m SrcSpan
159 getCurLoc = EwM (\(L loc _) es ws -> return (es, ws, loc))
160
161 liftEwM :: Monad m => m a -> EwM m a
162 liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) })
163
164
165 --------------------------------------------------------
166 -- A state monad for use in the command-line parser
167 --------------------------------------------------------
168
169 -- (CmdLineP s) typically instantiates the 'm' in (EwM m) and (OptKind m)
170 newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) }
171
172 instance Functor (CmdLineP s) where
173 fmap = liftM
174
175 instance Applicative (CmdLineP s) where
176 pure a = CmdLineP $ \s -> (a, s)
177 (<*>) = ap
178
179 instance Monad (CmdLineP s) where
180 m >>= k = CmdLineP $ \s ->
181 let (a, s') = runCmdLine m s
182 in runCmdLine (k a) s'
183
184
185 getCmdLineState :: CmdLineP s s
186 getCmdLineState = CmdLineP $ \s -> (s,s)
187 putCmdLineState :: s -> CmdLineP s ()
188 putCmdLineState s = CmdLineP $ \_ -> ((),s)
189
190
191 --------------------------------------------------------
192 -- Processing arguments
193 --------------------------------------------------------
194
195 processArgs :: Monad m
196 => [Flag m] -- cmdline parser spec
197 -> [Located String] -- args
198 -> m ( [Located String], -- spare args
199 [Err], -- errors
200 [Warn] ) -- warnings
201 processArgs spec args = do
202 (errs, warns, spare) <- runEwM action
203 return (spare, bagToList errs, bagToList warns)
204 where
205 action = process args []
206
207 -- process :: [Located String] -> [Located String] -> EwM m [Located String]
208 process [] spare = return (reverse spare)
209
210 process (locArg@(L _ ('-' : arg)) : args) spare =
211 case findArg spec arg of
212 Just (rest, opt_kind) ->
213 case processOneArg opt_kind rest arg args of
214 Left err ->
215 let b = process args spare
216 in (setArg locArg $ addErr err) >> b
217
218 Right (action,rest) ->
219 let b = process rest spare
220 in (setArg locArg $ action) >> b
221
222 Nothing -> process args (locArg : spare)
223
224 process (arg : args) spare = process args (arg : spare)
225
226
227 processOneArg :: OptKind m -> String -> String -> [Located String]
228 -> Either String (EwM m (), [Located String])
229 processOneArg opt_kind rest arg args
230 = let dash_arg = '-' : arg
231 rest_no_eq = dropEq rest
232 in case opt_kind of
233 NoArg a -> ASSERT(null rest) Right (a, args)
234
235 HasArg f | notNull rest_no_eq -> Right (f rest_no_eq, args)
236 | otherwise -> case args of
237 [] -> missingArgErr dash_arg
238 (L _ arg1:args1) -> Right (f arg1, args1)
239
240 -- See Trac #9776
241 SepArg f -> case args of
242 [] -> missingArgErr dash_arg
243 (L _ arg1:args1) -> Right (f arg1, args1)
244
245 Prefix f | notNull rest_no_eq -> Right (f rest_no_eq, args)
246 | otherwise -> unknownFlagErr dash_arg
247
248 PrefixPred _ f | notNull rest_no_eq -> Right (f rest_no_eq, args)
249 | otherwise -> unknownFlagErr dash_arg
250
251 PassFlag f | notNull rest -> unknownFlagErr dash_arg
252 | otherwise -> Right (f dash_arg, args)
253
254 OptIntSuffix f | null rest -> Right (f Nothing, args)
255 | Just n <- parseInt rest_no_eq -> Right (f (Just n), args)
256 | otherwise -> Left ("malformed integer argument in " ++ dash_arg)
257
258 IntSuffix f | Just n <- parseInt rest_no_eq -> Right (f n, args)
259 | otherwise -> Left ("malformed integer argument in " ++ dash_arg)
260
261 FloatSuffix f | Just n <- parseFloat rest_no_eq -> Right (f n, args)
262 | otherwise -> Left ("malformed float argument in " ++ dash_arg)
263
264 OptPrefix f -> Right (f rest_no_eq, args)
265 AnySuffix f -> Right (f dash_arg, args)
266 AnySuffixPred _ f -> Right (f dash_arg, args)
267
268 findArg :: [Flag m] -> String -> Maybe (String, OptKind m)
269 findArg spec arg =
270 case sortBy (compare `on` (length . fst)) -- prefer longest matching flag
271 [ (removeSpaces rest, optKind)
272 | flag <- spec,
273 let optKind = flagOptKind flag,
274 Just rest <- [stripPrefix (flagName flag) arg],
275 arg_ok optKind rest arg ]
276 of
277 [] -> Nothing
278 (one:_) -> Just one
279
280 arg_ok :: OptKind t -> [Char] -> String -> Bool
281 arg_ok (NoArg _) rest _ = null rest
282 arg_ok (HasArg _) _ _ = True
283 arg_ok (SepArg _) rest _ = null rest
284 arg_ok (Prefix _) rest _ = notNull rest
285 arg_ok (PrefixPred p _) rest _ = notNull rest && p (dropEq rest)
286 arg_ok (OptIntSuffix _) _ _ = True
287 arg_ok (IntSuffix _) _ _ = True
288 arg_ok (FloatSuffix _) _ _ = True
289 arg_ok (OptPrefix _) _ _ = True
290 arg_ok (PassFlag _) rest _ = null rest
291 arg_ok (AnySuffix _) _ _ = True
292 arg_ok (AnySuffixPred p _) _ arg = p arg
293
294 -- | Parse an Int
295 --
296 -- Looks for "433" or "=342", with no trailing gubbins
297 -- * n or =n => Just n
298 -- * gibberish => Nothing
299 parseInt :: String -> Maybe Int
300 parseInt s = case reads s of
301 ((n,""):_) -> Just n
302 _ -> Nothing
303
304 parseFloat :: String -> Maybe Float
305 parseFloat s = case reads s of
306 ((n,""):_) -> Just n
307 _ -> Nothing
308
309 -- | Discards a leading equals sign
310 dropEq :: String -> String
311 dropEq ('=' : s) = s
312 dropEq s = s
313
314 unknownFlagErr :: String -> Either String a
315 unknownFlagErr f = Left ("unrecognised flag: " ++ f)
316
317 missingArgErr :: String -> Either String a
318 missingArgErr f = Left ("missing argument for flag: " ++ f)
319
320 --------------------------------------------------------
321 -- Utils
322 --------------------------------------------------------
323
324
325 -- See Note [Handling errors when parsing flags]
326 errorsToGhcException :: [(String, -- Location
327 String)] -- Error
328 -> GhcException
329 errorsToGhcException errs =
330 UsageError $ intercalate "\n" $ [ l ++ ": " ++ e | (l, e) <- errs ]
331
332 {- Note [Handling errors when parsing commandline flags]
333
334 Parsing of static and mode flags happens before any session is started, i.e.,
335 before the first call to 'GHC.withGhc'. Therefore, to report errors for
336 invalid usage of these two types of flags, we can not call any function that
337 needs DynFlags, as there are no DynFlags available yet (unsafeGlobalDynFlags
338 is not set either). So we always print "on the commandline" as the location,
339 which is true except for Api users, which is probably ok.
340
341 When reporting errors for invalid usage of dynamic flags we /can/ make use of
342 DynFlags, and we do so explicitly in DynFlags.parseDynamicFlagsFull.
343
344 Before, we called unsafeGlobalDynFlags when an invalid (combination of)
345 flag(s) was given on the commandline, resulting in panics (#9963).
346 -}