X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=8a20fb1b991d1075813b7052beb490057f48a529;hb=472bbd6cf5bef4398a851a720f32084cdd85d974;hp=9e9c2620526bc3e2b2bb171d01783e6b27ca6608;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 9e9c262..8a20fb1 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -26,14 +26,14 @@ import TcType ( tidyTopType ) import qualified Id ( setIdType ) import IdInfo ( GlobalIdDetails(..) ) import Linker ( HValue, extendLinkEnv, withExtendedLinkEnv,initDynLinker ) -import PrelNames ( breakpointJumpName ) +import PrelNames ( breakpointJumpName, breakpointCondJumpName ) #endif -- The GHC interface import qualified GHC -import GHC ( Session, verbosity, dopt, DynFlag(..), Target(..), +import GHC ( Session, dopt, DynFlag(..), Target(..), TargetId(..), DynFlags(..), - pprModule, Type, Module, SuccessFlag(..), + pprModule, Type, Module, ModuleName, SuccessFlag(..), TyThing(..), Name, LoadHowMuch(..), Phase, GhcException(..), showGhcException, CheckedModule(..), SrcLoc ) @@ -45,7 +45,6 @@ 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 ) @@ -67,6 +66,7 @@ import System.Posix #endif #else import GHC.ConsoleHandler ( flushConsole ) +import System.Win32 ( setConsoleCP, setConsoleOutputCP ) #endif #ifdef USE_READLINE @@ -94,7 +94,6 @@ import System.IO.Error as IO import Data.Char import Control.Monad as Monad import Foreign.StablePtr ( newStablePtr ) -import Text.Printf import GHC.Exts ( unsafeCoerce# ) import GHC.IOBase ( IOErrorType(InvalidArgument) ) @@ -209,6 +208,11 @@ printScopeMsg session location ids nest 2 (pprWithCommas showId ids) where showId id = ppr (idName id) <+> dcolon <+> ppr (idType id) +jumpCondFunction :: Session -> Int -> [HValue] -> String -> Bool -> b -> b +jumpCondFunction session ptr hValues location True b = b +jumpCondFunction session ptr hValues location False b + = jumpFunction session ptr hValues location b + jumpFunction :: Session -> Int -> [HValue] -> String -> b -> b jumpFunction session@(Session ref) (I# idsPtr) hValues location b = unsafePerformIO $ @@ -235,13 +239,16 @@ jumpFunction session@(Session ref) (I# idsPtr) hValues location b 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 withExtendedLinkEnv (zip names hValues) $ - startGHCi (runGHCi [] Nothing) + startGHCi (interactiveLoop is_tty True) GHCiState{ progname = "", args = [], prompt = location++"> ", session = session, - options = [] } + options = [], + prelude = prel_mod } writeIORef ref hsc_env putStrLn $ "Returning to normal execution..." return b @@ -251,7 +258,8 @@ interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO () interactiveUI session srcs maybe_expr = do #if defined(GHCI) && defined(BREAKPOINT) initDynLinker =<< GHC.getSessionDynFlags session - extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))] + extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session)) + ,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))] #endif -- HACK! If we happen to get into an infinite loop (eg the user -- types 'let x=x in x' at the prompt), then the thread will block @@ -276,7 +284,8 @@ interactiveUI session srcs maybe_expr = do 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 @@ -297,7 +306,8 @@ interactiveUI session srcs maybe_expr = do args = [], prompt = "%s> ", session = session, - options = [] } + options = [], + prelude = prel_mod } #ifdef USE_READLINE Readline.resetTerminal Nothing @@ -305,6 +315,8 @@ interactiveUI session srcs maybe_expr = do 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 @@ -355,8 +367,8 @@ runGHCi paths maybe_expr = do 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, @@ -367,6 +379,9 @@ runGHCi paths maybe_expr = do | 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 @@ -454,13 +469,13 @@ fileLoop hdl show_prompt = 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 @@ -512,7 +527,7 @@ runCommand c = ghciHandle handler (doCommand c) 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 @@ -743,9 +758,9 @@ defineMacro s = do 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) @@ -796,7 +811,7 @@ loadModule' files = do 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 @@ -805,7 +820,7 @@ checkModule m = do case 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) @@ -821,21 +836,23 @@ reloadModule "" = do 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))]) + 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) @@ -852,7 +869,7 @@ setContextAfterLoad session ms = do (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 @@ -861,17 +878,19 @@ setContextAfterLoad session ms = do 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))) @@ -938,8 +957,9 @@ createTagsFile session tagskind tagFile = do 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, @@ -1027,8 +1047,7 @@ browseCmd m = 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")) @@ -1036,7 +1055,8 @@ browseModule m exports_only = do -- 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) @@ -1077,47 +1097,53 @@ setContext str 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' @@ -1345,7 +1371,7 @@ completeModule w = do 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 @@ -1381,9 +1407,9 @@ getCommonPrefix (s:ss) = foldl common s ss | 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 @@ -1406,7 +1432,8 @@ data GHCiState = GHCiState args :: [String], prompt :: String, session :: GHC.Session, - options :: [GHCiOption] + options :: [GHCiOption], + prelude :: Module } data GHCiOption @@ -1433,6 +1460,7 @@ setGHCiState s = GHCi $ \r -> writeIORef r s -- 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" @@ -1521,7 +1549,7 @@ revertCAFs = do foreign import ccall "revertCAFs" rts_revertCAFs :: IO () -- Make it "safe", just in case --- ----------------------------------------------------------------------------- +-- ---------------------------------------------------------------------------- -- Utils expandPath :: String -> GHCi String @@ -1532,3 +1560,27 @@ expandPath path = 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 ()