ghc: Introduce --run mode

As described in #18011, this mode provides similar functionality to the
`runhaskell` command, but doesn't require that the user know the path of
yet another executable, simplifying interactions with upstream tools.

1 files changed, 22 insertions, 3 deletions

diff --git a/ghc/Main.hs b/ghc/Main.hs
index 9c4c012247..2db9a99005 100644
--- a/ghc/Main.hs
+++ b/ghc/Main.hs
@@ -155,6 +155,9 @@ main = do
 main' :: PostLoadMode -> DynFlags -> [Located String] -> [Warn]
       -> Ghc ()
 main' postLoadMode dflags0 args flagWarnings = do
+  let args' = case postLoadMode of
+                DoRun -> takeWhile (\arg -> unLoc arg /= "--") args
+                _     -> args
 
   -- set the default GhcMode, backend and GhcLink.  The backend
   -- can be further adjusted on a module by module basis, using only
@@ -165,6 +168,7 @@ main' postLoadMode dflags0 args flagWarnings = do
          = case postLoadMode of
                DoInteractive   -> (CompManager, Interpreter,  LinkInMemory)
                DoEval _        -> (CompManager, Interpreter,  LinkInMemory)
+               DoRun           -> (CompManager, Interpreter,  LinkInMemory)
                DoMake          -> (CompManager, dflt_backend, LinkBinary)
                DoBackpack      -> (CompManager, dflt_backend, LinkBinary)
                DoMkDependHS    -> (MkDepend,    dflt_backend, LinkBinary)
@@ -176,6 +180,7 @@ main' postLoadMode dflags0 args flagWarnings = do
                          ghcLink   = link,
                          verbosity = case postLoadMode of
                                          DoEval _ -> 0
+                                         DoRun    -> 0
                                          _other   -> 1
                         }
 
@@ -189,6 +194,7 @@ main' postLoadMode dflags0 args flagWarnings = do
       -- a great story for the moment.
       dflags2  | DoInteractive <- postLoadMode = def_ghci_flags
                | DoEval _      <- postLoadMode = def_ghci_flags
+               | DoRun         <- postLoadMode = def_ghci_flags
                | otherwise                     = dflags1
         where def_ghci_flags = dflags1 `gopt_set` Opt_ImplicitImportQualified
                                        `gopt_set` Opt_IgnoreOptimChanges
@@ -200,7 +206,7 @@ main' postLoadMode dflags0 args flagWarnings = do
         -- The rest of the arguments are "dynamic"
         -- Leftover ones are presumably files
   (dflags3, fileish_args, dynamicFlagWarnings) <-
-      GHC.parseDynamicFlags logger2 dflags2 args
+      GHC.parseDynamicFlags logger2 dflags2 args'
 
   let dflags4 = case bcknd of
                 Interpreter | not (gopt Opt_ExternalInterpreter dflags3) ->
@@ -262,6 +268,7 @@ main' postLoadMode dflags0 args flagWarnings = do
        StopBefore p           -> liftIO (oneShot hsc_env p srcs)
        DoInteractive          -> ghciUI srcs Nothing
        DoEval exprs           -> ghciUI srcs $ Just $ reverse exprs
+       DoRun                  -> doRun srcs args
        DoAbiHash              -> abiHash (map fst srcs)
        ShowPackages           -> liftIO $ showUnits hsc_env
        DoFrontend f           -> doFrontend f srcs
@@ -269,6 +276,14 @@ main' postLoadMode dflags0 args flagWarnings = do
 
   liftIO $ dumpFinalStats logger
 
+doRun :: [(FilePath, Maybe Phase)] -> [Located String] -> Ghc ()
+doRun srcs args = do
+    dflags <- getDynFlags
+    let mainFun = fromMaybe "main" (mainFunIs dflags)
+    ghciUI srcs (Just ["System.Environment.withArgs " ++ show args' ++ " (Control.Monad.void " ++ mainFun ++ ")"])
+  where
+    args' = drop 1 $ dropWhile (/= "--") $ map unLoc args
+
 ghciUI :: [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc ()
 #if !defined(HAVE_INTERNAL_INTERPRETER)
 ghciUI _ _ =
@@ -430,16 +445,17 @@ data PostLoadMode
   | DoBackpack              -- ghc --backpack foo.bkp
   | DoInteractive           -- ghc --interactive
   | DoEval [String]         -- ghc -e foo -e bar => DoEval ["bar", "foo"]
+  | DoRun                   -- ghc --run
   | DoAbiHash               -- ghc --abi-hash
   | ShowPackages            -- ghc --show-packages
   | DoFrontend ModuleName   -- ghc --frontend Plugin.Module
 
-
-doMkDependHSMode, doMakeMode, doInteractiveMode,
+doMkDependHSMode, doMakeMode, doInteractiveMode, doRunMode,
   doAbiHashMode, showUnitsMode :: Mode
 doMkDependHSMode = mkPostLoadMode DoMkDependHS
 doMakeMode = mkPostLoadMode DoMake
 doInteractiveMode = mkPostLoadMode DoInteractive
+doRunMode = mkPostLoadMode DoRun
 doAbiHashMode = mkPostLoadMode DoAbiHash
 showUnitsMode = mkPostLoadMode ShowPackages
 
@@ -500,11 +516,13 @@ needsInputsMode _               = False
 isLinkMode :: PostLoadMode -> Bool
 isLinkMode (StopBefore NoStop) = True
 isLinkMode DoMake              = True
+isLinkMode DoRun               = True
 isLinkMode DoInteractive       = True
 isLinkMode (DoEval _)          = True
 isLinkMode _                   = False
 
 isCompManagerMode :: PostLoadMode -> Bool
+isCompManagerMode DoRun         = True
 isCompManagerMode DoMake        = True
 isCompManagerMode DoInteractive = True
 isCompManagerMode (DoEval _)    = True
@@ -586,6 +604,7 @@ mode_flags =
   , defFlag "E"            (PassFlag (setMode (stopBeforeMode StopPreprocess )))
   , defFlag "C"            (PassFlag (setMode (stopBeforeMode StopC)))
   , defFlag "S"            (PassFlag (setMode (stopBeforeMode StopAs)))
+  , defFlag "-run"         (PassFlag (setMode doRunMode))
   , defFlag "-make"        (PassFlag (setMode doMakeMode))
   , defFlag "-backpack"    (PassFlag (setMode doBackpackMode))
   , defFlag "-interactive" (PassFlag (setMode doInteractiveMode))