compiler: Write .o files atomically. See #14533
[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
83
84 --------------------------------------------------------
85 -- The EwM monad
86 --------------------------------------------------------
87
88 -- | Used when filtering warnings: if a reason is given
89 -- it can be filtered out when displaying.
90 data WarnReason
91 = NoReason
92 | ReasonDeprecatedFlag
93 | ReasonUnrecognisedFlag
94 deriving (Eq, Show)
95
96 instance Outputable WarnReason where
97 ppr = text . show
98
99 instance ToJson WarnReason where
100 json NoReason = JSNull
101 json reason = JSString $ show reason
102
103 -- | A command-line error message
104 newtype Err = Err { errMsg :: Located String }
105
106 -- | A command-line warning message and the reason it arose
107 data Warn = Warn
108 { warnReason :: WarnReason,
109 warnMsg :: Located String
110 }
111
112 type Errs = Bag Err
113 type Warns = Bag Warn
114
115 -- EwM ("errors and warnings monad") is a monad
116 -- transformer for m that adds an (err, warn) state
117 newtype EwM m a = EwM { unEwM :: Located String -- Current parse arg
118 -> Errs -> Warns
119 -> m (Errs, Warns, a) }
120
121 instance Monad m => Functor (EwM m) where
122 fmap = liftM
123
124 instance Monad m => Applicative (EwM m) where
125 pure v = EwM (\_ e w -> return (e, w, v))
126 (<*>) = ap
127
128 instance Monad m => Monad (EwM m) where
129 (EwM f) >>= k = EwM (\l e w -> do (e', w', r) <- f l e w
130 unEwM (k r) l e' w')
131
132 runEwM :: EwM m a -> m (Errs, Warns, a)
133 runEwM action = unEwM action (panic "processArgs: no arg yet") emptyBag emptyBag
134
135 setArg :: Located String -> EwM m () -> EwM m ()
136 setArg l (EwM f) = EwM (\_ es ws -> f l es ws)
137
138 addErr :: Monad m => String -> EwM m ()
139 addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` Err (L loc e), ws, ()))
140
141 addWarn :: Monad m => String -> EwM m ()
142 addWarn = addFlagWarn NoReason
143
144 addFlagWarn :: Monad m => WarnReason -> String -> EwM m ()
145 addFlagWarn reason msg = EwM $
146 (\(L loc _) es ws -> return (es, ws `snocBag` Warn reason (L loc msg), ()))
147
148 deprecate :: Monad m => String -> EwM m ()
149 deprecate s = do
150 arg <- getArg
151 addFlagWarn ReasonDeprecatedFlag (arg ++ " is deprecated: " ++ s)
152
153 getArg :: Monad m => EwM m String
154 getArg = EwM (\(L _ arg) es ws -> return (es, ws, arg))
155
156 getCurLoc :: Monad m => EwM m SrcSpan
157 getCurLoc = EwM (\(L loc _) es ws -> return (es, ws, loc))
158
159 liftEwM :: Monad m => m a -> EwM m a
160 liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) })
161
162
163 --------------------------------------------------------
164 -- A state monad for use in the command-line parser
165 --------------------------------------------------------
166
167 -- (CmdLineP s) typically instantiates the 'm' in (EwM m) and (OptKind m)
168 newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) }
169
170 instance Functor (CmdLineP s) where
171 fmap = liftM
172
173 instance Applicative (CmdLineP s) where
174 pure a = CmdLineP $ \s -> (a, s)
175 (<*>) = ap
176
177 instance Monad (CmdLineP s) where
178 m >>= k = CmdLineP $ \s ->
179 let (a, s') = runCmdLine m s
180 in runCmdLine (k a) s'
181
182
183 getCmdLineState :: CmdLineP s s
184 getCmdLineState = CmdLineP $ \s -> (s,s)
185 putCmdLineState :: s -> CmdLineP s ()
186 putCmdLineState s = CmdLineP $ \_ -> ((),s)
187
188
189 --------------------------------------------------------
190 -- Processing arguments
191 --------------------------------------------------------
192
193 processArgs :: Monad m
194 => [Flag m] -- cmdline parser spec
195 -> [Located String] -- args
196 -> m ( [Located String], -- spare args
197 [Err], -- errors
198 [Warn] ) -- warnings
199 processArgs spec args = do
200 (errs, warns, spare) <- runEwM action
201 return (spare, bagToList errs, bagToList warns)
202 where
203 action = process args []
204
205 -- process :: [Located String] -> [Located String] -> EwM m [Located String]
206 process [] spare = return (reverse spare)
207
208 process (locArg@(L _ ('-' : arg)) : args) spare =
209 case findArg spec arg of
210 Just (rest, opt_kind) ->
211 case processOneArg opt_kind rest arg args of
212 Left err ->
213 let b = process args spare
214 in (setArg locArg $ addErr err) >> b
215
216 Right (action,rest) ->
217 let b = process rest spare
218 in (setArg locArg $ action) >> b
219
220 Nothing -> process args (locArg : spare)
221
222 process (arg : args) spare = process args (arg : spare)
223
224
225 processOneArg :: OptKind m -> String -> String -> [Located String]
226 -> Either String (EwM m (), [Located String])
227 processOneArg opt_kind rest arg args
228 = let dash_arg = '-' : arg
229 rest_no_eq = dropEq rest
230 in case opt_kind of
231 NoArg a -> ASSERT(null rest) Right (a, args)
232
233 HasArg f | notNull rest_no_eq -> Right (f rest_no_eq, args)
234 | otherwise -> case args of
235 [] -> missingArgErr dash_arg
236 (L _ arg1:args1) -> Right (f arg1, args1)
237
238 -- See Trac #9776
239 SepArg f -> case args of
240 [] -> missingArgErr dash_arg
241 (L _ arg1:args1) -> Right (f arg1, args1)
242
243 -- See Trac #12625
244 Prefix f | notNull rest_no_eq -> Right (f rest_no_eq, args)
245 | otherwise -> missingArgErr dash_arg
246
247 PassFlag f | notNull rest -> unknownFlagErr dash_arg
248 | otherwise -> Right (f dash_arg, args)
249
250 OptIntSuffix f | null rest -> Right (f Nothing, args)
251 | Just n <- parseInt rest_no_eq -> Right (f (Just n), args)
252 | otherwise -> Left ("malformed integer argument in " ++ dash_arg)
253
254 IntSuffix f | Just n <- parseInt rest_no_eq -> Right (f n, args)
255 | otherwise -> Left ("malformed integer argument in " ++ dash_arg)
256
257 FloatSuffix f | Just n <- parseFloat rest_no_eq -> Right (f n, args)
258 | otherwise -> Left ("malformed float argument in " ++ dash_arg)
259
260 OptPrefix f -> Right (f rest_no_eq, args)
261 AnySuffix f -> Right (f dash_arg, args)
262
263 findArg :: [Flag m] -> String -> Maybe (String, OptKind m)
264 findArg spec arg =
265 case sortBy (compare `on` (length . fst)) -- prefer longest matching flag
266 [ (removeSpaces rest, optKind)
267 | flag <- spec,
268 let optKind = flagOptKind flag,
269 Just rest <- [stripPrefix (flagName flag) arg],
270 arg_ok optKind rest arg ]
271 of
272 [] -> Nothing
273 (one:_) -> Just one
274
275 arg_ok :: OptKind t -> [Char] -> String -> Bool
276 arg_ok (NoArg _) rest _ = null rest
277 arg_ok (HasArg _) _ _ = True
278 arg_ok (SepArg _) rest _ = null rest
279 arg_ok (Prefix _) _ _ = True -- Missing argument checked for in processOneArg t
280 -- to improve error message (Trac #12625)
281 arg_ok (OptIntSuffix _) _ _ = True
282 arg_ok (IntSuffix _) _ _ = True
283 arg_ok (FloatSuffix _) _ _ = True
284 arg_ok (OptPrefix _) _ _ = True
285 arg_ok (PassFlag _) rest _ = null rest
286 arg_ok (AnySuffix _) _ _ = True
287
288 -- | Parse an Int
289 --
290 -- Looks for "433" or "=342", with no trailing gubbins
291 -- * n or =n => Just n
292 -- * gibberish => Nothing
293 parseInt :: String -> Maybe Int
294 parseInt s = case reads s of
295 ((n,""):_) -> Just n
296 _ -> Nothing
297
298 parseFloat :: String -> Maybe Float
299 parseFloat s = case reads s of
300 ((n,""):_) -> Just n
301 _ -> Nothing
302
303 -- | Discards a leading equals sign
304 dropEq :: String -> String
305 dropEq ('=' : s) = s
306 dropEq s = s
307
308 unknownFlagErr :: String -> Either String a
309 unknownFlagErr f = Left ("unrecognised flag: " ++ f)
310
311 missingArgErr :: String -> Either String a
312 missingArgErr f = Left ("missing argument for flag: " ++ f)
313
314 --------------------------------------------------------
315 -- Utils
316 --------------------------------------------------------
317
318
319 -- See Note [Handling errors when parsing flags]
320 errorsToGhcException :: [(String, -- Location
321 String)] -- Error
322 -> GhcException
323 errorsToGhcException errs =
324 UsageError $ intercalate "\n" $ [ l ++ ": " ++ e | (l, e) <- errs ]
325
326 {- Note [Handling errors when parsing commandline flags]
327
328 Parsing of static and mode flags happens before any session is started, i.e.,
329 before the first call to 'GHC.withGhc'. Therefore, to report errors for
330 invalid usage of these two types of flags, we can not call any function that
331 needs DynFlags, as there are no DynFlags available yet (unsafeGlobalDynFlags
332 is not set either). So we always print "on the commandline" as the location,
333 which is true except for Api users, which is probably ok.
334
335 When reporting errors for invalid usage of dynamic flags we /can/ make use of
336 DynFlags, and we do so explicitly in DynFlags.parseDynamicFlagsFull.
337
338 Before, we called unsafeGlobalDynFlags when an invalid (combination of)
339 flag(s) was given on the commandline, resulting in panics (#9963).
340 -}