import qualified GHC
import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
Module, ModuleName, TyThing(..), Phase,
- BreakIndex, SrcSpan, Resume, SingleStep )
+ BreakIndex, SrcSpan, Resume, SingleStep, Id )
import PprTyThing
import DynFlags
-#ifdef USE_READLINE
import Packages
+#ifdef USE_READLINE
import PackageConfig
import UniqFM
#endif
import HscTypes ( implicitTyThings )
+import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
import Outputable hiding (printForUser)
import Module -- for ModuleEnv
import Name
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) )
cmdName :: Command -> String
cmdName (n,_,_,_) = n
-commands :: IORef [Command]
-GLOBAL_VAR(commands, builtin_commands, [Command])
+macros_ref :: IORef [Command]
+GLOBAL_VAR(macros_ref, [], [Command])
builtin_commands :: [Command]
builtin_commands = [
("abandon", keepGoing abandonCmd, False, completeNone),
("break", keepGoing breakCmd, False, completeIdentifier),
("back", keepGoing backCmd, False, completeNone),
- ("browse", keepGoing browseCmd, False, completeModule),
+ ("browse", keepGoing (browseCmd False), False, completeModule),
+ ("browse!", keepGoing (browseCmd True), False, completeModule),
("cd", keepGoing changeDirectory, False, completeFilename),
("check", keepGoing checkModule, False, completeHomeModule),
("continue", keepGoing continueCmd, False, completeNone),
("cmd", keepGoing cmdCmd, False, completeIdentifier),
("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
- ("def", keepGoing defineMacro, False, completeIdentifier),
+ ("def", keepGoing (defineMacro False), False, completeIdentifier),
+ ("def!", keepGoing (defineMacro True), False, completeIdentifier),
("delete", keepGoing deleteCmd, False, completeNone),
("e", keepGoing editFile, False, completeFilename),
("edit", keepGoing editFile, False, completeFilename),
" Commands available from the prompt:\n" ++
"\n" ++
" <statement> evaluate/run <statement>\n" ++
+ " :{\\n ..lines.. \\n:}\\n multiline command\n" ++
" :add <filename> ... add module(s) to the current target set\n" ++
- " :browse [[*]<module>] display the names defined by <module>\n" ++
+ " :browse[!] [-s] [[*]<mod>] display the names defined by module <mod>\n" ++
+ " (!: more details; -s: sort; *: all top-level names)\n" ++
" :cd <dir> change directory to <dir>\n" ++
" :cmd <expr> run the commands returned by <expr>::IO String\n" ++
" :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
" +t print type after evaluation\n" ++
" -<flags> most GHC command line flags can also be set here\n" ++
" (eg. -v2, -fglasgow-exts, etc.)\n" ++
+ " for GHCi-specific flags, see User's Guide,\n"++
+ " Flag reference, Interactive-mode options\n" ++
"\n" ++
" -- Commands for displaying information:\n" ++
"\n" ++
" :show breaks show the active breakpoints\n" ++
" :show context show the breakpoint context\n" ++
" :show modules show the currently loaded modules\n" ++
+ " :show packages show the currently active package flags\n" ++
+ " :show languages show the currently active language flags\n" ++
" :show <setting> show anything that can be set with :set (e.g. args)\n" ++
"\n"
either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
case either_hdl of
Left _e -> return ()
- Right hdl -> 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 -> 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
-- read commands from stdin
#ifdef USE_READLINE
if (is_tty)
- then readlineLoop
- else fileLoop stdin show_prompt
+ then runCommands readlineLoop
+ else runCommands (fileLoop stdin show_prompt is_tty)
#else
- fileLoop stdin show_prompt
+ runCommands (fileLoop stdin show_prompt is_tty)
#endif
else return True
#endif
-fileLoop :: Handle -> Bool -> GHCi ()
-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))
l <- io (IO.try (hGetLine hdl))
case l of
- Left e | isEOFError e -> return ()
- | InvalidArgument <- etype -> return ()
- | otherwise -> io (ioError e)
- where etype = ioeGetErrorType e
- -- treat InvalidArgument in the same way as EOF:
- -- this can happen if the user closed stdin, or
- -- perhaps did getContents which closes stdin at
- -- EOF.
- Right l ->
- case removeSpaces l of
- "" -> fileLoop hdl show_prompt
- l -> do quit <- runCommands l
- if quit then return () else fileLoop hdl show_prompt
+ Left e | isEOFError e -> return Nothing
+ | InvalidArgument <- etype -> return Nothing
+ | otherwise -> io (ioError e)
+ where etype = ioeGetErrorType e
+ -- treat InvalidArgument in the same way as EOF:
+ -- this can happen if the user closed stdin, or
+ -- perhaps did getContents which closes stdin at
+ -- EOF.
+ 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
#ifdef USE_READLINE
-readlineLoop :: GHCi ()
+readlineLoop :: GHCi (Maybe String)
readlineLoop = do
io yield
saveSession -- for use by completion
prompt <- mkPrompt
l <- io (readline prompt `finally` setNonBlockingFD 0)
- -- readline sometimes puts stdin into blocking mode,
- -- so we need to put it back for the IO library
+ -- readline sometimes puts stdin into blocking mode,
+ -- so we need to put it back for the IO library
splatSavedSession
case l of
- Nothing -> return ()
- Just l ->
- case removeSpaces l of
- "" -> readlineLoop
- l -> do
- io (addHistory l)
- quit <- runCommands l
- if quit then return () else readlineLoop
+ Nothing -> return Nothing
+ Just l -> do
+ io (addHistory l)
+ str <- io $ consoleInputToUnicode True l
+ return (Just str)
#endif
-runCommands :: String -> GHCi Bool
-runCommands cmd = do
- q <- ghciHandle handler (doCommand cmd)
- if q then return True else runNext
+queryQueue :: GHCi (Maybe String)
+queryQueue = do
+ st <- getGHCiState
+ case cmdqueue st of
+ [] -> return Nothing
+ c:cs -> do setGHCiState st{ cmdqueue = cs }
+ return (Just c)
+
+runCommands :: GHCi (Maybe String) -> GHCi ()
+runCommands getCmd = do
+ mb_cmd <- noSpace queryQueue
+ mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
+ case mb_cmd of
+ Nothing -> return ()
+ Just c -> do
+ b <- ghciHandle handler (doCommand c)
+ if b then return () else runCommands getCmd
where
- runNext = do
- st <- getGHCiState
- case cmdqueue st of
- [] -> return False
- c:cs -> do setGHCiState st{ cmdqueue = cs }
- runCommands c
-
- doCommand (':' : cmd) = specialCommand cmd
- doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion
- return False
+ noSpace q = q >>= maybe (return Nothing)
+ (\c->case removeSpaces c of
+ "" -> noSpace q
+ ":{" -> multiLineCmd q
+ c -> return (Just c) )
+ multiLineCmd q = do
+ st <- getGHCiState
+ let p = prompt st
+ setGHCiState st{ prompt = "%s| " }
+ mb_cmd <- collectCommand q ""
+ getGHCiState >>= \st->setGHCiState st{ prompt = p }
+ return mb_cmd
+ -- we can't use removeSpaces for the sublines here, so
+ -- multiline commands are somewhat more brittle against
+ -- fileformat errors (such as \r in dos input on unix),
+ -- we get rid of any extra spaces for the ":}" test;
+ -- we also avoid silent failure if ":}" is not found;
+ -- and since there is no (?) valid occurrence of \r (as
+ -- opposed to its String representation, "\r") inside a
+ -- ghci command, we replace any such with ' ' (argh:-(
+ collectCommand q c = q >>=
+ maybe (io (ioError collectError))
+ (\l->if removeSpaces l == ":}"
+ then return (Just $ removeSpaces c)
+ else collectCommand q (c++map normSpace l))
+ where normSpace '\r' = ' '
+ normSpace c = c
+ -- QUESTION: is userError the one to use here?
+ collectError = userError "unterminated multiline command :{ .. :}"
+ doCommand (':' : cmd) = specialCommand cmd
+ doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion
+ return False
enqueueCommands :: [String] -> GHCi ()
enqueueCommands cmds = 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)
+
+ printTypeAndContents session [id | AnId id <- tythings]
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
+printTypeAndContents :: Session -> [Id] -> GHCi ()
+printTypeAndContents session ids = do
+ dflags <- getDynFlags
+ let pefas = dopt Opt_PrintExplicitForalls dflags
+ pcontents = dopt Opt_PrintBindContents dflags
+ if pcontents
+ then do
+ let depthBound = 100
+ terms <- mapM (io . GHC.obtainTermB session depthBound False) ids
+ docs_terms <- mapM (io . showTerm session) terms
+ printForUser $ vcat $ zipWith (\ty cts -> ty <+> equals <+> cts)
+ (map (pprTyThing pefas . AnId) ids)
+ docs_terms
+ else printForUser $ vcat $ map (pprTyThing pefas . AnId) ids
+
+
specialCommand :: String -> GHCi Bool
specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
specialCommand str = do
lookupCommand :: String -> IO (Maybe Command)
lookupCommand str = do
- cmds <- readIORef commands
+ 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)
session <- getSession
io (mapM_ (GHC.addTarget session) targets)
ok <- io (GHC.load session LoadAllTargets)
- afterLoad ok session
+ afterLoad ok session Nothing
changeDirectory :: String -> GHCi ()
changeDirectory dir = do
where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
fromTarget _ = Nothing -- when would we get a module target?
-defineMacro :: String -> GHCi ()
-defineMacro s = do
+defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
+defineMacro overwrite s = do
let (macro_name, definition) = break isSpace s
- cmds <- io (readIORef commands)
+ macros <- io (readIORef macros_ref)
+ let defined = map cmdName macros
if (null macro_name)
- then throwDyn (CmdLineError "invalid macro name")
+ then if null defined
+ then io $ putStrLn "no macros defined"
+ else io $ putStr ("the following macros are defined:\n" ++
+ unlines defined)
else do
- if (macro_name `elem` map cmdName cmds)
+ if (not overwrite && macro_name `elem` defined)
then throwDyn (CmdLineError
- ("command '" ++ macro_name ++ "' is already defined"))
+ ("macro '" ++ macro_name ++ "' is already defined"))
else do
+ let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
+
-- give the expression a type signature, so we can be sure we're getting
-- something of the right type.
let new_expr = '(' : definition ++ ") :: String -> IO String"
maybe_hv <- io (GHC.compileExpr cms new_expr)
case maybe_hv of
Nothing -> return ()
- Just hv -> io (writeIORef commands --
- (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
+ Just hv -> io (writeIORef macros_ref --
+ (filtered ++ [(macro_name, runMacro hv, False, completeNone)]))
runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
runMacro fun s = do
return False
undefineMacro :: String -> GHCi ()
-undefineMacro macro_name = do
- cmds <- io (readIORef commands)
- if (macro_name `elem` map cmdName builtin_commands)
- then throwDyn (CmdLineError
- ("command '" ++ macro_name ++ "' cannot be undefined"))
- else do
- if (macro_name `notElem` map cmdName cmds)
- then throwDyn (CmdLineError
- ("command '" ++ macro_name ++ "' not defined"))
- else do
- io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
+undefineMacro str = mapM_ undef (words str)
+ where undef macro_name = do
+ cmds <- io (readIORef macros_ref)
+ if (macro_name `notElem` map cmdName cmds)
+ then throwDyn (CmdLineError
+ ("macro '" ++ macro_name ++ "' is not defined"))
+ else do
+ io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
cmdCmd :: String -> GHCi ()
cmdCmd str = do
-- as a ToDo for now.
io (GHC.setTargets session targets)
- doLoad session LoadAllTargets
+ doLoad session False LoadAllTargets
checkModule :: String -> GHCi ()
checkModule m = do
(text "global names: " <+> ppr global) $$
(text "local names: " <+> ppr local)
_ -> empty))
- afterLoad (successIf (isJust result)) session
+ afterLoad (successIf (isJust result)) session Nothing
reloadModule :: String -> GHCi ()
reloadModule m = do
session <- getSession
- doLoad session $ if null m then LoadAllTargets
- else LoadUpTo (GHC.mkModuleName m)
+ doLoad session True $ if null m then LoadAllTargets
+ else LoadUpTo (GHC.mkModuleName m)
return ()
-doLoad :: Session -> LoadHowMuch -> GHCi SuccessFlag
-doLoad session howmuch = do
+doLoad :: Session -> Bool -> LoadHowMuch -> GHCi SuccessFlag
+doLoad session retain_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
+ afterLoad ok session (if retain_context then Just context else Nothing)
return ok
-afterLoad :: SuccessFlag -> Session -> GHCi ()
-afterLoad ok session = do
+afterLoad :: SuccessFlag -> Session -> Maybe ([Module],[Module]) -> GHCi ()
+afterLoad ok session maybe_context = do
io (revertCAFs) -- always revert CAFs on load.
discardTickArrays
loaded_mods <- getLoadedModules session
- setContextAfterLoad session loaded_mods
+
+ -- 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 ()
-----------------------------------------------------------------------------
-- Browsing a module's contents
-browseCmd :: String -> GHCi ()
-browseCmd m =
+browseCmd :: Bool -> String -> GHCi ()
+browseCmd bang m =
case words m of
['*':s] | looksLikeModuleName s -> do
m <- wantInterpretedModule s
- browseModule m False
+ browseModule bang m False
[s] | looksLikeModuleName s -> do
m <- lookupModule s
- browseModule m True
+ browseModule bang m True
[] -> do
s <- getSession
(as,bs) <- io $ GHC.getContext s
-- modules that are interpreted first. The most
-- recently-added module occurs last, it seems.
case (as,bs) of
- (as@(_:_), _) -> browseModule (last as) True
- ([], bs@(_:_)) -> browseModule (last bs) True
+ (as@(_:_), _) -> browseModule bang (last as) True
+ ([], bs@(_:_)) -> browseModule bang (last bs) True
([], []) -> throwDyn (CmdLineError ":browse: no current module")
_ -> throwDyn (CmdLineError "syntax: :browse <module>")
-browseModule :: Module -> Bool -> GHCi ()
-browseModule modl exports_only = do
+-- without bang, show items in context of their parents and omit children
+-- with bang, show class methods and data constructors separately, and
+-- indicate import modules, to aid qualifying unqualified names
+-- with sorted, sort items alphabetically
+browseModule :: Bool -> Module -> Bool -> GHCi ()
+browseModule bang modl exports_only = do
s <- getSession
-- 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] [])
+ else GHC.setContext s [modl] [])
unqual <- io (GHC.getPrintUnqual s)
io (GHC.setContext s as bs)
Nothing -> throwDyn (CmdLineError ("unknown module: " ++
GHC.moduleNameString (GHC.moduleName modl)))
Just mod_info -> do
- let names
- | exports_only = GHC.modInfoExports mod_info
- | otherwise = GHC.modInfoTopLevelScope mod_info
- `orElse` []
-
- mb_things <- io $ mapM (GHC.lookupName s) names
- let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
-
dflags <- getDynFlags
- let pefas = dopt Opt_PrintExplicitForalls dflags
- io (putStrLn (showSDocForUser unqual (
- vcat (map (pprTyThingInContext pefas) filtered_things)
- )))
- -- ToDo: modInfoInstances currently throws an exception for
- -- package modules. When it works, we can do this:
- -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
+ let names
+ | exports_only = GHC.modInfoExports mod_info
+ | otherwise = GHC.modInfoTopLevelScope mod_info
+ `orElse` []
+
+ -- sort alphabetically name, but putting
+ -- locally-defined identifiers first.
+ -- We would like to improve this; see #1799.
+ sorted_names = loc_sort local ++ occ_sort external
+ where
+ (local,external) = partition ((==modl) . nameModule) names
+ occ_sort = sortBy (compare `on` nameOccName)
+ -- try to sort by src location. If the first name in
+ -- our list has a good source location, then they all should.
+ loc_sort names
+ | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
+ = sortBy (compare `on` nameSrcSpan) names
+ | otherwise
+ = occ_sort names
+
+ mb_things <- io $ mapM (GHC.lookupName s) sorted_names
+ let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
+
+ rdr_env <- io $ GHC.getGRE s
+
+ let pefas = dopt Opt_PrintExplicitForalls dflags
+ things | bang = catMaybes mb_things
+ | otherwise = filtered_things
+ pretty | bang = pprTyThing
+ | otherwise = pprTyThingInContext
+
+ labels [] = text "-- not currently imported"
+ labels l = text $ intercalate "\n" $ map qualifier l
+ qualifier = maybe "-- defined locally"
+ (("-- imported from "++) . intercalate ", "
+ . map GHC.moduleNameString)
+ importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
+ modNames = map (importInfo . GHC.getName) things
+
+ -- annotate groups of imports with their import modules
+ -- the default ordering is somewhat arbitrary, so we group
+ -- by header and sort groups; the names themselves should
+ -- really come in order of source appearance.. (trac #1799)
+ annotate mts = concatMap (\(m,ts)->labels m:ts)
+ $ sortBy cmpQualifiers $ group mts
+ where cmpQualifiers =
+ compare `on` (map (fmap (map moduleNameFS)) . fst)
+ group [] = []
+ group mts@((m,_):_) = (m,map snd g) : group ng
+ where (g,ng) = partition ((==m).fst) mts
+
+ let prettyThings = map (pretty pefas) things
+ prettyThings' | bang = annotate $ zip modNames prettyThings
+ | otherwise = prettyThings
+ io (putStrLn $ showSDocForUser unqual (vcat prettyThings'))
+ -- ToDo: modInfoInstances currently throws an exception for
+ -- package modules. When it works, we can do this:
+ -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
-----------------------------------------------------------------------------
-- Setting the module context
-> 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 ()
then text "none."
else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
))
+ dflags <- getDynFlags
+ io $ putStrLn (showSDoc (
+ vcat (text "GHCi-specific dynamic flag settings:"
+ :map (flagSetting dflags) ghciFlags)
+ ))
+ io $ putStrLn (showSDoc (
+ vcat (text "other dynamic, non-language, flag settings:"
+ :map (flagSetting dflags) nonLanguageDynFlags)
+ ))
+ where flagSetting dflags (str,f)
+ | dopt f dflags = text " " <> text "-f" <> text str
+ | otherwise = text " " <> text "-fno-" <> text str
+ (ghciFlags,others) = partition (\(_,f)->f `elem` flags)
+ DynFlags.fFlags
+ nonLanguageDynFlags = filter (\(_,f)->not $ f `elem` map snd xFlags)
+ others
+ flags = [Opt_PrintExplicitForalls
+ ,Opt_PrintBindResult
+ ,Opt_BreakOnException
+ ,Opt_BreakOnError
+ ,Opt_PrintEvldWithShow
+ ]
setCmd str
= case toArgs str of
("args":args) -> setArgs args
["linker"] -> io showLinkerState
["breaks"] -> showBkptTable
["context"] -> showContext
+ ["packages"] -> showPackages
+ ["languages"] -> showLanguages
_ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
showModules :: GHCi ()
showBindings = do
s <- getSession
bindings <- io (GHC.getBindings s)
- mapM_ printTyThing $ sortBy compareTyThings bindings
- return ()
+ printTypeAndContents s [ id | AnId id <- sortBy compareTyThings bindings]
compareTyThings :: TyThing -> TyThing -> Ordering
t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
$$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
+showPackages :: GHCi ()
+showPackages = do
+ pkg_flags <- fmap packageFlags getDynFlags
+ io $ putStrLn $ showSDoc $ vcat $
+ text ("active package flags:"++if null pkg_flags then " none" else "")
+ : map showFlag pkg_flags
+ pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
+ io $ putStrLn $ showSDoc $ vcat $
+ text "packages currently loaded:"
+ : map (nest 2 . text . packageIdString) pkg_ids
+ where showFlag (ExposePackage p) = text $ " -package " ++ p
+ showFlag (HidePackage p) = text $ " -hide-package " ++ p
+ showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
+
+showLanguages :: GHCi ()
+showLanguages = do
+ dflags <- getDynFlags
+ io $ putStrLn $ showSDoc $ vcat $
+ text "active language flags:" :
+ [text (" -X" ++ str) | (str,f) <- DynFlags.xFlags, dopt f dflags]
-- -----------------------------------------------------------------------------
-- Completion
completeCmd :: String -> IO [String]
completeCmd w = do
- cmds <- readIORef commands
- return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
+ cmds <- readIORef macros_ref
+ return (filter (w `isPrefixOf`) (map (':':)
+ (map cmdName (builtin_commands ++ cmds))))
completeMacro w = do
- cmds <- readIORef commands
- let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
- return (filter (w `isPrefixOf`) cmds')
+ cmds <- readIORef macros_ref
+ return (filter (w `isPrefixOf`) (map cmdName cmds))
completeIdentifier w = do
s <- restoreSession
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
projects / ghc-hetmet.git / blobdiff