--
-- GHC Interactive User Interface
--
--- (c) The GHC Team 2005
+-- (c) The GHC Team 2005-2006
--
-----------------------------------------------------------------------------
module InteractiveUI (
import GHC.Exts ( Int(..), Ptr(..), int2Addr# )
import Foreign.StablePtr ( deRefStablePtr, castPtrToStablePtr )
import System.IO.Unsafe ( unsafePerformIO )
-import Var ( Id, globaliseId, idName, idType )
-import HscTypes ( Session(..), InteractiveContext(..), HscEnv(..)
- , extendTypeEnvWithIds )
-import RdrName ( extendLocalRdrEnv, mkRdrUnqual, lookupLocalRdrEnv )
-import NameEnv ( delListFromNameEnv )
-import TcType ( tidyTopType )
-import qualified Id ( setIdType )
-import IdInfo ( GlobalIdDetails(..) )
-import Linker ( HValue, extendLinkEnv, withExtendedLinkEnv,initDynLinker )
-import PrelNames ( breakpointJumpName, breakpointCondJumpName )
+import Var
+import HscTypes
+import RdrName
+import NameEnv
+import TcType
+import qualified Id
+import IdInfo
+import PrelNames
#endif
-- The GHC interface
import qualified GHC
-import GHC ( Session, verbosity, dopt, DynFlag(..), Target(..),
- TargetId(..), DynFlags(..),
- pprModule, Type, Module, SuccessFlag(..),
- TyThing(..), Name, LoadHowMuch(..), Phase,
- GhcException(..), showGhcException,
- CheckedModule(..), SrcLoc )
-import DynFlags ( allFlags )
-import Packages ( PackageState(..) )
-import PackageConfig ( InstalledPackageInfo(..) )
-import UniqFM ( eltsUFM )
+import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
+ Type, Module, ModuleName, TyThing(..), Phase )
+import DynFlags
+import Packages
+import PackageConfig
+import UniqFM
import PprTyThing
import Outputable
--- for createtags (should these come via GHC?)
-import Module ( moduleString )
-import Name ( nameSrcLoc, nameModule, nameOccName )
-import OccName ( pprOccName )
-import SrcLoc ( isGoodSrcLoc, srcLocFile, srcLocLine, srcLocCol )
+-- for createtags
+import Name
+import OccName
+import SrcLoc
-- Other random utilities
-import Digraph ( flattenSCCs )
-import BasicTypes ( failed, successIf )
-import Panic ( panic, installSignalHandlers )
+import Digraph
+import BasicTypes
+import Panic hiding (showException)
import Config
-import StaticFlags ( opt_IgnoreDotGhci )
-import Linker ( showLinkerState )
-import Util ( removeSpaces, handle, global, toArgs,
- looksLikeModuleName, prefixMatch, sortLe )
+import StaticFlags
+import Linker
+import Util
#ifndef mingw32_HOST_OS
import System.Posix
#endif
#else
import GHC.ConsoleHandler ( flushConsole )
+import System.Win32 ( setConsoleCP, setConsoleOutputCP )
+import qualified System.Win32
#endif
#ifdef USE_READLINE
import Numeric
import Data.List
import Data.Int ( Int64 )
-import Data.Maybe ( isJust, fromMaybe, catMaybes )
+import Data.Maybe ( isJust, isNothing, fromMaybe, catMaybes )
import System.Cmd
import System.CPUTime
import System.Environment
import Data.Char
import Control.Monad as Monad
import Foreign.StablePtr ( newStablePtr )
-import Text.Printf
import GHC.Exts ( unsafeCoerce# )
import GHC.IOBase ( IOErrorType(InvalidArgument) )
("browse", keepGoing browseCmd, False, completeModule),
("cd", keepGoing changeDirectory, False, completeFilename),
("def", keepGoing defineMacro, False, completeIdentifier),
+ ("e", keepGoing editFile, False, completeFilename),
+ -- Hugs users are accustomed to :e, so make sure it doesn't overlap
+ ("edit", keepGoing editFile, False, completeFilename),
("help", keepGoing help, False, completeNone),
("?", keepGoing help, False, completeNone),
("info", keepGoing info, False, completeIdentifier),
" :browse [*]<module> display the names defined by <module>\n" ++
" :cd <dir> change directory to <dir>\n" ++
" :def <cmd> <expr> define a command :<cmd>\n" ++
+ " :edit <file> edit file\n" ++
+ " :edit edit last module\n" ++
" :help, :? display this list of commands\n" ++
" :info [<name> ...] display information about the given names\n" ++
" :load <filename> ... load module(s) and their dependents\n" ++
" :set args <arg> ... set the arguments returned by System.getArgs\n" ++
" :set prog <progname> set the value returned by System.getProgName\n" ++
" :set prompt <prompt> set the prompt used in GHCi\n" ++
+ " :set editor <cmd> set the comand used for :edit\n" ++
"\n" ++
" :show modules show the currently loaded modules\n" ++
" :show bindings show the current bindings made at the prompt\n" ++
"\n" ++
" :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
- " :etags [<file>] create tags file for Emacs (defauilt: \"TAGS\")\n" ++
+ " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
" :type <expr> show the type of <expr>\n" ++
" :kind <type> show the kind of <type>\n" ++
" :undef <cmd> undefine user-defined command :<cmd>\n" ++
new_ic = ictxt { ic_rn_local_env = new_rn_env,
ic_type_env = new_type_env }
writeIORef ref (hsc_env { hsc_IC = new_ic })
+ is_tty <- hIsTerminalDevice stdin
+ prel_mod <- GHC.findModule session prel_name Nothing
+ default_editor <- findEditor
withExtendedLinkEnv (zip names hValues) $
- startGHCi (runGHCi [] Nothing)
+ startGHCi (interactiveLoop is_tty True)
GHCiState{ progname = "<interactive>",
args = [],
prompt = location++"> ",
+ editor = default_editor,
session = session,
- options = [] }
+ options = [],
+ prelude = prel_mod }
writeIORef ref hsc_env
putStrLn $ "Returning to normal execution..."
return b
#endif
+findEditor = do
+ getEnv "EDITOR"
+ `IO.catch` \_ -> do
+#if mingw32_HOST_OS
+ win <- System.Win32.getWindowsDirectory
+ return (win `joinFileName` "notepad.exe")
+#else
+ return ""
+#endif
+
interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
interactiveUI session srcs maybe_expr = do
#if defined(GHCI) && defined(BREAKPOINT)
newStablePtr stdout
newStablePtr stderr
- hFlush stdout
- hSetBuffering stdout NoBuffering
-
-- Initialise buffering for the *interpreted* I/O system
initInterpBuffering session
+ when (isNothing maybe_expr) $ do
+ -- Only for GHCi (not runghc and ghc -e):
+ -- Turn buffering off for the compiled program's stdout/stderr
+ turnOffBuffering
+ -- Turn buffering off for GHCi's stdout
+ hFlush stdout
+ hSetBuffering stdout NoBuffering
-- We don't want the cmd line to buffer any input that might be
-- intended for the program, so unbuffer stdin.
- hSetBuffering stdin NoBuffering
+ hSetBuffering stdin NoBuffering
-- initial context is just the Prelude
- GHC.setContext session [] [prelude_mod]
+ prel_mod <- GHC.findModule session prel_name Nothing
+ GHC.setContext session [] [prel_mod]
#ifdef USE_READLINE
Readline.initialize
Readline.setCompleterWordBreakCharacters word_break_chars
#endif
+ default_editor <- findEditor
+
startGHCi (runGHCi srcs maybe_expr)
GHCiState{ progname = "<interactive>",
args = [],
prompt = "%s> ",
+ editor = default_editor,
session = session,
- options = [] }
+ options = [],
+ prelude = prel_mod }
#ifdef USE_READLINE
Readline.resetTerminal Nothing
return ()
+prel_name = GHC.mkModuleName "Prelude"
+
runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
runGHCi paths maybe_expr = do
let read_dot_files = not opt_IgnoreDotGhci
case maybe_expr of
Nothing ->
-#if defined(mingw32_HOST_OS)
do
+#if defined(mingw32_HOST_OS)
-- The win32 Console API mutates the first character of
-- type-ahead when reading from it in a non-buffered manner. Work
-- around this by flushing the input buffer of type-ahead characters,
| otherwise -> io (ioError err)
Right () -> return ()
#endif
+ -- initialise the console if necessary
+ io setUpConsole
+
-- enter the interactive loop
interactiveLoop is_tty show_prompt
Just expr -> do
l -> do quit <- runCommand l
if quit then return () else fileLoop hdl show_prompt
-stringLoop :: [String] -> GHCi ()
-stringLoop [] = return ()
+stringLoop :: [String] -> GHCi Bool{-True: we quit-}
+stringLoop [] = return False
stringLoop (s:ss) = do
case removeSpaces s of
"" -> stringLoop ss
l -> do quit <- runCommand l
- if quit then return () else stringLoop ss
+ if quit then return True else stringLoop ss
mkPrompt toplevs exports prompt
= showSDoc $ f prompt
f (x:xs) = char x <> f xs
f [] = empty
- perc_s = hsep (map (\m -> char '*' <> pprModule m) toplevs) <+>
- hsep (map pprModule exports)
+ perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
+ hsep (map (ppr . GHC.moduleName) exports)
#ifdef USE_READLINE
runCommandEval c = ghciHandle handleEval (doCommand c)
where
handleEval (ExitException code) = io (exitWith code)
- handleEval e = do showException e
+ handleEval e = do handler e
io (exitWith (ExitFailure 1))
doCommand (':' : command) = specialCommand command
Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
_ -> panic "interactiveUI:flush"
- turnOffBuffering -- Turn it off right now
-
return ()
filterOutChildren :: [Name] -> [Name]
filterOutChildren names = filter (not . parent_is_there) names
where parent_is_there n
- | Just p <- GHC.nameParent_maybe n = p `elem` names
+-- | Just p <- GHC.nameParent_maybe n = p `elem` names
+-- ToDo!!
| otherwise = False
pprInfo exts (thing, fixity, insts)
dir <- expandPath dir
io (setCurrentDirectory dir)
+editFile :: String -> GHCi ()
+editFile str
+ | null str = do
+ -- find the name of the "topmost" file loaded
+ session <- getSession
+ graph0 <- io (GHC.getModuleGraph session)
+ graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
+ let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
+ case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
+ Just file -> do_edit file
+ Nothing -> throwDyn (CmdLineError "unknown file name")
+ | otherwise = do_edit str
+ where
+ do_edit file = do
+ st <- getGHCiState
+ let cmd = editor st
+ when (null cmd) $
+ throwDyn (CmdLineError "editor not set, use :set editor")
+ io $ system (cmd ++ ' ':file)
+ return ()
+
defineMacro :: String -> GHCi ()
defineMacro s = do
let (macro_name, definition) = break isSpace s
case maybe_hv of
Nothing -> return ()
Just hv -> io (writeIORef commands --
- (cmds ++ [(macro_name, keepGoing (runMacro hv), False, completeNone)]))
+ (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
-runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi ()
+runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
runMacro fun s = do
str <- io ((unsafeCoerce# fun :: String -> IO String) s)
stringLoop (lines str)
checkModule :: String -> GHCi ()
checkModule m = do
- let modl = GHC.mkModule m
+ let modl = GHC.mkModuleName m
session <- getSession
result <- io (GHC.checkModule session modl)
case result of
Nothing -> io $ putStrLn "Nothing"
Just r -> io $ putStrLn (showSDoc (
- case checkedModuleInfo r of
+ case GHC.checkedModuleInfo r of
Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
let
- (local,global) = partition ((== modl) . GHC.nameModule) scope
+ (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
in
(text "global names: " <+> ppr global) $$
(text "local names: " <+> ppr local)
reloadModule m = do
io (revertCAFs) -- always revert CAFs on reload.
session <- getSession
- ok <- io (GHC.load session (LoadUpTo (GHC.mkModule m)))
+ ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
afterLoad ok session
afterLoad ok session = do
io (revertCAFs) -- always revert CAFs on load.
graph <- io (GHC.getModuleGraph session)
- graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod) graph
+ graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
setContextAfterLoad session graph'
- modulesLoadedMsg ok (map GHC.ms_mod graph')
+ modulesLoadedMsg ok (map GHC.ms_mod_name graph')
#if defined(GHCI) && defined(BREAKPOINT)
io (extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))
,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))])
#endif
setContextAfterLoad session [] = do
- io (GHC.setContext session [] [prelude_mod])
+ prel_mod <- getPrelude
+ io (GHC.setContext session [] [prel_mod])
setContextAfterLoad session ms = do
-- load a target if one is available, otherwise load the topmost module.
targets <- io (GHC.getTargets session)
(m:_) -> Just m
summary `matches` Target (TargetModule m) _
- = GHC.ms_mod summary == m
+ = GHC.ms_mod_name summary == m
summary `matches` Target (TargetFile f _) _
| Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
summary `matches` target
load_this summary | m <- GHC.ms_mod summary = do
b <- io (GHC.moduleIsInterpreted session m)
if b then io (GHC.setContext session [m] [])
- else io (GHC.setContext session [] [prelude_mod,m])
+ else do
+ prel_mod <- getPrelude
+ io (GHC.setContext session [] [prel_mod,m])
-modulesLoadedMsg :: SuccessFlag -> [Module] -> GHCi ()
+modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
modulesLoadedMsg ok mods = do
dflags <- getDynFlags
when (verbosity dflags > 0) $ do
let mod_commas
| null mods = text "none."
| otherwise = hsep (
- punctuate comma (map pprModule mods)) <> text "."
+ punctuate comma (map ppr mods)) <> text "."
case ok of
Failed ->
io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
is_interpreted <- GHC.moduleIsInterpreted session m
-- should we just skip these?
when (not is_interpreted) $
- throwDyn (CmdLineError ("module '" ++ moduleString m ++ "' is not interpreted"))
-
+ throwDyn (CmdLineError ("module '"
+ ++ GHC.moduleNameString (GHC.moduleName m)
+ ++ "' is not interpreted"))
mbModInfo <- GHC.getModuleInfo session m
let unqual
| Just modinfo <- mbModInfo,
browseModule m exports_only = do
s <- getSession
-
- let modl = GHC.mkModule m
+ modl <- io $ GHC.findModule s (GHC.mkModuleName m) Nothing
is_interpreted <- io (GHC.moduleIsInterpreted s modl)
when (not is_interpreted && not exports_only) $
throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
-- Temporarily set the context to the module we're interested in,
-- just so we can get an appropriate PrintUnqualified
(as,bs) <- io (GHC.getContext s)
- io (if exports_only then GHC.setContext s [] [prelude_mod,modl]
+ prel_mod <- getPrelude
+ io (if exports_only then GHC.setContext s [] [prel_mod,modl]
else GHC.setContext s [modl] [])
unqual <- io (GHC.getPrintUnqual s)
io (GHC.setContext s as bs)
sensible ('*':m) = looksLikeModuleName m
sensible m = looksLikeModuleName m
-newContext mods = do
- session <- getSession
- (as,bs) <- separate session mods [] []
- let bs' = if null as && prelude_mod `notElem` bs then prelude_mod:bs else bs
- io (GHC.setContext session as bs')
-
-separate :: Session -> [String] -> [Module] -> [Module]
- -> GHCi ([Module],[Module])
+separate :: Session -> [String] -> [Module] -> [Module]
+ -> GHCi ([Module],[Module])
separate session [] as bs = return (as,bs)
-separate session (('*':m):ms) as bs = do
- let modl = GHC.mkModule m
- b <- io (GHC.moduleIsInterpreted session modl)
- if b then separate session ms (modl:as) bs
- else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
-separate session (m:ms) as bs = separate session ms as (GHC.mkModule m:bs)
-
-prelude_mod = GHC.mkModule "Prelude"
+separate session (('*':str):ms) as bs = do
+ m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
+ b <- io $ GHC.moduleIsInterpreted session m
+ if b then separate session ms (m:as) bs
+ else throwDyn (CmdLineError ("module '"
+ ++ GHC.moduleNameString (GHC.moduleName m)
+ ++ "' is not interpreted"))
+separate session (str:ms) as bs = do
+ m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
+ separate session ms as (m:bs)
+
+newContext :: [String] -> GHCi ()
+newContext strs = do
+ s <- getSession
+ (as,bs) <- separate s strs [] []
+ prel_mod <- getPrelude
+ let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
+ io $ GHC.setContext s as bs'
-addToContext mods = do
- cms <- getSession
- (as,bs) <- io (GHC.getContext cms)
+addToContext :: [String] -> GHCi ()
+addToContext strs = do
+ s <- getSession
+ (as,bs) <- io $ GHC.getContext s
- (as',bs') <- separate cms mods [] []
+ (new_as,new_bs) <- separate s strs [] []
- let as_to_add = as' \\ (as ++ bs)
- bs_to_add = bs' \\ (as ++ bs)
+ let as_to_add = new_as \\ (as ++ bs)
+ bs_to_add = new_bs \\ (as ++ bs)
- io (GHC.setContext cms (as ++ as_to_add) (bs ++ bs_to_add))
+ io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
-removeFromContext mods = do
- cms <- getSession
- (as,bs) <- io (GHC.getContext cms)
+removeFromContext :: [String] -> GHCi ()
+removeFromContext strs = do
+ s <- getSession
+ (as,bs) <- io $ GHC.getContext s
- (as_to_remove,bs_to_remove) <- separate cms mods [] []
+ (as_to_remove,bs_to_remove) <- separate s strs [] []
let as' = as \\ (as_to_remove ++ bs_to_remove)
bs' = bs \\ (as_to_remove ++ bs_to_remove)
- io (GHC.setContext cms as' bs')
+ io $ GHC.setContext s as' bs'
----------------------------------------------------------------------------
-- Code for `:set'
else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
))
setCmd str
- = case words str of
+ = case toArgs str of
("args":args) -> setArgs args
("prog":prog) -> setProg prog
- ("prompt":prompt) -> setPrompt (dropWhile isSpace $ drop 6 $ dropWhile isSpace str)
+ ("prompt":prompt) -> setPrompt (after 6)
+ ("editor":cmd) -> setEditor (after 6)
wds -> setOptions wds
+ where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
setArgs args = do
st <- getGHCiState
setProg _ = do
io (hPutStrLn stderr "syntax: :set prog <progname>")
+setEditor cmd = do
+ st <- getGHCiState
+ setGHCiState st{ editor = cmd }
+
setPrompt value = do
st <- getGHCiState
if null value
-- then, dynamic flags
dflags <- getDynFlags
+ let pkg_flags = packageFlags dflags
(dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
- setDynFlags dflags'
-
- -- update things if the users wants more packages
-{- TODO:
- let new_packages = pkgs_after \\ pkgs_before
- when (not (null new_packages)) $
- newPackages new_packages
--}
if (not (null leftovers))
then throwDyn (CmdLineError ("unrecognised flags: " ++
unwords leftovers))
else return ()
+ new_pkgs <- setDynFlags dflags'
+
+ -- if the package flags changed, we should reset the context
+ -- and link the new packages.
+ dflags <- getDynFlags
+ when (packageFlags dflags /= pkg_flags) $ do
+ io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
+ session <- getSession
+ io (GHC.setTargets session [])
+ io (GHC.load session LoadAllTargets)
+ io (linkPackages dflags new_pkgs)
+ setContextAfterLoad session []
+ return ()
+
unsetOptions :: String -> GHCi ()
unsetOptions str
optToStr ShowType = "t"
optToStr RevertCAFs = "r"
-{- ToDo
-newPackages new_pkgs = do -- The new packages are already in v_Packages
- session <- getSession
- io (GHC.setTargets session [])
- io (GHC.load session Nothing)
- dflags <- getDynFlags
- io (linkPackages dflags new_pkgs)
- setContextAfterLoad []
--}
-
-- ---------------------------------------------------------------------------
-- code for `:show'
completeHomeModule w = do
s <- restoreSession
g <- GHC.getModuleGraph s
- let home_mods = map GHC.ms_mod g
+ let home_mods = map GHC.ms_mod_name g
return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
completeSetOptions w = do
| c == d = c : common cs ds
| otherwise = ""
-allExposedModules :: DynFlags -> [Module]
+allExposedModules :: DynFlags -> [ModuleName]
allExposedModules dflags
- = map GHC.mkModule (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
+ = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
where
pkg_db = pkgIdMap (pkgState dflags)
#else
progname :: String,
args :: [String],
prompt :: String,
+ editor :: String,
session :: GHC.Session,
- options :: [GHCiOption]
+ options :: [GHCiOption],
+ prelude :: Module
}
data GHCiOption
-- for convenience...
getSession = getGHCiState >>= return . session
+getPrelude = getGHCiState >>= return . prelude
GLOBAL_VAR(saved_sess, no_saved_sess, Session)
no_saved_sess = error "no saved_ses"
foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
-- Make it "safe", just in case
--- -----------------------------------------------------------------------------
+-- ----------------------------------------------------------------------------
-- Utils
expandPath :: String -> GHCi String
return (tilde ++ '/':d)
other ->
return other
+
+-- ----------------------------------------------------------------------------
+-- Windows console setup
+
+setUpConsole :: IO ()
+setUpConsole = do
+#ifdef mingw32_HOST_OS
+ -- On Windows we need to set a known code page, otherwise the characters
+ -- we read from the console will be be in some strange encoding, and
+ -- similarly for characters we write to the console.
+ --
+ -- At the moment, GHCi pretends all input is Latin-1. In the
+ -- future we should support UTF-8, but for now we set the code pages
+ -- to Latin-1.
+ --
+ -- It seems you have to set the font in the console window to
+ -- a Unicode font in order for output to work properly,
+ -- otherwise non-ASCII characters are mapped wrongly. sigh.
+ -- (see MSDN for SetConsoleOutputCP()).
+ --
+ setConsoleCP 28591 -- ISO Latin-1
+ setConsoleOutputCP 28591 -- ISO Latin-1
+#endif
+ return ()
projects / ghc-hetmet.git / blobdiff