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