X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2FInteractiveUI.hs;h=eaf2d2d5596bcbc32bdd36cf8f546ee031afa31f;hb=5100993061f3c7ce3ac19005d88f8299bc54b797;hp=2f3ca85dece9910fb2251e960c61aac479139d99;hpb=b00e3a6c0a82a8af3238d677f798d812cd7fd49f;p=ghc-hetmet.git diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 2f3ca85..eaf2d2d 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 @@ -42,7 +44,6 @@ 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 @@ -257,6 +258,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" ++ @@ -369,7 +371,7 @@ interactiveUI srcs maybe_exprs = do withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a withGhcAppData right left = do - either_dir <- IO.try (getAppUserDataDirectory "ghc") + either_dir <- tryIO (getAppUserDataDirectory "ghc") case either_dir of Right dir -> do createDirectoryIfMissing False dir `catchIO` \_ -> return () @@ -388,7 +390,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 @@ -404,7 +406,7 @@ 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; @@ -517,7 +519,7 @@ checkPerms name = fileLoop :: MonadIO m => Handle -> InputT m (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 @@ -585,30 +587,34 @@ runCommands' :: (SomeException -> GHCi Bool) -- Exception handler -> InputT GHCi (Maybe String) -> InputT GHCi () runCommands' eh getCmd = do 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 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 @@ -639,9 +645,63 @@ 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 1 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 -> Int -> InputT GHCi (Maybe String) + -> InputT GHCi (Maybe String) +checkInputForLayout stmt line_number 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 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 checkInputForLayout (stmt++"\n"++str) (line_number+1) getStmt + where goToEnd = do + eof <- Lexer.nextIsEOF + if eof + then Lexer.activeContext + else Lexer.lexer return >> goToEnd enqueueCommands :: [String] -> GHCi () enqueueCommands cmds = do @@ -661,7 +721,7 @@ runStmt stmt step -- 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 + _ <- liftIO $ tryIO $ hFlushAll stdin result <- GhciMonad.runStmt stmt step afterRunStmt (const True) result @@ -890,7 +950,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 @@ -1501,7 +1561,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' @@ -1569,12 +1631,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"