X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2FInteractiveUI.hs;h=0f68607a92fdbb1e170e6c8d26c2bc880d901b54;hp=03d0370ddb64e89e1c4ee1c5b92291e00df7c7f8;hb=b2524b3960999fffdb3767900f58825903f6560f;hpb=35c017791d582a0486f049ae5917dad8e891db8c diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 03d0370..0f68607 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -27,6 +27,8 @@ import GHC ( LoadHowMuch(..), Target(..), TargetId(..), Ghc, handleSourceError ) import PprTyThing import DynFlags +import qualified Lexer +import StringBuffer import Packages -- import PackageConfig @@ -36,13 +38,12 @@ import HscTypes ( handleFlagWarnings ) import HsImpExp import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC? import RdrName (RdrName) -import Outputable hiding (printForUser, printForUserPartWay) +import Outputable hiding (printForUser, printForUserPartWay, bold) import Module -- for ModuleEnv import Name import SrcLoc -- Other random utilities -import CmdLineParser import Digraph import BasicTypes hiding (isTopLevel) import Panic hiding (showException) @@ -81,7 +82,7 @@ import System.Environment import System.Exit ( exitWith, ExitCode(..) ) import System.Directory import System.IO -import System.IO.Error as IO +import System.IO.Error import Data.Char import Data.Array import Control.Monad as Monad @@ -89,12 +90,8 @@ import Text.Printf import Foreign import GHC.Exts ( unsafeCoerce# ) -#if __GLASGOW_HASKELL__ >= 611 import GHC.IO.Exception ( IOErrorType(InvalidArgument) ) import GHC.IO.Handle ( hFlushAll ) -#else -import GHC.IOBase ( IOErrorType(InvalidArgument) ) -#endif import GHC.TopHandler @@ -146,6 +143,7 @@ builtin_commands = [ ("quit", quit, noCompletion), ("reload", keepGoing' reloadModule, noCompletion), ("run", keepGoing runRun, completeFilename), + ("script", keepGoing' scriptCmd, completeFilename), ("set", keepGoing setCmd, completeSetOptions), ("show", keepGoing showCmd, completeShowOptions), ("sprint", keepGoing sprintCmd, completeExpression), @@ -220,6 +218,7 @@ helpText = " :quit exit GHCi\n" ++ " :reload reload the current module set\n" ++ " :run function [ ...] run the function with the given arguments\n" ++ + " :script run the script " ++ " :type show the type of \n" ++ " :undef undefine user-defined command :\n" ++ " :! run the shell command \n" ++ @@ -261,6 +260,7 @@ helpText = "\n" ++ " Options for ':set' and ':unset':\n" ++ "\n" ++ + " +m allow multiline commands\n" ++ " +r revert top-level expressions after each evaluation\n" ++ " +s print timing/memory stats after each evaluation\n" ++ " +t print type after evaluation\n" ++ @@ -284,7 +284,7 @@ helpText = findEditor :: IO String findEditor = do getEnv "EDITOR" - `IO.catch` \_ -> do + `catchIO` \_ -> do #if mingw32_HOST_OS win <- System.Win32.getWindowsDirectory return (win "notepad.exe") @@ -294,6 +294,14 @@ findEditor = do foreign import ccall unsafe "rts_isProfiled" isProfiled :: IO CInt +default_progname, default_prompt, default_stop :: String +default_progname = "" +default_prompt = "%s> " +default_stop = "" + +default_args :: [String] +default_args = [] + interactiveUI :: [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc () interactiveUI srcs maybe_exprs = do @@ -330,7 +338,7 @@ interactiveUI srcs maybe_exprs = do -- We don't want the cmd line to buffer any input that might be -- intended for the program, so unbuffer stdin. hSetBuffering stdin NoBuffering -#if defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 611 +#if defined(mingw32_HOST_OS) -- On Unix, stdin will use the locale encoding. The IO library -- doesn't do this on Windows (yet), so for now we use UTF-8, -- for consistency with GHC 6.10 and to make the tests work. @@ -344,14 +352,15 @@ interactiveUI srcs maybe_exprs = do default_editor <- liftIO $ findEditor startGHCi (runGHCi srcs maybe_exprs) - GHCiState{ progname = "", - args = [], - prompt = "%s> ", - stop = "", + GHCiState{ progname = default_progname, + args = default_args, + prompt = default_prompt, + stop = default_stop, editor = default_editor, -- session = session, options = [], prelude = prel_mod, + line_number = 1, break_ctr = 0, breaks = [], tickarrays = emptyModuleEnv, @@ -365,14 +374,16 @@ interactiveUI srcs maybe_exprs = do withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a withGhcAppData right left = do - either_dir <- IO.try (getAppUserDataDirectory "ghc") - case either_dir of - Right dir -> right dir - _ -> left + either_dir <- tryIO (getAppUserDataDirectory "ghc") + case either_dir of + Right dir -> + do createDirectoryIfMissing False dir `catchIO` \_ -> return () + right dir + _ -> left runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi () runGHCi paths maybe_exprs = do - let + let read_dot_files = not opt_IgnoreDotGhci current_dir = return (Just ".ghci") @@ -382,7 +393,7 @@ runGHCi paths maybe_exprs = do (return Nothing) home_dir = do - either_dir <- liftIO $ IO.try (getEnv "HOME") + either_dir <- liftIO $ tryIO (getEnv "HOME") case either_dir of Right home -> return (Just (home ".ghci")) _ -> return Nothing @@ -398,14 +409,16 @@ runGHCi paths maybe_exprs = do dir_ok <- liftIO $ checkPerms (getDirectory file) file_ok <- liftIO $ checkPerms file when (dir_ok && file_ok) $ do - either_hdl <- liftIO $ IO.try (openFile file ReadMode) + either_hdl <- liftIO $ tryIO (openFile file ReadMode) case either_hdl of Left _e -> return () -- NOTE: this assumes that runInputT won't affect the terminal; -- can we assume this will always be the case? -- This would be a good place for runFileInputT. - Right hdl -> runInputTWithPrefs defaultPrefs defaultSettings $ do - runCommands $ fileLoop hdl + Right hdl -> + do runInputTWithPrefs defaultPrefs defaultSettings $ + runCommands False $ fileLoop hdl + liftIO (hClose hdl `catchIO` \_ -> return ()) where getDirectory f = case takeDirectory f of "" -> "."; d -> d @@ -439,7 +452,7 @@ runGHCi paths maybe_exprs = do Nothing -> do -- enter the interactive loop - runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty + runGHCiInput $ runCommands True $ nextInputLine show_prompt is_tty Just exprs -> do -- just evaluate the expression we were given enqueueCommands exprs @@ -453,7 +466,7 @@ runGHCi paths maybe_exprs = do -- this used to be topHandlerFastExit, see #2228 $ topHandler e runInputTWithPrefs defaultPrefs defaultSettings $ do - runCommands' handle (return Nothing) + runCommands' handle True (return Nothing) -- and finally, exit liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving GHCi." @@ -507,9 +520,15 @@ checkPerms name = else return True #endif -fileLoop :: MonadIO m => Handle -> InputT m (Maybe String) +incrementLines :: InputT GHCi () +incrementLines = do + st <- lift $ getGHCiState + let ln = 1+(line_number st) + lift $ setGHCiState st{line_number=ln} + +fileLoop :: Handle -> InputT GHCi (Maybe String) fileLoop hdl = do - l <- liftIO $ IO.try $ hGetLine hdl + l <- liftIO $ tryIO $ hGetLine hdl case l of Left e | isEOFError e -> return Nothing | InvalidArgument <- etype -> return Nothing @@ -519,7 +538,9 @@ fileLoop hdl = do -- this can happen if the user closed stdin, or -- perhaps did getContents which closes stdin at -- EOF. - Right l -> return (Just l) + Right l -> do + incrementLines + return (Just l) mkPrompt :: GHCi String mkPrompt = do @@ -570,37 +591,44 @@ queryQueue = do c:cs -> do setGHCiState st{ cmdqueue = cs } return (Just c) -runCommands :: InputT GHCi (Maybe String) -> InputT GHCi () +runCommands :: Bool -> InputT GHCi (Maybe String) -> InputT GHCi () runCommands = runCommands' handler runCommands' :: (SomeException -> GHCi Bool) -- Exception handler + -> Bool -> InputT GHCi (Maybe String) -> InputT GHCi () -runCommands' eh getCmd = do +runCommands' eh resetLineTo1 getCmd = do + when resetLineTo1 $ lift $ do st <- getGHCiState + setGHCiState $ st { line_number = 0 } b <- ghandle (\e -> case fromException e of - Just UserInterrupt -> return False + Just UserInterrupt -> return $ Just False _ -> case fromException e of Just ghc_e -> do liftIO (print (ghc_e :: GhcException)) - return True + return Nothing _other -> liftIO (Exception.throwIO e)) (runOneCommand eh getCmd) - if b then return () else runCommands' eh getCmd + case b of + Nothing -> return () + Just _ -> runCommands' eh resetLineTo1 getCmd runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String) - -> InputT GHCi Bool + -> InputT GHCi (Maybe Bool) runOneCommand eh getCmd = do mb_cmd <- noSpace (lift queryQueue) mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd case mb_cmd of - Nothing -> return True - Just c -> ghciHandle (lift . eh) $ + Nothing -> return Nothing + Just c -> ghciHandle (\e -> lift $ eh e >>= return . Just) $ handleSourceError printErrorAndKeepGoing (doCommand c) + -- source error's are handled by runStmt + -- is the handler necessary here? where printErrorAndKeepGoing err = do GHC.printException err - return False + return $ Just True noSpace q = q >>= maybe (return Nothing) (\c->case removeSpaces c of @@ -631,9 +659,64 @@ runOneCommand eh getCmd = do normSpace c = c -- QUESTION: is userError the one to use here? collectError = userError "unterminated multiline command :{ .. :}" - doCommand (':' : cmd) = specialCommand cmd - doCommand stmt = do _ <- timeIt $ lift $ runStmt stmt GHC.RunToCompletion - return False + doCommand (':' : cmd) = do + result <- specialCommand cmd + case result of + True -> return Nothing + _ -> return $ Just True + doCommand stmt = do + ml <- lift $ isOptionSet Multiline + if ml + then do + mb_stmt <- checkInputForLayout stmt getCmd + case mb_stmt of + Nothing -> return $ Just True + Just ml_stmt -> do + result <- timeIt $ lift $ runStmt ml_stmt GHC.RunToCompletion + return $ Just result + else do + result <- timeIt $ lift $ runStmt stmt GHC.RunToCompletion + return $ Just result + +-- #4316 +-- lex the input. If there is an unclosed layout context, request input +checkInputForLayout :: String -> InputT GHCi (Maybe String) + -> InputT GHCi (Maybe String) +checkInputForLayout stmt getStmt = do + dflags' <- lift $ getDynFlags + let dflags = xopt_set dflags' Opt_AlternativeLayoutRule + st <- lift $ getGHCiState + let buf = stringToStringBuffer stmt + loc = mkSrcLoc (fsLit (progname st)) (line_number st) 1 + pstate = Lexer.mkPState dflags buf loc + case Lexer.unP goToEnd pstate of + (Lexer.POk _ False) -> return $ Just stmt + _other -> do + st <- lift getGHCiState + let p = prompt st + lift $ setGHCiState st{ prompt = "%s| " } + mb_stmt <- ghciHandle (\ex -> case fromException ex of + Just UserInterrupt -> return Nothing + _ -> case fromException ex of + Just ghc_e -> + do liftIO (print (ghc_e :: GhcException)) + return Nothing + _other -> liftIO (Exception.throwIO ex)) + getStmt + lift $ getGHCiState >>= \st->setGHCiState st{ prompt = p } + -- the recursive call does not recycle parser state + -- as we use a new string buffer + case mb_stmt of + Nothing -> return Nothing + Just str -> if str == "" + then return $ Just stmt + else do + checkInputForLayout (stmt++"\n"++str) getStmt + where goToEnd = do + eof <- Lexer.nextIsEOF + if eof + then Lexer.activeContext + else Lexer.lexer return >> goToEnd enqueueCommands :: [String] -> GHCi () enqueueCommands cmds = do @@ -648,15 +731,12 @@ runStmt stmt step | "import " `isPrefixOf` stmt = do newContextCmd (Import stmt); return False | otherwise - = do -#if __GLASGOW_HASKELL__ >= 611 - -- In the new IO library, read handles buffer data even if the Handle + = do -- In the new IO library, read handles buffer data even if the Handle -- is set to NoBuffering. This causes problems for GHCi where there -- are really two stdin Handles. So we flush any bufferred data in -- GHCi's stdin Handle here (only relevant if stdin is attached to -- a file, otherwise the read buffer can't be flushed). - _ <- liftIO $ IO.try $ hFlushAll stdin -#endif + _ <- liftIO $ tryIO $ hFlushAll stdin result <- GhciMonad.runStmt stmt step afterRunStmt (const True) result @@ -768,8 +848,11 @@ lookupCommand' str' = do macros <- readIORef macros_ref let{ (str, cmds) = case str' of ':' : rest -> (rest, builtin_commands) - _ -> (str', macros ++ builtin_commands) } + _ -> (str', builtin_commands ++ macros) } -- look for exact match first, then the first prefix match + -- We consider builtin commands first: since new macros are appended + -- on the *end* of the macros list, this is consistent with the view + -- that things defined earlier should take precedence. See also #3858 return $ case [ c | c <- cmds, str == cmdName c ] of c:_ -> Just c [] -> case [ c | c@(s,_,_) <- cmds, str `isPrefixOf` s ] of @@ -885,7 +968,7 @@ addModule files = do changeDirectory :: String -> InputT GHCi () changeDirectory "" = do -- :cd on its own changes to the user's home directory - either_dir <- liftIO $ IO.try getHomeDirectory + either_dir <- liftIO $ tryIO getHomeDirectory case either_dir of Left _e -> return () Right dir -> changeDirectory dir @@ -1187,6 +1270,39 @@ shellEscape :: String -> GHCi Bool shellEscape str = liftIO (system str >> return False) ----------------------------------------------------------------------------- +-- running a script file #1363 + +scriptCmd :: String -> InputT GHCi () +scriptCmd s = do + case words s of + [s] -> runScript s + _ -> ghcError (CmdLineError "syntax: :script ") + +runScript :: String -- ^ filename + -> InputT GHCi () +runScript filename = do + either_script <- liftIO $ tryIO (openFile filename ReadMode) + case either_script of + Left _err -> ghcError (CmdLineError $ "IO error: \""++filename++"\" " + ++(ioeGetErrorString _err)) + Right script -> do + st <- lift $ getGHCiState + let prog = progname st + line = line_number st + lift $ setGHCiState st{progname=filename,line_number=0} + scriptLoop script + liftIO $ hClose script + new_st <- lift $ getGHCiState + lift $ setGHCiState new_st{progname=prog,line_number=line} + where scriptLoop script = do + res <- runOneCommand handler $ fileLoop script + case res of + Nothing -> return () + Just succ -> if succ + then scriptLoop script + else return () + +----------------------------------------------------------------------------- -- Browsing a module's contents browseCmd :: Bool -> String -> InputT GHCi () @@ -1496,7 +1612,9 @@ newDynFlags minus_opts = do liftIO $ handleFlagWarnings dflags' warns if (not (null leftovers)) - then ghcError $ errorsToGhcException leftovers + then ghcError . CmdLineError + $ "Some flags have not been recognized: " + ++ (concat . intersperse ", " $ map unLoc leftovers) else return () new_pkgs <- setDynFlags dflags' @@ -1516,22 +1634,32 @@ newDynFlags minus_opts = do unsetOptions :: String -> GHCi () unsetOptions str - = do -- first, deal with the GHCi opts (+s, +t, etc.) - let opts = words str - (minus_opts, rest1) = partition isMinus opts - (plus_opts, rest2) = partitionWith isPlus rest1 - - if (not (null rest2)) - then liftIO (putStrLn ("unknown option: '" ++ head rest2 ++ "'")) - else do + = -- first, deal with the GHCi opts (+s, +t, etc.) + let opts = words str + (minus_opts, rest1) = partition isMinus opts + (plus_opts, rest2) = partitionWith isPlus rest1 + (other_opts, rest3) = partition (`elem` map fst defaulters) rest2 + + defaulters = + [ ("args" , setArgs default_args) + , ("prog" , setProg default_progname) + , ("prompt", setPrompt default_prompt) + , ("editor", liftIO findEditor >>= setEditor) + , ("stop" , setStop default_stop) + ] + + no_flag ('-':'f':rest) = return ("-fno-" ++ rest) + no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f)) + + in if (not (null rest3)) + then liftIO (putStrLn ("unknown option: '" ++ head rest3 ++ "'")) + else do + mapM_ (fromJust.flip lookup defaulters) other_opts - mapM_ unsetOpt plus_opts - - let no_flag ('-':'f':rest) = return ("-fno-" ++ rest) - no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f)) + mapM_ unsetOpt plus_opts - no_flags <- mapM no_flag minus_opts - newDynFlags no_flags + no_flags <- mapM no_flag minus_opts + newDynFlags no_flags isMinus :: String -> Bool isMinus ('-':_) = True @@ -1554,12 +1682,14 @@ unsetOpt str Just o -> unsetOption o strToGHCiOpt :: String -> (Maybe GHCiOption) +strToGHCiOpt "m" = Just Multiline strToGHCiOpt "s" = Just ShowTiming strToGHCiOpt "t" = Just ShowType strToGHCiOpt "r" = Just RevertCAFs strToGHCiOpt _ = Nothing optToStr :: GHCiOption -> String +optToStr Multiline = "m" optToStr ShowTiming = "s" optToStr ShowType = "t" optToStr RevertCAFs = "r" @@ -1963,11 +2093,11 @@ historyCmd arg _ -> do spans <- mapM GHC.getHistorySpan took let nums = map (printf "-%-3d:") [(1::Int)..] - names = map GHC.historyEnclosingDecl took + names = map GHC.historyEnclosingDecls took printForUser (vcat(zipWith3 (\x y z -> x <+> y <+> z) (map text nums) - (map (bold . ppr) names) + (map (bold . hcat . punctuate colon . map text) names) (map (parens . ppr) spans))) liftIO $ putStrLn $ if null rest then "" else "..."