X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=c9de96ff62864fd1a9a208f0e656873d54719dc3;hb=5c9c3660697f18ae9dcd95e254249d3dd908b94e;hp=9e9c2620526bc3e2b2bb171d01783e6b27ca6608;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 9e9c262..c9de96f 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -26,7 +26,7 @@ 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 @@ -67,6 +67,7 @@ import System.Posix #endif #else import GHC.ConsoleHandler ( flushConsole ) +import System.Win32 ( setConsoleCP, setConsoleOutputCP ) #endif #ifdef USE_READLINE @@ -209,6 +210,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,8 +241,9 @@ 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 withExtendedLinkEnv (zip names hValues) $ - startGHCi (runGHCi [] Nothing) + startGHCi (interactiveLoop is_tty True) GHCiState{ progname = "", args = [], prompt = location++"> ", @@ -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 @@ -355,8 +363,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 +375,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 +465,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 @@ -743,9 +754,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) @@ -831,7 +842,8 @@ afterLoad ok session = do setContextAfterLoad session graph' modulesLoadedMsg ok (map GHC.ms_mod 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 @@ -1521,7 +1533,7 @@ revertCAFs = do foreign import ccall "revertCAFs" rts_revertCAFs :: IO () -- Make it "safe", just in case --- ----------------------------------------------------------------------------- +-- ---------------------------------------------------------------------------- -- Utils expandPath :: String -> GHCi String @@ -1532,3 +1544,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 ()