X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=afd970214b5f1be4c5c9ac23e396158a0d8d97a1;hb=00fc612dc1e776ef34bd09b4f4ef4f6650d418b0;hp=30f1de6d275d7d51c58217ffb34c085b7e6b550e;hpb=a0b2691bb9116d06bc6a3a16b36388b477791224;p=ghc-hetmet.git diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 30f1de6..afd9702 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -82,9 +82,10 @@ import Data.Array import Control.Monad as Monad import Text.Printf import Foreign -import Foreign.C ( withCStringLen ) +import Foreign.C import GHC.Exts ( unsafeCoerce# ) import GHC.IOBase ( IOErrorType(InvalidArgument) ) +import GHC.TopHandler import Data.IORef ( IORef, readIORef, writeIORef ) @@ -138,6 +139,7 @@ builtin_commands = [ ("print", keepGoing printCmd, Nothing, completeIdentifier), ("quit", quit, Nothing, completeNone), ("reload", keepGoing reloadModule, Nothing, completeNone), + ("run", keepGoing runRun, Nothing, completeIdentifier), ("set", keepGoing setCmd, Just flagWordBreakChars, completeSetOptions), ("show", keepGoing showCmd, Nothing, completeNone), ("sprint", keepGoing sprintCmd, Nothing, completeIdentifier), @@ -176,7 +178,11 @@ keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool) keepGoing a str = a str >> return False keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool) -keepGoingPaths a str = a (toArgs str) >> return False +keepGoingPaths a str + = do case toArgs str of + Left err -> io (hPutStrLn stderr err) + Right args -> a args + return False shortHelpText :: String shortHelpText = "use :? for help.\n" @@ -206,6 +212,7 @@ helpText = " :module [+/-] [*] ... set the context for expression evaluation\n" ++ " :quit exit GHCi\n" ++ " :reload reload the current module set\n" ++ + " :run function [ ...] run the function with the given arguments\n" ++ " :type show the type of \n" ++ " :undef undefine user-defined command :\n" ++ " :! run the shell command \n" ++ @@ -274,8 +281,9 @@ findEditor = do return "" #endif -interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO () -interactiveUI session srcs maybe_expr = do +interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe [String] + -> IO () +interactiveUI session srcs maybe_exprs = do -- HACK! If we happen to get into an infinite loop (eg the user -- types 'let x=x in x' at the prompt), then the thread will block -- on a blackhole, and become unreachable during GC. The GC will @@ -291,7 +299,7 @@ interactiveUI session srcs maybe_expr = do -- Initialise buffering for the *interpreted* I/O system initInterpBuffering session - when (isNothing maybe_expr) $ do + when (isNothing maybe_exprs) $ do -- Only for GHCi (not runghc and ghc -e): -- Turn buffering off for the compiled program's stdout/stderr @@ -322,7 +330,7 @@ interactiveUI session srcs maybe_expr = do default_editor <- findEditor - startGHCi (runGHCi srcs maybe_expr) + startGHCi (runGHCi srcs maybe_exprs) GHCiState{ progname = "", args = [], prompt = "%s> ", @@ -345,8 +353,8 @@ interactiveUI session srcs maybe_expr = do return () -runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi () -runGHCi paths maybe_expr = do +runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi () +runGHCi paths maybe_exprs = do let read_dot_files = not opt_IgnoreDotGhci when (read_dot_files) $ do @@ -384,7 +392,7 @@ runGHCi paths maybe_expr = do when (not (null paths)) $ do ok <- ghciHandle (\e -> do showException e; return Failed) $ loadModule paths - when (isJust maybe_expr && failed ok) $ + when (isJust maybe_exprs && failed ok) $ io (exitWith (ExitFailure 1)) -- if verbosity is greater than 0, or we are connected to a @@ -393,7 +401,7 @@ runGHCi paths maybe_expr = do dflags <- getDynFlags let show_prompt = verbosity dflags > 0 || is_tty - case maybe_expr of + case maybe_exprs of Nothing -> do #if defined(mingw32_HOST_OS) @@ -409,15 +417,25 @@ runGHCi paths maybe_expr = do #endif -- enter the interactive loop interactiveLoop is_tty show_prompt - Just expr -> do + Just exprs -> do -- just evaluate the expression we were given - runCommandEval expr - return () + enqueueCommands exprs + let handle e = do st <- getGHCiState + -- Jump through some hoops to get the + -- current progname in the exception text: + -- : + io $ withProgName (progname st) + -- The "fast exit" part just calls exit() + -- directly instead of doing an orderly + -- runtime shutdown, otherwise the main + -- GHCi thread will complain about being + -- interrupted. + $ topHandlerFastExit e + runCommands' handle (return Nothing) -- and finally, exit io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi." - interactiveLoop :: Bool -> Bool -> GHCi () interactiveLoop is_tty show_prompt = -- Ignore ^C exceptions caught here @@ -588,14 +606,18 @@ queryQueue = do return (Just c) runCommands :: GHCi (Maybe String) -> GHCi () -runCommands getCmd = do +runCommands = runCommands' handler + +runCommands' :: (Exception -> GHCi Bool) -- Exception handler + -> GHCi (Maybe String) -> GHCi () +runCommands' eh getCmd = do mb_cmd <- noSpace queryQueue mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd case mb_cmd of Nothing -> return () Just c -> do - b <- ghciHandle handler (doCommand c) - if b then return () else runCommands getCmd + b <- ghciHandle eh (doCommand c) + if b then return () else runCommands' eh getCmd where noSpace q = q >>= maybe (return Nothing) (\c->case removeSpaces c of @@ -636,24 +658,6 @@ enqueueCommands cmds = do setGHCiState st{ cmdqueue = cmds ++ cmdqueue st } --- This version is for the GHC command-line option -e. The only difference --- from runCommand is that it catches the ExitException exception and --- exits, rather than printing out the exception. -runCommandEval :: String -> GHCi Bool -runCommandEval c = ghciHandle handleEval (doCommand c) - where - handleEval (ExitException code) = io (exitWith code) - handleEval e = do handler e - io (exitWith (ExitFailure 1)) - - doCommand (':' : command) = specialCommand command - doCommand stmt - = do r <- runStmt stmt GHC.RunToCompletion - case r of - False -> io (exitWith (ExitFailure 1)) - -- failure to run the command causes exit(1) for ghc -e. - _ -> return True - runStmt :: String -> SingleStep -> GHCi Bool runStmt stmt step | null (filter (not.isSpace) stmt) = return False @@ -851,9 +855,22 @@ pprInfo pefas (thing, fixity, insts) | otherwise = ppr fix <+> ppr (GHC.getName thing) runMain :: String -> GHCi () -runMain args = do - let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args)) - enqueueCommands ['[': ss ++ "] `System.Environment.withArgs` main"] +runMain s = case toArgs s of + Left err -> io (hPutStrLn stderr err) + Right args -> + do dflags <- getDynFlags + case mainFunIs dflags of + Nothing -> doWithArgs args "main" + Just f -> doWithArgs args f + +runRun :: String -> GHCi () +runRun s = case toCmdArgs s of + Left err -> io (hPutStrLn stderr err) + Right (cmd, args) -> doWithArgs args cmd + +doWithArgs :: [String] -> String -> GHCi () +doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++ + show args ++ " (" ++ cmd ++ ")"] addModule :: [FilePath] -> GHCi () addModule files = do @@ -1398,27 +1415,32 @@ setCmd "" ,Opt_PrintEvldWithShow ] setCmd str - = case toArgs str of - ("args":args) -> setArgs args - ("prog":prog) -> setProg prog - ("prompt":_) -> setPrompt (after 6) - ("editor":_) -> setEditor (after 6) - ("stop":_) -> setStop (after 4) - wds -> setOptions wds - where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str - -setArgs, setProg, setOptions :: [String] -> GHCi () -setEditor, setStop, setPrompt :: String -> GHCi () + = case getCmd str of + Right ("args", rest) -> + case toArgs rest of + Left err -> io (hPutStrLn stderr err) + Right args -> setArgs args + Right ("prog", rest) -> + case toArgs rest of + Right [prog] -> setProg prog + _ -> io (hPutStrLn stderr "syntax: :set prog ") + Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest + Right ("editor", rest) -> setEditor $ dropWhile isSpace rest + Right ("stop", rest) -> setStop $ dropWhile isSpace rest + _ -> case toArgs str of + Left err -> io (hPutStrLn stderr err) + Right wds -> setOptions wds + +setArgs, setOptions :: [String] -> GHCi () +setProg, setEditor, setStop, setPrompt :: String -> GHCi () setArgs args = do st <- getGHCiState setGHCiState st{ args = args } -setProg [prog] = do +setProg prog = do st <- getGHCiState setGHCiState st{ progname = prog } -setProg _ = do - io (hPutStrLn stderr "syntax: :set prog ") setEditor cmd = do st <- getGHCiState