Ghc, handleSourceError )
import PprTyThing
import DynFlags
+import qualified Lexer
+import StringBuffer
import Packages
-- import PackageConfig
import UniqFM
-import HscTypes ( implicitTyThings, handleFlagWarnings )
+import HscTypes ( handleFlagWarnings )
+import HsImpExp
import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
-import Outputable hiding (printForUser, printForUserPartWay)
+import RdrName (RdrName)
+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
("kind", keepGoing' kindOfType, completeIdentifier),
("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),
("list", keepGoing' listCmd, noCompletion),
- ("module", keepGoing setContext, completeModule),
+ ("module", keepGoing moduleCmd, completeSetModule),
("main", keepGoing runMain, completeFilename),
("print", keepGoing printCmd, completeExpression),
("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.
#endif
-- initial context is just the Prelude
- prel_mod <- GHC.lookupModule (GHC.mkModuleName "Prelude") Nothing
- GHC.setContext [] [prel_mod]
+ let prel_mn = GHC.mkModuleName "Prelude"
+ GHC.setContext [] [simpleImportDecl prel_mn]
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,
+ prelude = prel_mn,
+ 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")
- app_user_dir = io $ withGhcAppData
+ app_user_dir = liftIO $ withGhcAppData
(\dir -> return (Just (dir </> "ghci.conf")))
(return Nothing)
home_dir = do
- either_dir <- io $ IO.try (getEnv "HOME")
+ either_dir <- liftIO $ tryIO (getEnv "HOME")
case either_dir of
Right home -> return (Just (home </> ".ghci"))
_ -> return Nothing
+ canonicalizePath' :: FilePath -> IO (Maybe FilePath)
+ canonicalizePath' fp = liftM Just (canonicalizePath fp)
+ `catchIO` \_ -> return Nothing
+
sourceConfigFile :: FilePath -> GHCi ()
sourceConfigFile file = do
- exists <- io $ doesFileExist file
+ exists <- liftIO $ doesFileExist file
when exists $ do
- dir_ok <- io $ checkPerms (getDirectory file)
- file_ok <- io $ checkPerms file
+ dir_ok <- liftIO $ checkPerms (getDirectory file)
+ file_ok <- liftIO $ checkPerms file
when (dir_ok && file_ok) $ do
- either_hdl <- io $ 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
- setLogAction
- 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
when (read_dot_files) $ do
- cfgs0 <- sequence [ current_dir, app_user_dir, home_dir ]
- cfgs <- io $ mapM canonicalizePath (catMaybes cfgs0)
- mapM_ sourceConfigFile (nub cfgs)
+ mcfgs0 <- sequence [ current_dir, app_user_dir, home_dir ]
+ mcfgs <- liftIO $ mapM canonicalizePath' (catMaybes mcfgs0)
+ mapM_ sourceConfigFile $ nub $ catMaybes mcfgs
-- nub, because we don't want to read .ghci twice if the
-- CWD is $HOME.
filePaths' <- mapM (Encoding.decode . BS.pack) filePaths
loadModule (zip filePaths' phases)
when (isJust maybe_exprs && failed ok) $
- io (exitWith (ExitFailure 1))
+ liftIO (exitWith (ExitFailure 1))
-- if verbosity is greater than 0, or we are connected to a
-- terminal, display the prompt in the interactive loop.
- is_tty <- io (hIsTerminalDevice stdin)
+ is_tty <- liftIO (hIsTerminalDevice stdin)
dflags <- getDynFlags
let show_prompt = verbosity dflags > 0 || is_tty
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
let handle e = do st <- getGHCiState
+ -- flush the interpreter's stdout/stderr on exit (#3890)
+ flushInterpBuffers
-- Jump through some hoops to get the
-- current progname in the exception text:
-- <progname>: <exception>
- io $ withProgName (progname st)
+ liftIO $ withProgName (progname st)
-- this used to be topHandlerFastExit, see #2228
- $ topHandler e
+ $ topHandler e
runInputTWithPrefs defaultPrefs defaultSettings $ do
- setLogAction
- runCommands' handle (return Nothing)
+ runCommands' handle True (return Nothing)
-- and finally, exit
- io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
+ liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
runGHCiInput :: InputT GHCi a -> GHCi a
runGHCiInput f = do
- histFile <- io $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))
- (return Nothing)
+ histFile <- liftIO $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))
+ (return Nothing)
let settings = setComplete ghciCompleteWord
$ defaultSettings {historyFile = histFile}
- runInputT settings $ do
- setLogAction
- f
+ runInputT settings f
nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
nextInputLine show_prompt is_tty
putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
return False
else do
- let mode = fileMode st
+ let mode = System.Posix.fileMode st
if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
|| (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
then do
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
- (toplevs,exports) <- GHC.getContext
+ (toplevs,imports) <- GHC.getContext
resumes <- GHC.getResumeContext
-- st <- getGHCiState
dots | _:rs <- resumes, not (null rs) = text "... "
| otherwise = empty
-
-
modules_bit =
-- ToDo: maybe...
-- let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
-- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
-- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+>
hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
- hsep (map (ppr . GHC.moduleName) exports)
+ hsep (map ppr (nub (map ideclName imports)))
deflt_prompt = dots <> context_bit <> modules_bit
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
- b <- handleGhcException (\e -> case e of
- Interrupted -> return False
- _other -> liftIO (print e) >> return True)
+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
+ Just ghc_e ->
+ do liftIO (print (ghc_e :: GhcException))
+ 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.printExceptionAndWarnings err
- return False
+ GHC.printException err
+ return $ Just True
noSpace q = q >>= maybe (return Nothing)
(\c->case removeSpaces c of
maybe (liftIO (ioError collectError))
(\l->if removeSpaces l == ":}"
then return (Just $ removeSpaces c)
- else collectCommand q (c++map normSpace l))
+ else collectCommand q (c ++ "\n" ++ map normSpace l))
where normSpace '\r' = ' '
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 = mkRealSrcLoc (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
runStmt :: String -> SingleStep -> GHCi Bool
runStmt stmt step
- | null (filter (not.isSpace) stmt) = return False
- | ["import", mod] <- words stmt = keepGoing' setContext ('+':mod)
+ | null (filter (not.isSpace) stmt)
+ = return False
+ | "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
_ -> return ()
flushInterpBuffers
- io installSignalHandlers
+ liftIO installSignalHandlers
b <- isOptionSet RevertCAFs
when b revertCAFs
Just c -> return $ GotCommand c
Nothing -> return NoLastCommand
lookupCommand str = do
- mc <- io $ lookupCommand' str
+ mc <- liftIO $ lookupCommand' str
st <- getGHCiState
setGHCiState st{ last_command = mc }
return $ case mc of
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
noArgs :: GHCi () -> String -> GHCi ()
noArgs m "" = m
-noArgs _ _ = io $ putStrLn "This command takes no arguments"
+noArgs _ _ = liftIO $ putStrLn "This command takes no arguments"
help :: String -> GHCi ()
-help _ = io (putStr helpText)
+help _ = liftIO (putStr helpText)
info :: String -> InputT GHCi ()
info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
-info s = handleSourceError GHC.printExceptionAndWarnings $ do
- { let names = words s
+info s = handleSourceError GHC.printException $
+ do { let names = words s
; dflags <- getDynFlags
; let pefas = dopt Opt_PrintExplicitForalls dflags
; mapM_ (infoThing pefas) names }
mb_stuffs <- mapM GHC.getInfo names
let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
unqual <- GHC.getPrintUnqual
- outputStrLn $ showSDocForUser unqual $
+ liftIO $ putStrLn $ showSDocForUser unqual $
vcat (intersperse (text "") $
map (pprInfo pefas) filtered)
-- constructor in the same type
filterOutChildren :: (a -> TyThing) -> [a] -> [a]
filterOutChildren get_thing xs
- = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
+ = filterOut has_parent xs
where
- implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
+ all_names = mkNameSet (map (getName . get_thing) xs)
+ has_parent x = case pprTyThingParent_maybe (get_thing x) of
+ Just p -> getName p `elemNameSet` all_names
+ Nothing -> False
pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
pprInfo pefas (thing, fixity, insts)
runMain :: String -> GHCi ()
runMain s = case toArgs s of
- Left err -> io (hPutStrLn stderr err)
+ Left err -> liftIO (hPutStrLn stderr err)
Right args ->
do dflags <- getDynFlags
case mainFunIs dflags of
runRun :: String -> GHCi ()
runRun s = case toCmdArgs s of
- Left err -> io (hPutStrLn stderr err)
+ Left err -> liftIO (hPutStrLn stderr err)
Right (cmd, args) -> doWithArgs args cmd
doWithArgs :: [String] -> String -> GHCi ()
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
changeDirectory dir = do
graph <- GHC.getModuleGraph
when (not (null graph)) $
- outputStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
+ liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed."
prev_context <- GHC.getContext
GHC.setTargets []
_ <- GHC.load LoadAllTargets
trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
trySuccess act =
- handleSourceError (\e -> do GHC.printExceptionAndWarnings e
+ handleSourceError (\e -> do GHC.printException e
return Failed) $ do
act
let cmd = editor st
when (null cmd)
$ ghcError (CmdLineError "editor not set, use :set editor")
- _ <- io $ system (cmd ++ ' ':file)
+ _ <- liftIO $ system (cmd ++ ' ':file)
return ()
-- The user didn't specify a file so we pick one for them.
defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
defineMacro _ (':':_) =
- io $ putStrLn "macro name cannot start with a colon"
+ liftIO $ putStrLn "macro name cannot start with a colon"
defineMacro overwrite s = do
let (macro_name, definition) = break isSpace s
- macros <- io (readIORef macros_ref)
+ macros <- liftIO (readIORef macros_ref)
let defined = map cmdName macros
if (null macro_name)
then if null defined
- then io $ putStrLn "no macros defined"
- else io $ putStr ("the following macros are defined:\n" ++
- unlines defined)
+ then liftIO $ putStrLn "no macros defined"
+ else liftIO $ putStr ("the following macros are defined:\n" ++
+ unlines defined)
else do
if (not overwrite && macro_name `elem` defined)
then ghcError (CmdLineError
let new_expr = '(' : definition ++ ") :: String -> IO String"
-- compile the expression
- handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
+ handleSourceError (\e -> GHC.printException e) $
+ do
hv <- GHC.compileExpr new_expr
- io (writeIORef macros_ref --
- (filtered ++ [(macro_name, lift . runMacro hv, noCompletion)]))
+ liftIO (writeIORef macros_ref --
+ (filtered ++ [(macro_name, lift . runMacro hv, noCompletion)]))
runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
runMacro fun s = do
- str <- io ((unsafeCoerce# fun :: String -> IO String) s)
+ str <- liftIO ((unsafeCoerce# fun :: String -> IO String) s)
-- make sure we force any exceptions in the result, while we are still
-- inside the exception handler for commands:
seqList str (return ())
undefineMacro :: String -> GHCi ()
undefineMacro str = mapM_ undef (words str)
where undef macro_name = do
- cmds <- io (readIORef macros_ref)
+ cmds <- liftIO (readIORef macros_ref)
if (macro_name `notElem` map cmdName cmds)
then ghcError (CmdLineError
("macro '" ++ macro_name ++ "' is not defined"))
else do
- io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
+ liftIO (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
cmdCmd :: String -> GHCi ()
cmdCmd str = do
let expr = '(' : str ++ ") :: IO String"
- handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
+ handleSourceError (\e -> GHC.printException e) $
+ do
hv <- GHC.compileExpr expr
- cmds <- io $ (unsafeCoerce# hv :: IO String)
+ cmds <- liftIO $ (unsafeCoerce# hv :: IO String)
enqueueCommands (lines cmds)
return ()
+loadModuleName :: GHC.GhcMonad m => ImportDecl RdrName -> m Module
+loadModuleName = flip GHC.findModule Nothing . unLoc . ideclName
+
loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
loadModule fs = timeIt (loadModule' fs)
checkModule m = do
let modl = GHC.mkModuleName m
prev_context <- GHC.getContext
- ok <- handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return False) $ do
+ ok <- handleSourceError (\e -> GHC.printException e >> return False) $ do
r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
- outputStrLn (showSDoc (
+ liftIO $ putStrLn $ showSDoc $
case GHC.moduleInfo r of
cm | Just scope <- GHC.modInfoTopLevelScope cm ->
let
in
(text "global names: " <+> ppr global) $$
(text "local names: " <+> ppr local)
- _ -> empty))
+ _ -> empty
return True
afterLoad (successIf ok) False prev_context
else LoadUpTo (GHC.mkModuleName m)
return ()
-doLoad :: Bool -> ([Module],[Module]) -> LoadHowMuch -> InputT GHCi SuccessFlag
+doLoad :: Bool -> ([Module],[ImportDecl RdrName]) -> LoadHowMuch -> InputT GHCi SuccessFlag
doLoad retain_context prev_context howmuch = do
-- turn off breakpoints before we load: we can't turn them off later, because
-- the ModBreaks will have gone away.
afterLoad ok retain_context prev_context
return ok
-afterLoad :: SuccessFlag -> Bool -> ([Module],[Module]) -> InputT GHCi ()
+afterLoad :: SuccessFlag -> Bool -> ([Module],[ImportDecl RdrName]) -> InputT GHCi ()
afterLoad ok retain_context prev_context = do
lift revertCAFs -- always revert CAFs on load.
lift discardTickArrays
lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries
-setContextAfterLoad :: ([Module],[Module]) -> Bool -> [GHC.ModSummary] -> GHCi ()
+setContextAfterLoad :: ([Module],[ImportDecl RdrName]) -> Bool -> [GHC.ModSummary] -> GHCi ()
setContextAfterLoad prev keep_ctxt [] = do
prel_mod <- getPrelude
- setContextKeepingPackageModules prev keep_ctxt ([], [prel_mod])
+ setContextKeepingPackageModules prev keep_ctxt ([], [simpleImportDecl prel_mod])
setContextAfterLoad prev keep_ctxt ms = do
-- load a target if one is available, otherwise load the topmost module.
targets <- GHC.getTargets
if b then setContextKeepingPackageModules prev keep_ctxt ([m], [])
else do
prel_mod <- getPrelude
- setContextKeepingPackageModules prev keep_ctxt ([],[prel_mod,m])
+ setContextKeepingPackageModules prev keep_ctxt
+ ([], [simpleImportDecl prel_mod,
+ simpleImportDecl (GHC.moduleName m)])
-- | Keep any package modules (except Prelude) when changing the context.
setContextKeepingPackageModules
- :: ([Module],[Module]) -- previous context
+ :: ([Module],[ImportDecl RdrName]) -- previous context
-> Bool -- re-execute :module commands
- -> ([Module],[Module]) -- new context
+ -> ([Module],[ImportDecl RdrName]) -- new context
-> GHCi ()
setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do
- let (_,bs0) = prev_context
+ let (_,imports0) = prev_context
prel_mod <- getPrelude
- let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0
- let bs1 = if null as then nub (prel_mod : bs) else bs
- GHC.setContext as (nub (bs1 ++ pkg_modules))
+ -- filter everything, not just lefts
+
+ let is_pkg_mod i
+ | unLoc (ideclName i) == prel_mod = return False
+ | otherwise = do
+ e <- gtry $ GHC.findModule (unLoc (ideclName i)) (ideclPkgQual i)
+ case e :: Either SomeException Module of
+ Left _ -> return False
+ Right m -> return (not (isHomeModule m))
+
+ pkg_modules <- filterM is_pkg_mod imports0
+
+ let bs1 = if null as
+ then nubBy sameMod (simpleImportDecl prel_mod : bs)
+ else bs
+
+ GHC.setContext as (nubBy sameMod (bs1 ++ pkg_modules))
if keep_ctxt
then do
st <- getGHCiState
- mapM_ (playCtxtCmd False) (remembered_ctx st)
+ playCtxtCmds False (remembered_ctx st)
else do
st <- getGHCiState
setGHCiState st{ remembered_ctx = [] }
isHomeModule :: Module -> Bool
isHomeModule mod = GHC.modulePackageId mod == mainPackageId
+sameMod :: ImportDecl RdrName -> ImportDecl RdrName -> Bool
+sameMod x y = unLoc (ideclName x) == unLoc (ideclName y)
+
modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> InputT GHCi ()
modulesLoadedMsg ok mods = do
dflags <- getDynFlags
punctuate comma (map ppr mods)) <> text "."
case ok of
Failed ->
- outputStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas))
+ liftIO $ putStrLn $ showSDoc (text "Failed, modules loaded: " <> mod_commas)
Succeeded ->
- outputStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas))
+ liftIO $ putStrLn $ showSDoc (text "Ok, modules loaded: " <> mod_commas)
typeOfExpr :: String -> InputT GHCi ()
typeOfExpr str
- = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
+ = handleSourceError GHC.printException
+ $ do
ty <- GHC.exprType str
dflags <- getDynFlags
let pefas = dopt Opt_PrintExplicitForalls dflags
- printForUser' $ sep [text str, nest 2 (dcolon <+> pprTypeForUser pefas ty)]
+ printForUser $ sep [text str, nest 2 (dcolon <+> pprTypeForUser pefas ty)]
kindOfType :: String -> InputT GHCi ()
kindOfType str
- = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
+ = handleSourceError GHC.printException
+ $ do
ty <- GHC.typeKind str
- printForUser' $ text str <+> dcolon <+> ppr ty
+ printForUser $ text str <+> dcolon <+> ppr ty
quit :: String -> InputT GHCi Bool
quit _ = return True
shellEscape :: String -> GHCi Bool
-shellEscape str = io (system str >> return False)
+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
-- recently-added module occurs last, it seems.
case (as,bs) of
(as@(_:_), _) -> browseModule bang (last as) True
- ([], bs@(_:_)) -> browseModule bang (last bs) True
- ([], []) -> ghcError (CmdLineError ":browse: no current module")
+ ([], bs@(_:_)) -> do
+ let i = last bs
+ m <- GHC.findModule (unLoc (ideclName i)) (ideclPkgQual i)
+ browseModule bang m True
+ ([], []) -> ghcError (CmdLineError ":browse: no current module")
_ -> ghcError (CmdLineError "syntax: :browse <module>")
-- without bang, show items in context of their parents and omit children
-- just so we can get an appropriate PrintUnqualified
(as,bs) <- GHC.getContext
prel_mod <- lift getPrelude
- if exports_only then GHC.setContext [] [prel_mod,modl]
+ if exports_only then GHC.setContext [] [simpleImportDecl prel_mod,
+ simpleImportDecl (GHC.moduleName modl)]
else GHC.setContext [modl] []
target_unqual <- GHC.getPrintUnqual
GHC.setContext as bs
let prettyThings = map (pretty pefas) things
prettyThings' | bang = annotate $ zip modNames prettyThings
| otherwise = prettyThings
- outputStrLn $ showSDocForUser unqual (vcat prettyThings')
+ liftIO $ putStrLn $ showSDocForUser unqual (vcat prettyThings')
-- ToDo: modInfoInstances currently throws an exception for
-- package modules. When it works, we can do this:
-- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
-----------------------------------------------------------------------------
-- Setting the module context
-setContext :: String -> GHCi ()
-setContext str
- | all sensible strs = do
- playCtxtCmd True (cmd, as, bs)
- st <- getGHCiState
- setGHCiState st{ remembered_ctx = remembered_ctx st ++ [(cmd,as,bs)] }
+newContextCmd :: CtxtCmd -> GHCi ()
+newContextCmd cmd = do
+ playCtxtCmds True [cmd]
+ st <- getGHCiState
+ let cmds = remembered_ctx st
+ setGHCiState st{ remembered_ctx = cmds ++ [cmd] }
+
+moduleCmd :: String -> GHCi ()
+moduleCmd str
+ | all sensible strs = newContextCmd cmd
| otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
where
- (cmd, strs, as, bs) =
+ (cmd, strs) =
case str of
'+':stuff -> rest AddModules stuff
'-':stuff -> rest RemModules stuff
stuff -> rest SetContext stuff
- rest cmd stuff = (cmd, strs, as, bs)
+ rest cmd stuff = (cmd as bs, strs)
where strs = words stuff
(as,bs) = partitionWith starred strs
starred ('*':m) = Left m
starred m = Right m
-playCtxtCmd :: Bool -> (CtxtCmd, [String], [String]) -> GHCi ()
-playCtxtCmd fail (cmd, as, bs)
- = do
- (as',bs') <- do_checks fail
- (prev_as,prev_bs) <- GHC.getContext
- (new_as, new_bs) <-
- case cmd of
- SetContext -> do
+type Context = ([GHC.Module], [GHC.ImportDecl GHC.RdrName])
+
+playCtxtCmds :: Bool -> [CtxtCmd] -> GHCi ()
+playCtxtCmds fail cmds = do
+ ctx <- GHC.getContext
+ (as,bs) <- foldM (playCtxtCmd fail) ctx cmds
+ GHC.setContext as bs
+
+playCtxtCmd:: Bool -> Context -> CtxtCmd -> GHCi Context
+playCtxtCmd fail (prev_as, prev_bs) cmd = do
+ case cmd of
+ SetContext as bs -> do
+ (as',bs') <- do_checks as bs
prel_mod <- getPrelude
- let bs'' = if null as && prel_mod `notElem` bs' then prel_mod:bs'
- else bs'
- return (as',bs'')
- AddModules -> do
- let as_to_add = as' \\ (prev_as ++ prev_bs)
- bs_to_add = bs' \\ (prev_as ++ prev_bs)
- return (prev_as ++ as_to_add, prev_bs ++ bs_to_add)
- RemModules -> do
- let new_as = prev_as \\ (as' ++ bs')
- new_bs = prev_bs \\ (as' ++ bs')
+ let bs'' = if null as && prel_mod `notElem` bs'
+ then prel_mod : bs'
+ else bs'
+ return (as', map simpleImportDecl bs'')
+
+ AddModules as bs -> do
+ (as',bs') <- do_checks as bs
+ let (remaining_as, remaining_bs) =
+ prev_without (map moduleName as' ++ bs')
+ return (remaining_as ++ as', remaining_bs ++ map simpleImportDecl bs')
+
+ RemModules as bs -> do
+ (as',bs') <- do_checks as bs
+ let (new_as, new_bs) = prev_without (map moduleName as' ++ bs')
return (new_as, new_bs)
- GHC.setContext new_as new_bs
+
+ Import str -> do
+ m_idecl <- maybe_fail $ GHC.parseImportDecl str
+ case m_idecl of
+ Nothing -> return (prev_as, prev_bs)
+ Just idecl -> do
+ m_mdl <- maybe_fail $ loadModuleName idecl
+ case m_mdl of
+ Nothing -> return (prev_as, prev_bs)
+ Just _ -> return (prev_as, prev_bs ++ [idecl])
+ -- we don't filter the module out of the old declarations,
+ -- because 'import' is supposed to be cumulative.
where
- do_checks True = do
- as' <- mapM wantInterpretedModule as
- bs' <- mapM lookupModule bs
- return (as',bs')
- do_checks False = do
- as' <- mapM (trymaybe . wantInterpretedModule) as
- bs' <- mapM (trymaybe . lookupModule) bs
- return (catMaybes as', catMaybes bs')
-
- trymaybe m = do
- r <- ghciTry m
- case r of
- Left _ -> return Nothing
- Right a -> return (Just a)
+ maybe_fail | fail = liftM Just
+ | otherwise = trymaybe
+
+ prev_without names = (as',bs')
+ where as' = deleteAllBy sameModName prev_as names
+ bs' = deleteAllBy importsSameMod prev_bs names
+
+ do_checks as bs = do
+ as' <- mapM (maybe_fail . wantInterpretedModule) as
+ bs' <- mapM (maybe_fail . liftM moduleName . lookupModule) bs
+ return (catMaybes as', catMaybes bs')
+
+ sameModName a b = moduleName a == b
+ importsSameMod a b = unLoc (ideclName a) == b
+
+ deleteAllBy :: (a -> b -> Bool) -> [a] -> [b] -> [a]
+ deleteAllBy f as bs = filter (\a-> not (any (f a) bs)) as
+
+trymaybe ::GHCi a -> GHCi (Maybe a)
+trymaybe m = do
+ r <- ghciTry m
+ case r of
+ Left _ -> return Nothing
+ Right a -> return (Just a)
----------------------------------------------------------------------------
-- Code for `:set'
setCmd ""
= do st <- getGHCiState
let opts = options st
- io $ putStrLn (showSDoc (
+ liftIO $ putStrLn (showSDoc (
text "options currently set: " <>
if null opts
then text "none."
else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
))
dflags <- getDynFlags
- io $ putStrLn (showSDoc (
+ liftIO $ putStrLn (showSDoc (
vcat (text "GHCi-specific dynamic flag settings:"
:map (flagSetting dflags) ghciFlags)
))
- io $ putStrLn (showSDoc (
+ liftIO $ putStrLn (showSDoc (
vcat (text "other dynamic, non-language, flag settings:"
- :map (flagSetting dflags) nonLanguageDynFlags)
+ :map (flagSetting dflags) others)
))
where flagSetting dflags (str, f, _)
| dopt f dflags = text " " <> text "-f" <> text str
| otherwise = text " " <> text "-fno-" <> text str
(ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags)
DynFlags.fFlags
- nonLanguageDynFlags = filterOut (\(_, f, _) -> f `elem` languageOptions)
- others
flags = [Opt_PrintExplicitForalls
,Opt_PrintBindResult
,Opt_BreakOnException
= case getCmd str of
Right ("args", rest) ->
case toArgs rest of
- Left err -> io (hPutStrLn stderr err)
+ Left err -> liftIO (hPutStrLn stderr err)
Right args -> setArgs args
Right ("prog", rest) ->
case toArgs rest of
Right [prog] -> setProg prog
- _ -> io (hPutStrLn stderr "syntax: :set prog <progname>")
+ _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>")
Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest
Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
Right ("stop", rest) -> setStop $ dropWhile isSpace rest
_ -> case toArgs str of
- Left err -> io (hPutStrLn stderr err)
+ Left err -> liftIO (hPutStrLn stderr err)
Right wds -> setOptions wds
setArgs, setOptions :: [String] -> GHCi ()
setPrompt value = do
st <- getGHCiState
if null value
- then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
+ then liftIO $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
else case value of
'\"' : _ -> case reads value of
[(value', xs)] | all isSpace xs ->
setGHCiState (st { prompt = value' })
_ ->
- io $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."
+ liftIO $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."
_ -> setGHCiState (st { prompt = value })
setOptions wds =
newDynFlags minus_opts = do
dflags <- getDynFlags
let pkg_flags = packageFlags dflags
- (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
- handleFlagWarnings dflags' warns
+ (dflags', leftovers, warns) <- liftIO $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
+ 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'
-- and link the new packages.
dflags <- getDynFlags
when (packageFlags dflags /= pkg_flags) $ do
- io $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..."
+ liftIO $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..."
GHC.setTargets []
_ <- GHC.load LoadAllTargets
- io (linkPackages dflags new_pkgs)
+ liftIO (linkPackages dflags new_pkgs)
-- package flags changed, we can't re-use any of the old context
setContextAfterLoad ([],[]) False []
return ()
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 io (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
setOpt str
= case strToGHCiOpt str of
- Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
+ Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))
Just o -> setOption o
unsetOpt str
= case strToGHCiOpt str of
- Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
+ Nothing -> liftIO (putStrLn ("unknown option: '" ++ 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"
showCmd str = do
st <- getGHCiState
case words str of
- ["args"] -> io $ putStrLn (show (args st))
- ["prog"] -> io $ putStrLn (show (progname st))
- ["prompt"] -> io $ putStrLn (show (prompt st))
- ["editor"] -> io $ putStrLn (show (editor st))
- ["stop"] -> io $ putStrLn (show (stop st))
+ ["args"] -> liftIO $ putStrLn (show (args st))
+ ["prog"] -> liftIO $ putStrLn (show (progname st))
+ ["prompt"] -> liftIO $ putStrLn (show (prompt st))
+ ["editor"] -> liftIO $ putStrLn (show (editor st))
+ ["stop"] -> liftIO $ putStrLn (show (stop st))
["modules" ] -> showModules
["bindings"] -> showBindings
- ["linker"] -> io showLinkerState
+ ["linker"] -> liftIO showLinkerState
["breaks"] -> showBkptTable
["context"] -> showContext
["packages"] -> showPackages
showModules = do
loaded_mods <- getLoadedModules
-- we want *loaded* modules only, see #1734
- let show_one ms = do m <- GHC.showModule ms; io (putStrLn m)
+ let show_one ms = do m <- GHC.showModule ms; liftIO (putStrLn m)
mapM_ show_one loaded_mods
getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]
showPackages :: GHCi ()
showPackages = do
pkg_flags <- fmap packageFlags getDynFlags
- io $ putStrLn $ showSDoc $ vcat $
+ liftIO $ putStrLn $ showSDoc $ vcat $
text ("active package flags:"++if null pkg_flags then " none" else "")
: map showFlag pkg_flags
- pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
- io $ putStrLn $ showSDoc $ vcat $
- text "packages currently loaded:"
- : map (nest 2 . text . packageIdString)
- (sortBy (compare `on` packageIdFS) pkg_ids)
where showFlag (ExposePackage p) = text $ " -package " ++ p
showFlag (HidePackage p) = text $ " -hide-package " ++ p
showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
showLanguages :: GHCi ()
showLanguages = do
dflags <- getDynFlags
- io $ putStrLn $ showSDoc $ vcat $
+ liftIO $ putStrLn $ showSDoc $ vcat $
text "active language flags:" :
- [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, dopt f dflags]
+ [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, xopt f dflags]
-- -----------------------------------------------------------------------------
-- Completion
completeCmd, completeMacro, completeIdentifier, completeModule,
+ completeSetModule,
completeHomeModule, completeSetOptions, completeShowOptions,
completeHomeModuleOrFile, completeExpression
:: CompletionFunc GHCi
return $ filter (w `isPrefixOf`)
$ map (showSDoc.ppr) $ loaded_mods ++ pkg_mods
+completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
+ modules <- case m of
+ Just '-' -> do
+ (toplevs, imports) <- GHC.getContext
+ return $ map GHC.moduleName toplevs ++ map (unLoc.ideclName) imports
+ _ -> do
+ dflags <- GHC.getSessionDynFlags
+ let pkg_mods = allExposedModules dflags
+ loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
+ return $ loaded_mods ++ pkg_mods
+ return $ filter (w `isPrefixOf`) $ map (showSDoc.ppr) modules
+
completeHomeModule = wrapIdentCompleter listHomeModules
listHomeModules :: String -> GHCi [String]
wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi
wrapIdentCompleter = wrapCompleter word_break_chars
+wrapIdentCompleterWithModifier :: String -> (Maybe Char -> String -> GHCi [String]) -> CompletionFunc GHCi
+wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing word_break_chars
+ $ \rest -> fmap (map simpleCompletion) . fmap sort . fun (getModifier rest)
+ where
+ getModifier = find (`elem` modifChars)
+
allExposedModules :: DynFlags -> [ModuleName]
allExposedModules dflags
= concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
handler exception = do
flushInterpBuffers
- io installSignalHandlers
+ liftIO installSignalHandlers
ghciHandle handler (showException exception >> return False)
showException :: SomeException -> GHCi ()
showException se =
- io $ case fromException se of
- Just Interrupted -> putStrLn "Interrupted."
- -- omit the location for CmdLineError:
- Just (CmdLineError s) -> putStrLn s
- -- ditto:
- Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "")
- Just other_ghc_ex -> print other_ghc_ex
- Nothing -> putStrLn ("*** Exception: " ++ show se)
+ liftIO $ case fromException se of
+ -- omit the location for CmdLineError:
+ Just (CmdLineError s) -> putStrLn s
+ -- ditto:
+ Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "")
+ Just other_ghc_ex -> print other_ghc_ex
+ Nothing ->
+ case fromException se of
+ Just UserInterrupt -> putStrLn "Interrupted."
+ _ -> putStrLn ("*** Exception: " ++ show se)
-----------------------------------------------------------------------------
-- recursive exception handlers
-> (Name -> m ())
-> m ()
wantNameFromInterpretedModule noCanDo str and_then =
- handleSourceError (GHC.printExceptionAndWarnings) $ do
+ handleSourceError GHC.printException $ do
names <- GHC.parseName str
case names of
[] -> return ()
-- | Returns the span of the largest tick containing the srcspan given
enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
-enclosingTickSpan mod src = do
+enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"
+enclosingTickSpan mod (RealSrcSpan src) = do
ticks <- getTickArray mod
let line = srcSpanStartLine src
ASSERT (inRange (bounds ticks) line) do
- let enclosing_spans = [ span | (_,span) <- ticks ! line
- , srcSpanEnd span >= srcSpanEnd src]
+ let toRealSrcSpan (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"
+ toRealSrcSpan (RealSrcSpan s) = s
+ enclosing_spans = [ span | (_,span) <- ticks ! line
+ , realSrcSpanEnd (toRealSrcSpan span) >= realSrcSpanEnd src]
return . head . sortBy leftmost_largest $ enclosing_spans
traceCmd :: String -> GHCi ()
abandonCmd :: String -> GHCi ()
abandonCmd = noArgs $ do
b <- GHC.abandon -- the prompt will change to indicate the new context
- when (not b) $ io $ putStrLn "There is no computation running."
- return ()
+ when (not b) $ liftIO $ putStrLn "There is no computation running."
deleteCmd :: String -> GHCi ()
deleteCmd argLine = do
deleteSwitch $ words argLine
where
deleteSwitch :: [String] -> GHCi ()
- deleteSwitch [] =
- io $ putStrLn "The delete command requires at least one argument."
+ deleteSwitch [] =
+ liftIO $ putStrLn "The delete command requires at least one argument."
-- delete all break points
deleteSwitch ("*":_rest) = discardActiveBreakPoints
deleteSwitch idents = do
historyCmd arg
| null arg = history 20
| all isDigit arg = history (read arg)
- | otherwise = io $ putStrLn "Syntax: :history [num]"
+ | otherwise = liftIO $ putStrLn "Syntax: :history [num]"
where
history num = do
resumes <- GHC.getResumeContext
case resumes of
- [] -> io $ putStrLn "Not stopped at a breakpoint"
+ [] -> liftIO $ putStrLn "Not stopped at a breakpoint"
(r:_) -> do
let hist = GHC.resumeHistory r
(took,rest) = splitAt num hist
case hist of
- [] -> io $ putStrLn $
+ [] -> liftIO $ putStrLn $
"Empty history. Perhaps you forgot to use :trace?"
_ -> 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)))
- io $ putStrLn $ if null rest then "<end of history>" else "..."
+ liftIO $ putStrLn $ if null rest then "<end of history>" else "..."
bold :: SDoc -> SDoc
bold c | do_bold = text start_bold <> c <> text end_bold
breakSwitch :: [String] -> GHCi ()
breakSwitch [] = do
- io $ putStrLn "The break command requires at least one argument."
+ liftIO $ putStrLn "The break command requires at least one argument."
breakSwitch (arg1:rest)
| looksLikeModuleName arg1 && not (null rest) = do
mod <- wantInterpretedModule arg1
case toplevel of
(mod : _) -> breakByModuleLine mod (read arg1) rest
[] -> do
- io $ putStrLn "Cannot find default module for breakpoint."
- io $ putStrLn "Perhaps no modules are loaded for debugging?"
+ liftIO $ putStrLn "Cannot find default module for breakpoint."
+ liftIO $ putStrLn "Perhaps no modules are loaded for debugging?"
| otherwise = do -- try parsing it as an identifier
wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
- if GHC.isGoodSrcLoc loc
- then ASSERT( isExternalName name )
+ case loc of
+ RealSrcLoc l ->
+ ASSERT( isExternalName name )
findBreakAndSet (GHC.nameModule name) $
- findBreakByCoord (Just (GHC.srcLocFile loc))
- (GHC.srcLocLine loc,
- GHC.srcLocCol loc)
- else noCanDo name $ text "can't find its location: " <> ppr loc
+ findBreakByCoord (Just (GHC.srcLocFile l))
+ (GHC.srcLocLine l,
+ GHC.srcLocCol l)
+ UnhelpfulLoc _ ->
+ noCanDo name $ text "can't find its location: " <> ppr loc
where
noCanDo n why = printForUser $
text "cannot set breakpoint on " <> ppr n <> text ": " <> why
tickArray <- getTickArray mod
(breakArray, _) <- getModBreak mod
case lookupTickTree tickArray of
- Nothing -> io $ putStrLn $ "No breakpoints found at that location."
+ Nothing -> liftIO $ putStrLn $ "No breakpoints found at that location."
Just (tick, span) -> do
- success <- io $ setBreakFlag True breakArray tick
+ success <- liftIO $ setBreakFlag True breakArray tick
if success
then do
(alreadySet, nm) <-
ticks = arr ! line
starts_here = [ tick | tick@(_,span) <- ticks,
- GHC.srcSpanStartLine span == line ]
+ GHC.srcSpanStartLine (toRealSpan span) == line ]
(complete,incomplete) = partition ends_here starts_here
- where ends_here (_,span) = GHC.srcSpanEndLine span == line
+ where ends_here (_,span) = GHC.srcSpanEndLine (toRealSpan span) == line
+ toRealSpan (RealSrcSpan span) = span
+ toRealSpan (UnhelpfulSpan _) = panic "findBreakByLine UnhelpfulSpan"
findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
-> Maybe (BreakIndex,SrcSpan)
is_correct_file span ]
is_correct_file span
- | Just f <- mb_file = GHC.srcSpanFile span == f
+ | Just f <- mb_file = GHC.srcSpanFile (toRealSpan span) == f
| otherwise = True
after_here = [ tick | tick@(_,span) <- ticks,
- GHC.srcSpanStartLine span == line,
- GHC.srcSpanStartCol span >= col ]
+ let span' = toRealSpan span,
+ GHC.srcSpanStartLine span' == line,
+ GHC.srcSpanStartCol span' >= col ]
+
+ toRealSpan (RealSrcSpan span) = span
+ toRealSpan (UnhelpfulSpan _) = panic "findBreakByCoord UnhelpfulSpan"
-- For now, use ANSI bold on terminals that we know support it.
-- Otherwise, we add a line of carets under the active expression instead.
end_bold = "\ESC[0m"
listCmd :: String -> InputT GHCi ()
-listCmd "" = do
+listCmd c = listCmd' c
+
+listCmd' :: String -> InputT GHCi ()
+listCmd' "" = do
mb_span <- lift getCurrentBreakSpan
case mb_span of
Nothing ->
- printForUser' $ text "Not stopped at a breakpoint; nothing to list"
- Just span
- | GHC.isGoodSrcSpan span -> listAround span True
- | otherwise ->
+ printForUser $ text "Not stopped at a breakpoint; nothing to list"
+ Just (RealSrcSpan span) ->
+ listAround span True
+ Just span@(UnhelpfulSpan _) ->
do resumes <- GHC.getResumeContext
case resumes of
[] -> panic "No resumes"
[] -> text "rerunning with :trace,"
_ -> empty
doWhat = traceIt <+> text ":back then :list"
- printForUser' (text "Unable to list source for" <+>
+ printForUser (text "Unable to list source for" <+>
ppr span
$$ text "Try" <+> doWhat)
-listCmd str = list2 (words str)
+listCmd' str = list2 (words str)
list2 :: [String] -> InputT GHCi ()
list2 [arg] | all isDigit arg = do
(toplevel, _) <- GHC.getContext
case toplevel of
- [] -> outputStrLn "No module to list"
+ [] -> liftIO $ putStrLn "No module to list"
(mod : _) -> listModuleLine mod (read arg)
list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
mod <- wantInterpretedModule arg1
list2 [arg] = do
wantNameFromInterpretedModule noCanDo arg $ \name -> do
let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
- if GHC.isGoodSrcLoc loc
- then do
- tickArray <- ASSERT( isExternalName name )
+ case loc of
+ RealSrcLoc l ->
+ do tickArray <- ASSERT( isExternalName name )
lift $ getTickArray (GHC.nameModule name)
- let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
- (GHC.srcLocLine loc, GHC.srcLocCol loc)
+ let mb_span = findBreakByCoord (Just (GHC.srcLocFile l))
+ (GHC.srcLocLine l, GHC.srcLocCol l)
tickArray
case mb_span of
- Nothing -> listAround (GHC.srcLocSpan loc) False
- Just (_,span) -> listAround span False
- else
+ Nothing -> listAround (realSrcLocSpan l) False
+ Just (_, UnhelpfulSpan _) -> panic "list2 UnhelpfulSpan"
+ Just (_, RealSrcSpan span) -> listAround span False
+ UnhelpfulLoc _ ->
noCanDo name $ text "can't find its location: " <>
ppr loc
where
- noCanDo n why = printForUser' $
+ noCanDo n why = printForUser $
text "cannot list source code for " <> ppr n <> text ": " <> why
list2 _other =
- outputStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
+ liftIO $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
listModuleLine :: Module -> Int -> InputT GHCi ()
listModuleLine modl line = do
[] -> panic "listModuleLine"
summ:_ -> do
let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
- loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
- listAround (GHC.srcLocSpan loc) False
+ loc = mkRealSrcLoc (mkFastString (filename)) line 0
+ listAround (realSrcLocSpan loc) False
-- | list a section of a source file around a particular SrcSpan.
-- If the highlight flag is True, also highlight the span using
-- 2) convert the BS to String using utf-string, and write it out.
-- It would be better if we could convert directly between UTF-8 and the
-- console encoding, of course.
-listAround :: MonadIO m => SrcSpan -> Bool -> InputT m ()
+listAround :: MonadIO m => RealSrcSpan -> Bool -> InputT m ()
listAround span do_highlight = do
contents <- liftIO $ BS.readFile (unpackFS file)
let
let output = BS.intercalate (BS.pack "\n") prefixed
utf8Decoded <- liftIO $ BS.useAsCStringLen output
$ \(p,n) -> utf8DecodeString (castPtr p) n
- outputStrLn utf8Decoded
+ liftIO $ putStrLn utf8Decoded
where
file = GHC.srcSpanFile span
line1 = GHC.srcSpanStartLine span
- col1 = GHC.srcSpanStartCol span
+ col1 = GHC.srcSpanStartCol span - 1
line2 = GHC.srcSpanEndLine span
- col2 = GHC.srcSpanEndCol span
+ col2 = GHC.srcSpanEndCol span - 1
pad_before | line1 == 1 = 0
| otherwise = 1
mkTickArray ticks
= accumArray (flip (:)) [] (1, max_line)
[ (line, (nm,span)) | (nm,span) <- ticks,
- line <- srcSpanLines span ]
+ let span' = toRealSpan span,
+ line <- srcSpanLines span' ]
where
- max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
+ max_line = foldr max 0 (map (GHC.srcSpanEndLine . toRealSpan . snd) ticks)
srcSpanLines span = [ GHC.srcSpanStartLine span ..
GHC.srcSpanEndLine span ]
+ toRealSpan (RealSrcSpan span) = span
+ toRealSpan (UnhelpfulSpan _) = panic "mkTickArray UnhelpfulSpan"
lookupModule :: GHC.GhcMonad m => String -> m Module
lookupModule modName
turnOffBreak :: BreakLocation -> GHCi Bool
turnOffBreak loc = do
(arr, _) <- getModBreak (breakModule loc)
- io $ setBreakFlag False arr (breakTick loc)
+ liftIO $ setBreakFlag False arr (breakTick loc)
getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
getModBreak mod = do
setBreakFlag toggle array index
| toggle = GHC.setBreakOn array index
| otherwise = GHC.setBreakOff array index
+
projects / ghc-hetmet.git / blobdiff