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