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
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
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) )
break_ctr = 0,
breaks = [],
tickarrays = emptyModuleEnv,
- cmdqueue = []
+ cmdqueue = [],
+ remembered_ctx = Nothing
}
#ifdef USE_READLINE
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
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
| 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
#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
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))
-- 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
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
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)
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 <cmd>"
st <- getGHCiState
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
Nothing -> return ()
Just thing -> printTyThing thing
+
+
+
specialCommand :: String -> GHCi Bool
specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
specialCommand str = 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 Nothing
+ afterLoad ok session False prev_context
changeDirectory :: String -> GHCi ()
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)
loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
loadModule' files = do
session <- getSession
+ prev_context <- io $ GHC.getContext session
-- unload first
discardActiveBreakPoints
-- as a ToDo for now.
io (GHC.setTargets session targets)
- doLoad session False 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"
(text "global names: " <+> ppr global) $$
(text "local names: " <+> ppr local)
_ -> empty))
- afterLoad (successIf (isJust result)) session Nothing
+ afterLoad (successIf (isJust result)) session False prev_context
reloadModule :: String -> GHCi ()
reloadModule m = do
session <- getSession
- doLoad session True $ 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 -> Bool -> LoadHowMuch -> GHCi SuccessFlag
-doLoad session retain_context 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
- context <- io $ GHC.getContext session
ok <- io (GHC.load session howmuch)
- afterLoad ok session (if retain_context then Just context else Nothing)
+ afterLoad ok session retain_context prev_context
return ok
-afterLoad :: SuccessFlag -> Session -> Maybe ([Module],[Module]) -> GHCi ()
-afterLoad ok session maybe_context = 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
+ 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
- -- try to retain the old module context for :reload. This might
- -- not be possible, for example if some modules have gone away, so
- -- we attempt to set the same context, backing off to the default
- -- context if that fails.
- case maybe_context of
- Nothing -> setContextAfterLoad session loaded_mods
- Just (as,bs) -> do
- r <- io $ Exception.try (GHC.setContext session as bs)
- case r of
- Left _err -> setContextAfterLoad session loaded_mods
- Right _ -> return ()
-
- modulesLoadedMsg ok (map GHC.ms_mod_name loaded_mods)
-
-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
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
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 ()
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
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