Ghc, handleSourceError )
import PprTyThing
import DynFlags
+import qualified Lexer
+import StringBuffer
import Packages
-- import PackageConfig
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)
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
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
("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" ++
"\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" ++
findEditor :: IO String
findEditor = do
getEnv "EDITOR"
- `IO.catch` \_ -> do
+ `catchIO` \_ -> do
#if mingw32_HOST_OS
win <- System.Win32.getWindowsDirectory
return (win </> "notepad.exe")
foreign import ccall unsafe "rts_isProfiled" isProfiled :: IO CInt
+default_progname, default_prompt, default_stop :: String
+default_progname = "<interactive>"
+default_prompt = "%s> "
+default_stop = ""
+
+default_args :: [String]
+default_args = []
+
interactiveUI :: [(FilePath, Maybe Phase)] -> Maybe [String]
-> Ghc ()
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.
default_editor <- liftIO $ findEditor
startGHCi (runGHCi srcs maybe_exprs)
- GHCiState{ progname = "<interactive>",
- 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,
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")
(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
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;
-- This would be a good place for runFileInputT.
Right hdl ->
do runInputTWithPrefs defaultPrefs defaultSettings $
- runCommands $ fileLoop hdl
- liftIO (hClose hdl `IO.catch` \_ -> return ())
+ 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 $ IO.try $ hGetLine hdl
+ l <- liftIO $ tryIO $ hGetLine hdl
case l of
Left e | isEOFError e -> return Nothing
| InvalidArgument <- etype -> return Nothing
-- 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 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
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
| "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
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
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
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'
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
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"
projects / ghc-hetmet.git / blobdiff