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)
("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),
" :quit exit GHCi\n" ++
" :reload reload the current module set\n" ++
" :run function [<arguments> ...] run the function with the given arguments\n" ++
+ " :script <filename> run the script <filename>" ++
" :type <expr> show the type of <expr>\n" ++
" :undef <cmd> undefine user-defined command :<cmd>\n" ++
" :!<command> run the shell command <command>\n" ++
-- session = session,
options = [],
prelude = prel_mod,
+ line_number = 1,
break_ctr = 0,
breaks = [],
tickarrays = emptyModuleEnv,
-- 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
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
-- 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."
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
-- 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
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
(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)
ml <- lift $ isOptionSet Multiline
if ml
then do
- mb_stmt <- checkInputForLayout stmt getCmd
+ mb_stmt <- checkInputForLayout stmt getCmd
case mb_stmt of
Nothing -> return $ Just True
Just ml_stmt -> do
-- #4316
-- lex the input. If there is an unclosed layout context, request input
-checkInputForLayout :: String -> InputT GHCi (Maybe String)
+checkInputForLayout :: String -> InputT GHCi (Maybe String)
-> InputT GHCi (Maybe String)
checkInputForLayout stmt getStmt = do
dflags' <- lift $ getDynFlags
Nothing -> return Nothing
Just str -> if str == ""
then return $ Just stmt
- else checkInputForLayout (stmt++"\n"++str) getStmt
+ else do
+ checkInputForLayout (stmt++"\n"++str) getStmt
where goToEnd = do
eof <- Lexer.nextIsEOF
if eof
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
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 <filename>")
+
+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 ()
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'
projects / ghc-hetmet.git / blobdiff