+-- -----------------------------------------------------------------------------
+-- Parsing the mode flag
+
+parseModeFlags :: [String] -> IO (CmdLineMode, [String])
+parseModeFlags args = do
+ let ((leftover, errs), (mode, _, flags)) =
+ runCmdLine (processArgs mode_flags args) (StopBefore StopLn, "", [])
+ when (not (null errs)) $ do
+ throwDyn (UsageError (unlines errs))
+ return (mode, flags ++ leftover)
+
+type ModeM a = CmdLineP (CmdLineMode, String, [String]) a
+ -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)
+ -- so we collect the new ones and return them.
+
+mode_flags :: [(String, OptKind (CmdLineP (CmdLineMode, String, [String])))]
+mode_flags =
+ [ ------- help / version ----------------------------------------------
+ ( "?" , PassFlag (setMode ShowUsage))
+ , ( "-help" , PassFlag (setMode ShowUsage))
+ , ( "-print-libdir" , PassFlag (setMode PrintLibdir))
+ , ( "V" , PassFlag (setMode ShowVersion))
+ , ( "-version" , PassFlag (setMode ShowVersion))
+ , ( "-numeric-version", PassFlag (setMode ShowNumVersion))
+
+ ------- interfaces ----------------------------------------------------
+ , ( "-show-iface" , HasArg (\f -> setMode (ShowInterface f)
+ "--show-iface"))
+
+ ------- primary modes ------------------------------------------------
+ , ( "M" , PassFlag (setMode DoMkDependHS))
+ , ( "E" , PassFlag (setMode (StopBefore anyHsc)))
+ , ( "C" , PassFlag (\f -> do setMode (StopBefore HCc) f
+ addFlag "-fvia-C"))
+ , ( "S" , PassFlag (setMode (StopBefore As)))
+ , ( "-make" , PassFlag (setMode DoMake))
+ , ( "-interactive" , PassFlag (setMode DoInteractive))
+ , ( "e" , HasArg (\s -> setMode (DoEval s) "-e"))
+
+ -- -fno-code says to stop after Hsc but don't generate any code.
+ , ( "fno-code" , PassFlag (\f -> do setMode (StopBefore HCc) f
+ addFlag "-fno-code"
+ addFlag "-no-recomp"))
+ ]
+
+setMode :: CmdLineMode -> String -> ModeM ()
+setMode m flag = do
+ (old_mode, old_flag, flags) <- getCmdLineState
+ when (notNull old_flag && flag /= old_flag) $
+ throwDyn (UsageError
+ ("cannot use `" ++ old_flag ++ "' with `" ++ flag ++ "'"))
+ putCmdLineState (m, flag, flags)
+
+addFlag :: String -> ModeM ()
+addFlag s = do
+ (m, f, flags) <- getCmdLineState
+ putCmdLineState (m, f, s:flags)