X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=3ae37f53d04c805a7d708e182e67e0d34dbef544;hb=d2b3daa3cc474e6ab010fb6af5c21ddb852b8b5b;hp=83b59660899d416b12d237e6ac28e6b19f0bfb1e;hpb=da4dda13a3faf2ecc2138d16b7faa79cff264037;p=ghc-hetmet.git diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 83b5966..3ae37f5 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -31,7 +31,7 @@ import UniqFM import HscTypes ( implicitTyThings ) import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC? -import Outputable hiding (printForUser) +import Outputable hiding (printForUser, printForUserPartWay) import Module -- for ModuleEnv import Name import SrcLoc @@ -47,12 +47,12 @@ import Util import NameSet import Maybes ( orElse ) import FastString +import Encoding #ifndef mingw32_HOST_OS import System.Posix hiding (getEnv) #else import GHC.ConsoleHandler ( flushConsole ) -import System.Win32 ( setConsoleCP, setConsoleOutputCP ) import qualified System.Win32 #endif @@ -75,14 +75,13 @@ import System.Exit ( exitWith, ExitCode(..) ) import System.Directory import System.IO import System.IO.Error as IO -import System.IO.Unsafe import Data.Char import Data.Dynamic import Data.Array import Control.Monad as Monad import Text.Printf - -import Foreign.StablePtr ( newStablePtr ) +import Foreign +import Foreign.C ( withCStringLen ) import GHC.Exts ( unsafeCoerce# ) import GHC.IOBase ( IOErrorType(InvalidArgument) ) @@ -98,8 +97,6 @@ ghciWelcomeMsg :: String ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++ ": http://www.haskell.org/ghc/ :? for help" -type Command = (String, String -> GHCi Bool, Bool, String -> IO [String]) - cmdName :: Command -> String cmdName (n,_,_,_) = n @@ -166,10 +163,11 @@ helpText = " Commands available from the prompt:\n" ++ "\n" ++ " evaluate/run \n" ++ + " : repeat last command\n" ++ " :{\\n ..lines.. \\n:}\\n multiline command\n" ++ " :add ... add module(s) to the current target set\n" ++ - " :browse[!] [-s] [[*]] display the names defined by module \n" ++ - " (!: more details; -s: sort; *: all top-level names)\n" ++ + " :browse[!] [[*]] display the names defined by module \n" ++ + " (!: more details; *: all top-level names)\n" ++ " :cd change directory to \n" ++ " :cmd run the commands returned by ::IO String\n" ++ " :ctags [] create tags file for Vi (default: \"tags\")\n" ++ @@ -315,7 +313,9 @@ interactiveUI session srcs maybe_expr = do break_ctr = 0, breaks = [], tickarrays = emptyModuleEnv, - cmdqueue = [] + last_command = Nothing, + cmdqueue = [], + remembered_ctx = Nothing } #ifdef USE_READLINE @@ -339,7 +339,7 @@ runGHCi paths maybe_expr = do either_hdl <- io (IO.try (openFile "./.ghci" ReadMode)) case either_hdl of Left _e -> return () - Right hdl -> runCommands (fileLoop hdl False) + Right hdl -> runCommands (fileLoop hdl False False) when (read_dot_files) $ do -- Read in $HOME/.ghci @@ -355,7 +355,7 @@ runGHCi paths maybe_expr = do either_hdl <- io (IO.try (openFile file ReadMode)) case either_hdl of Left _e -> return () - Right hdl -> runCommands (fileLoop hdl False) + Right hdl -> runCommands (fileLoop hdl False False) -- Perform a :load for files given on the GHCi command line -- When in -e mode, if the load fails then we want to stop @@ -386,9 +386,6 @@ 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 @@ -418,9 +415,9 @@ interactiveLoop is_tty show_prompt = #ifdef USE_READLINE if (is_tty) then runCommands readlineLoop - else runCommands (fileLoop stdin show_prompt) + else runCommands (fileLoop stdin show_prompt is_tty) #else - runCommands (fileLoop stdin show_prompt) + runCommands (fileLoop stdin show_prompt is_tty) #endif @@ -456,8 +453,8 @@ checkPerms name = else return True #endif -fileLoop :: Handle -> Bool -> GHCi (Maybe String) -fileLoop hdl show_prompt = do +fileLoop :: Handle -> Bool -> Bool -> GHCi (Maybe String) +fileLoop hdl show_prompt is_tty = do when show_prompt $ do prompt <- mkPrompt (io (putStr prompt)) @@ -471,13 +468,40 @@ fileLoop hdl show_prompt = do -- 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 + str <- io $ consoleInputToUnicode is_tty l + return (Just str) + +#ifdef mingw32_HOST_OS +-- Convert the console input into Unicode according to the current code page. +-- The Windows console stores Unicode characters directly, so this is a +-- rather roundabout way of doing things... oh well. +-- See #782, #1483, #1649 +consoleInputToUnicode :: Bool -> String -> IO String +consoleInputToUnicode is_tty str + | is_tty = do + cp <- System.Win32.getConsoleCP + System.Win32.stringToUnicode cp str + | otherwise = + decodeStringAsUTF8 str +#else +-- for Unix, assume the input is in UTF-8 and decode it to a Unicode String. +-- See #782. +consoleInputToUnicode :: Bool -> String -> IO String +consoleInputToUnicode _is_tty str = decodeStringAsUTF8 str +#endif + +decodeStringAsUTF8 :: String -> IO String +decodeStringAsUTF8 str = + withCStringLen str $ \(cstr,len) -> + utf8DecodeString (castPtr cstr :: Ptr Word8) len mkPrompt :: GHCi String mkPrompt = do session <- getSession (toplevs,exports) <- io (GHC.getContext session) resumes <- io $ GHC.getResumeContext session + -- st <- getGHCiState context_bit <- case resumes of @@ -495,8 +519,14 @@ mkPrompt = do dots | _:rs <- resumes, not (null rs) = text "... " | otherwise = empty + + modules_bit = - hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+> + -- 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) deflt_prompt = dots <> context_bit <> modules_bit @@ -524,7 +554,8 @@ readlineLoop = do Nothing -> return Nothing Just l -> do io (addHistory l) - return (Just l) + str <- io $ consoleInputToUnicode True l + return (Just str) #endif queryQueue :: GHCi (Maybe String) @@ -631,7 +662,11 @@ afterRunStmt step_here run_result = do printForUser $ ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan $ head resumes) -- printTypeOfNames session names - printTypeAndContentOfNames session names + let namesSorted = sortBy compareNames names + tythings <- catMaybes `liftM` + io (mapM (GHC.lookupName session) namesSorted) + docs <- io$ pprTypeAndContents session [id | AnId id <- tythings] + printForUserPartWay docs maybe (return ()) runBreakCmd mb_info -- run the command set with ":set stop " st <- getGHCiState @@ -648,19 +683,6 @@ afterRunStmt step_here run_result = do return (case run_result of GHC.RunOk _ -> True; _ -> False) - where printTypeAndContentOfNames session names = do - let namesSorted = sortBy compareNames names - tythings <- catMaybes `liftM` - io (mapM (GHC.lookupName session) namesSorted) - let ids = [id | AnId id <- tythings] - terms <- mapM (io . GHC.obtainTermB session 10 False) ids - docs_terms <- mapM (io . showTerm session) terms - dflags <- getDynFlags - let pefas = dopt Opt_PrintExplicitForalls dflags - printForUser $ vcat $ zipWith (\ty cts -> ty <+> equals <+> cts) - (map (pprTyThing pefas . AnId) ids) - docs_terms - runBreakCmd :: GHC.BreakInfo -> GHCi () runBreakCmd info = do let mod = GHC.breakInfo_module info @@ -688,27 +710,49 @@ printTypeOfName session n Nothing -> return () Just thing -> printTyThing thing + +data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand + specialCommand :: String -> GHCi Bool specialCommand ('!':str) = shellEscape (dropWhile isSpace str) specialCommand str = do let (cmd,rest) = break isSpace str - maybe_cmd <- io (lookupCommand cmd) + maybe_cmd <- lookupCommand cmd case maybe_cmd of - Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n" - ++ shortHelpText) >> return False) - Just (_,f,_,_) -> f (dropWhile isSpace rest) - -lookupCommand :: String -> IO (Maybe Command) + GotCommand (_,f,_,_) -> f (dropWhile isSpace rest) + BadCommand -> + do io $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n" + ++ shortHelpText) + return False + NoLastCommand -> + do io $ hPutStr stdout ("there is no last command to perform\n" + ++ shortHelpText) + return False + +lookupCommand :: String -> GHCi (MaybeCommand) +lookupCommand "" = do + st <- getGHCiState + case last_command st of + Just c -> return $ GotCommand c + Nothing -> return NoLastCommand lookupCommand str = do + mc <- io $ lookupCommand' str + st <- getGHCiState + setGHCiState st{ last_command = mc } + return $ case mc of + Just c -> GotCommand c + Nothing -> BadCommand + +lookupCommand' :: String -> IO (Maybe Command) +lookupCommand' str = do macros <- readIORef macros_ref let cmds = builtin_commands ++ macros -- look for exact match first, then the first prefix match - case [ c | c <- cmds, str == cmdName c ] of - c:_ -> return (Just c) - [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of - [] -> return Nothing - c:_ -> return (Just c) - + return $ case [ c | c <- cmds, str == cmdName c ] of + c:_ -> Just c + [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of + [] -> Nothing + c:_ -> Just c getCurrentBreakSpan :: GHCi (Maybe SrcSpan) getCurrentBreakSpan = do @@ -797,8 +841,9 @@ addModule files = do targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files session <- getSession io (mapM_ (GHC.addTarget session) targets) + prev_context <- io $ GHC.getContext session ok <- io (GHC.load session LoadAllTargets) - afterLoad ok session + afterLoad ok session False prev_context changeDirectory :: String -> GHCi () changeDirectory dir = do @@ -806,9 +851,10 @@ changeDirectory dir = do graph <- io (GHC.getModuleGraph session) when (not (null graph)) $ io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n" + prev_context <- io $ GHC.getContext session io (GHC.setTargets session []) io (GHC.load session LoadAllTargets) - setContextAfterLoad session [] + setContextAfterLoad session prev_context [] io (GHC.workingDirectoryChanged session) dir <- expandPath dir io (setCurrentDirectory dir) @@ -923,6 +969,7 @@ loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return () loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag loadModule' files = do session <- getSession + prev_context <- io $ GHC.getContext session -- unload first discardActiveBreakPoints @@ -941,12 +988,13 @@ loadModule' files = do -- as a ToDo for now. io (GHC.setTargets session targets) - doLoad session LoadAllTargets + doLoad session False prev_context LoadAllTargets checkModule :: String -> GHCi () checkModule m = do let modl = GHC.mkModuleName m session <- getSession + prev_context <- io $ GHC.getContext session result <- io (GHC.checkModule session modl False) case result of Nothing -> io $ putStrLn "Nothing" @@ -959,37 +1007,74 @@ checkModule m = do (text "global names: " <+> ppr global) $$ (text "local names: " <+> ppr local) _ -> empty)) - afterLoad (successIf (isJust result)) session + afterLoad (successIf (isJust result)) session False prev_context reloadModule :: String -> GHCi () reloadModule m = do session <- getSession - doLoad session $ if null m then LoadAllTargets - else LoadUpTo (GHC.mkModuleName m) + prev_context <- io $ GHC.getContext session + doLoad session True prev_context $ + if null m then LoadAllTargets + else LoadUpTo (GHC.mkModuleName m) return () -doLoad :: Session -> LoadHowMuch -> GHCi SuccessFlag -doLoad session howmuch = do +doLoad :: Session -> Bool -> ([Module],[Module]) -> LoadHowMuch -> GHCi SuccessFlag +doLoad session 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. discardActiveBreakPoints ok <- io (GHC.load session howmuch) - afterLoad ok session + afterLoad ok session retain_context prev_context return ok -afterLoad :: SuccessFlag -> Session -> GHCi () -afterLoad ok session = do +afterLoad :: SuccessFlag -> Session -> Bool -> ([Module],[Module]) -> GHCi () +afterLoad ok session retain_context prev_context = do io (revertCAFs) -- always revert CAFs on load. discardTickArrays - loaded_mods <- getLoadedModules session - setContextAfterLoad session loaded_mods - modulesLoadedMsg ok (map GHC.ms_mod_name loaded_mods) + loaded_mod_summaries <- getLoadedModules session + let loaded_mods = map GHC.ms_mod loaded_mod_summaries + loaded_mod_names = map GHC.moduleName loaded_mods + modulesLoadedMsg ok loaded_mod_names -setContextAfterLoad :: Session -> [GHC.ModSummary] -> GHCi () -setContextAfterLoad session [] = do + st <- getGHCiState + if not retain_context + then do + setGHCiState st{ remembered_ctx = Nothing } + setContextAfterLoad session prev_context loaded_mod_summaries + else do + -- figure out which modules we can keep in the context, which we + -- have to put back, and which we have to remember because they + -- are (temporarily) unavailable. See ghci.prog009, #1873, #1360 + let (as,bs) = prev_context + as1 = filter isHomeModule as -- package modules are kept anyway + bs1 = filter isHomeModule bs + (as_ok, as_bad) = partition (`elem` loaded_mods) as1 + (bs_ok, bs_bad) = partition (`elem` loaded_mods) bs1 + (rem_as, rem_bs) = fromMaybe ([],[]) (remembered_ctx st) + (rem_as_ok, rem_as_bad) = partition (`elem` loaded_mods) rem_as + (rem_bs_ok, rem_bs_bad) = partition (`elem` loaded_mods) rem_bs + as' = nub (as_ok++rem_as_ok) + bs' = nub (bs_ok++rem_bs_ok) + rem_as' = nub (rem_as_bad ++ as_bad) + rem_bs' = nub (rem_bs_bad ++ bs_bad) + + -- Put back into the context any modules that we previously had + -- to drop because they weren't available (rem_as_ok, rem_bs_ok). + setContextKeepingPackageModules session prev_context (as',bs') + + -- If compilation failed, remember any modules that we are unable + -- to load, so that we can put them back in the context in the future. + case ok of + Succeeded -> setGHCiState st{ remembered_ctx = Nothing } + Failed -> setGHCiState st{ remembered_ctx = Just (rem_as',rem_bs') } + + + +setContextAfterLoad :: Session -> ([Module],[Module]) -> [GHC.ModSummary] -> GHCi () +setContextAfterLoad session prev [] = do prel_mod <- getPrelude - io (GHC.setContext session [] [prel_mod]) -setContextAfterLoad session ms = do + setContextKeepingPackageModules session prev ([], [prel_mod]) +setContextAfterLoad session prev ms = do -- load a target if one is available, otherwise load the topmost module. targets <- io (GHC.getTargets session) case [ m | Just m <- map (findTarget ms) targets ] of @@ -1013,11 +1098,26 @@ 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] []) + if b then setContextKeepingPackageModules session prev ([m], []) else do - prel_mod <- getPrelude - io (GHC.setContext session [] [prel_mod,m]) + prel_mod <- getPrelude + setContextKeepingPackageModules session prev ([],[prel_mod,m]) + +-- | Keep any package modules (except Prelude) when changing the context. +setContextKeepingPackageModules + :: Session + -> ([Module],[Module]) -- previous context + -> ([Module],[Module]) -- new context + -> GHCi () +setContextKeepingPackageModules session prev_context (as,bs) = do + let (_,bs0) = 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 + io $ GHC.setContext session as (nub (bs1 ++ pkg_modules)) +isHomeModule :: Module -> Bool +isHomeModule mod = GHC.modulePackageId mod == mainPackageId modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi () modulesLoadedMsg ok mods = do @@ -1090,15 +1190,19 @@ browseCmd bang m = browseModule :: Bool -> Module -> Bool -> GHCi () browseModule bang modl exports_only = do s <- getSession + -- :browse! reports qualifiers wrt current context + current_unqual <- io (GHC.getPrintUnqual s) -- 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) prel_mod <- getPrelude io (if exports_only then GHC.setContext s [] [prel_mod,modl] else GHC.setContext s [modl] []) - unqual <- io (GHC.getPrintUnqual s) + target_unqual <- io (GHC.getPrintUnqual s) io (GHC.setContext s as bs) + let unqual = if bang then current_unqual else target_unqual + mb_mod_info <- io $ GHC.getModuleInfo s modl case mb_mod_info of Nothing -> throwDyn (CmdLineError ("unknown module: " ++ @@ -1139,7 +1243,7 @@ browseModule bang modl exports_only = do labels [] = text "-- not currently imported" labels l = text $ intercalate "\n" $ map qualifier l qualifier = maybe "-- defined locally" - (("-- imported from "++) . intercalate ", " + (("-- imported via "++) . intercalate ", " . map GHC.moduleNameString) importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env modNames = map (importInfo . GHC.getName) things @@ -1184,14 +1288,10 @@ separate :: Session -> [String] -> [Module] -> [Module] -> GHCi ([Module],[Module]) separate _ [] as bs = return (as,bs) 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")) + m <- wantInterpretedModule str + separate session ms (m:as) bs separate session (str:ms) as bs = do - m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing + m <- lookupModule str separate session ms as (m:bs) newContext :: [String] -> GHCi () @@ -1352,7 +1452,8 @@ newDynFlags minus_opts = do io (GHC.setTargets session []) io (GHC.load session LoadAllTargets) io (linkPackages dflags new_pkgs) - setContextAfterLoad session [] + -- package flags changed, we can't re-use any of the old context + setContextAfterLoad session ([],[]) [] return () @@ -1444,8 +1545,9 @@ showBindings :: GHCi () showBindings = do s <- getSession bindings <- io (GHC.getBindings s) - mapM_ printTyThing $ sortBy compareTyThings bindings - return () + docs <- io$ pprTypeAndContents s + [ id | AnId id <- sortBy compareTyThings bindings] + printForUserPartWay docs compareTyThings :: TyThing -> TyThing -> Ordering t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2 @@ -1511,7 +1613,7 @@ completeWord w start end = do ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w _other | ((':':c) : _) <- line_words -> do - maybe_cmd <- lookupCommand c + maybe_cmd <- lookupCommand' c let (n,w') = selectWord (words' 0 line) case maybe_cmd of Nothing -> return Nothing @@ -1700,33 +1802,6 @@ wantNameFromInterpretedModule noCanDo str and_then = do text " is not interpreted" else and_then n --- ---------------------------------------------------------------------------- --- 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. Doing it this way does lead to problems, - -- however: see bug #1649. - -- - -- 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()). - -- - -- This call has been known to hang on some machines, see bug #1483 - -- - setConsoleCP 28591 -- ISO Latin-1 - setConsoleOutputCP 28591 -- ISO Latin-1 -#endif - return () - -- ----------------------------------------------------------------------------- -- commands for debugger