X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2FInteractiveUI.hs;h=2685377500f467c59317f4869d0871f9709dbced;hb=b187c221cc97679e28118ae8ac2997d6a686ba14;hp=278470fb1a9de6202460fa4f07710ea3268e9528;hpb=a852f1dd288c5a34b36a7f8bc21f4a338a19355c;p=ghc-hetmet.git diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 278470f..2685377 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -44,7 +44,6 @@ import Name import SrcLoc -- Other random utilities -import CmdLineParser import Digraph import BasicTypes hiding (isTopLevel) import Panic hiding (showException) @@ -144,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), @@ -218,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" ++ @@ -359,6 +360,7 @@ interactiveUI srcs maybe_exprs = do -- session = session, options = [], prelude = prel_mod, + line_number = 1, break_ctr = 0, breaks = [], tickarrays = emptyModuleEnv, @@ -415,7 +417,7 @@ runGHCi paths maybe_exprs = do -- This would be a good place for runFileInputT. Right hdl -> do runInputTWithPrefs defaultPrefs defaultSettings $ - runCommands $ fileLoop hdl + runCommands False $ fileLoop hdl liftIO (hClose hdl `catchIO` \_ -> return ()) where getDirectory f = case takeDirectory f of "" -> "."; d -> d @@ -450,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 @@ -464,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." @@ -518,7 +520,13 @@ 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 $ tryIO $ hGetLine hdl case l of @@ -530,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 @@ -581,12 +591,15 @@ 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 $ Just False _ -> case fromException e of @@ -598,7 +611,7 @@ runCommands' eh getCmd = do (runOneCommand eh getCmd) case b of Nothing -> return () - Just _ -> runCommands' eh getCmd + Just _ -> runCommands' eh resetLineTo1 getCmd runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String) -> InputT GHCi (Maybe Bool) @@ -655,7 +668,7 @@ runOneCommand eh getCmd = do ml <- lift $ isOptionSet Multiline if ml then do - mb_stmt <- checkInputForLayout stmt 1 getCmd + mb_stmt <- checkInputForLayout stmt getCmd case mb_stmt of Nothing -> return $ Just True Just ml_stmt -> do @@ -667,14 +680,14 @@ runOneCommand eh getCmd = do -- #4316 -- lex the input. If there is an unclosed layout context, request input -checkInputForLayout :: String -> Int -> InputT GHCi (Maybe String) +checkInputForLayout :: String -> InputT GHCi (Maybe String) -> InputT GHCi (Maybe String) -checkInputForLayout stmt line_number getStmt = do +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 1 + 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 @@ -697,7 +710,8 @@ checkInputForLayout stmt line_number getStmt = do Nothing -> return Nothing Just str -> if str == "" then return $ Just stmt - else checkInputForLayout (stmt++"\n"++str) (line_number+1) getStmt + else do + checkInputForLayout (stmt++"\n"++str) getStmt where goToEnd = do eof <- Lexer.nextIsEOF if eof @@ -834,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 @@ -1253,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 () @@ -1562,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'