X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=9bba141e2eebf67784c27369e0b1eb9ebf05e627;hb=0ebfc8bdb372157c9f238a387b0dadca3bbc667a;hp=65693b388cc30afe07dac4580268f6870611fd2b;hpb=c2fd45f3496040a6bc7ce8110ffe9e14bad6564f;p=ghc-hetmet.git diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 65693b3..9bba141 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -54,6 +54,7 @@ import System.Posix hiding (getEnv) #else import GHC.ConsoleHandler ( flushConsole ) import qualified System.Win32 +import System.FilePath #endif #ifdef USE_READLINE @@ -137,6 +138,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), @@ -158,11 +160,15 @@ builtin_commands = [ -- -- NOTE: in order for us to override the default correctly, any custom entry -- must be a SUBSET of word_break_chars. -word_break_chars, flagWordBreakChars, filenameWordBreakChars :: String +#ifdef USE_READLINE +word_break_chars :: String word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~" specials = "(),;[]`{}" spaces = " \t\n" in spaces ++ specials ++ symbols +#endif + +flagWordBreakChars, filenameWordBreakChars :: String flagWordBreakChars = " \t\n" filenameWordBreakChars = " \t\n\\`@$><=;|&{(" -- bash defaults @@ -171,7 +177,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" @@ -201,6 +211,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" ++ @@ -263,14 +274,15 @@ findEditor = do getEnv "EDITOR" `IO.catch` \_ -> do #if mingw32_HOST_OS - win <- System.Win32.getWindowsDirectory - return (win `joinFileName` "notepad.exe") + win <- System.Win32.getWindowsDirectory + return (win "notepad.exe") #else - return "" + 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 @@ -286,7 +298,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 @@ -298,30 +310,33 @@ interactiveUI session srcs maybe_expr = do -- intended for the program, so unbuffer stdin. hSetBuffering stdin NoBuffering - -- initial context is just the Prelude +#ifdef USE_READLINE + is_tty <- hIsTerminalDevice stdin + when is_tty $ do + Readline.initialize + Readline.setAttemptedCompletionFunction (Just completeWord) + --Readline.parseAndBind "set show-all-if-ambiguous 1" + + Readline.setBasicWordBreakCharacters word_break_chars + Readline.setCompleterWordBreakCharacters word_break_chars + Readline.setCompletionAppendCharacter Nothing +#endif + + -- initial context is just the Prelude prel_mod <- GHC.findModule session (GHC.mkModuleName "Prelude") (Just basePackageId) GHC.setContext session [] [prel_mod] -#ifdef USE_READLINE - Readline.initialize - Readline.setAttemptedCompletionFunction (Just completeWord) - --Readline.parseAndBind "set show-all-if-ambiguous 1" - - Readline.setBasicWordBreakCharacters word_break_chars - Readline.setCompleterWordBreakCharacters word_break_chars -#endif - default_editor <- findEditor - startGHCi (runGHCi srcs maybe_expr) - GHCiState{ progname = "", - args = [], + startGHCi (runGHCi srcs maybe_exprs) + GHCiState{ progname = "", + args = [], prompt = "%s> ", stop = "", - editor = default_editor, - session = session, - options = [], + editor = default_editor, + session = session, + options = [], prelude = prel_mod, break_ctr = 0, breaks = [], @@ -337,8 +352,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 @@ -349,35 +364,35 @@ runGHCi paths maybe_expr = do dir_ok <- io (checkPerms ".") file_ok <- io (checkPerms file) when (dir_ok && file_ok) $ do - either_hdl <- io (IO.try (openFile "./.ghci" ReadMode)) - case either_hdl of - Left _e -> return () - Right hdl -> runCommands (fileLoop hdl False False) - + either_hdl <- io (IO.try (openFile "./.ghci" ReadMode)) + case either_hdl of + Left _e -> return () + Right hdl -> runCommands (fileLoop hdl False False) + when (read_dot_files) $ do -- Read in $HOME/.ghci either_dir <- io (IO.try getHomeDirectory) case either_dir of Left _e -> return () Right dir -> do - cwd <- io (getCurrentDirectory) - when (dir /= cwd) $ do - let file = dir ++ "/.ghci" - ok <- io (checkPerms file) - when ok $ do - either_hdl <- io (IO.try (openFile file ReadMode)) - case either_hdl of - Left _e -> return () - Right hdl -> runCommands (fileLoop hdl False False) + cwd <- io (getCurrentDirectory) + when (dir /= cwd) $ do + let file = dir ++ "/.ghci" + ok <- io (checkPerms file) + when ok $ do + either_hdl <- io (IO.try (openFile file ReadMode)) + case either_hdl of + Left _e -> return () + Right hdl -> runCommands (fileLoop hdl False False) -- Perform a :load for files given on the GHCi command line -- When in -e mode, if the load fails then we want to stop -- immediately rather than going on to evaluate the expression. when (not (null paths)) $ do - ok <- ghciHandle (\e -> do showException e; return Failed) $ - loadModule paths - when (isJust maybe_expr && failed ok) $ - io (exitWith (ExitFailure 1)) + ok <- ghciHandle (\e -> do showException e; return Failed) $ + loadModule paths + when (isJust maybe_exprs && failed ok) $ + io (exitWith (ExitFailure 1)) -- if verbosity is greater than 0, or we are connected to a -- terminal, display the prompt in the interactive loop. @@ -385,7 +400,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) @@ -401,10 +416,12 @@ 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 handleEval (ExitException code) = io (exitWith code) + handleEval e = handler e + runCommands' handleEval (return Nothing) -- and finally, exit io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi." @@ -580,14 +597,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 @@ -628,24 +649,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 @@ -843,9 +846,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 @@ -1390,27 +1406,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 @@ -1699,7 +1720,18 @@ completeSetOptions w = do return (filter (w `isPrefixOf`) options) where options = "args":"prog":allFlags -completeFilename = Readline.filenameCompletionFunction +completeFilename w = do + ws <- Readline.filenameCompletionFunction w + case ws of + -- If we only found one result, and it's a directory, + -- add a trailing slash. + [file] -> do + isDir <- expandPathIO file >>= doesDirectoryExist + if isDir && last file /= '/' + then return [file ++ "/"] + else return [file] + _ -> return ws + completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename @@ -1713,8 +1745,10 @@ wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String] wrapCompleter fun w = do strs <- fun w case strs of - [] -> return Nothing - [x] -> return (Just (x,[])) + [] -> Readline.setAttemptedCompletionOver True >> return Nothing + [x] -> -- Add a trailing space, unless it already has an appended slash. + let appended = if last x == '/' then x else x ++ " " + in return (Just (appended,[])) xs -> case getCommonPrefix xs of "" -> return (Just ("",xs)) pref -> return (Just (pref,xs)) @@ -1795,10 +1829,13 @@ ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s) -- Utils expandPath :: String -> GHCi String -expandPath path = +expandPath path = io (expandPathIO path) + +expandPathIO :: String -> IO String +expandPathIO path = case dropWhile isSpace path of ('~':d) -> do - tilde <- io getHomeDirectory -- will fail if HOME not defined + tilde <- getHomeDirectory -- will fail if HOME not defined return (tilde ++ '/':d) other -> return other @@ -2115,9 +2152,23 @@ listCmd :: String -> GHCi () listCmd "" = do mb_span <- getCurrentBreakSpan case mb_span of - Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list" - Just span | GHC.isGoodSrcSpan span -> io $ listAround span True - | otherwise -> printForUser $ text "unable to list source for" <+> ppr span + Nothing -> + printForUser $ text "Not stopped at a breakpoint; nothing to list" + Just span + | GHC.isGoodSrcSpan span -> io $ listAround span True + | otherwise -> + do s <- getSession + resumes <- io $ GHC.getResumeContext s + case resumes of + [] -> panic "No resumes" + (r:_) -> + do let traceIt = case GHC.resumeHistory r of + [] -> text "rerunning with :trace," + _ -> empty + doWhat = traceIt <+> text ":back then :list" + printForUser (text "Unable to list source for" <+> + ppr span + $$ text "Try" <+> doWhat) listCmd str = list2 (words str) list2 :: [String] -> GHCi ()