-- (c) The GHC Team 2005-2006
--
-----------------------------------------------------------------------------
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
-- The GHC interface
import qualified GHC
import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
- Type, Module, ModuleName, TyThing(..), Phase,
+ Module, ModuleName, TyThing(..), Phase,
BreakIndex, SrcSpan, Resume, SingleStep )
import PprTyThing
import DynFlags
+
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 Data.IORef ( IORef, readIORef, writeIORef )
+#ifdef USE_READLINE
import System.Posix.Internals ( setNonBlockingFD )
+#endif
-----------------------------------------------------------------------------
": http://www.haskell.org/ghc/ :? for help"
type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
+
+cmdName :: Command -> String
cmdName (n,_,_,_) = n
-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),
keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
keepGoingPaths a str = a (toArgs str) >> return False
+shortHelpText :: String
shortHelpText = "use :? for help.\n"
+helpText :: String
helpText =
" 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"
+findEditor :: IO String
findEditor = do
getEnv "EDITOR"
`IO.catch` \_ -> do
hSetBuffering stdin NoBuffering
-- initial context is just the Prelude
- prel_mod <- GHC.findModule session prel_name (Just basePackageId)
+ prel_mod <- GHC.findModule session (GHC.mkModuleName "Prelude")
+ (Just basePackageId)
GHC.setContext session [] [prel_mod]
#ifdef USE_READLINE
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
when (dir_ok && file_ok) $ do
either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
case either_hdl of
- Left e -> return ()
- Right hdl -> fileLoop hdl False
+ Left _e -> return ()
+ Right hdl -> runCommands (fileLoop hdl False)
when (read_dot_files) $ do
-- Read in $HOME/.ghci
- either_dir <- io (IO.try (getEnv "HOME"))
+ either_dir <- io (IO.try getHomeDirectory)
case either_dir of
- Left e -> return ()
+ Left _e -> return ()
Right dir -> do
cwd <- io (getCurrentDirectory)
when (dir /= cwd) $ do
when ok $ do
either_hdl <- io (IO.try (openFile file ReadMode))
case either_hdl of
- Left e -> return ()
- Right hdl -> fileLoop hdl False
+ Left _e -> return ()
+ Right hdl -> runCommands (fileLoop hdl 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
io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
+interactiveLoop :: Bool -> Bool -> GHCi ()
interactiveLoop is_tty show_prompt =
-- Ignore ^C exceptions caught here
ghciHandleDyn (\e -> case e of
-- 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)
#else
- fileLoop stdin show_prompt
+ runCommands (fileLoop stdin show_prompt)
#endif
-- the same directory while a process is running.
checkPerms :: String -> IO Bool
-checkPerms name =
#ifdef mingw32_HOST_OS
+checkPerms _ =
return True
#else
+checkPerms name =
Util.handle (\_ -> return False) $ do
st <- getFileStatus name
me <- getRealUserID
else return True
#endif
-fileLoop :: Handle -> Bool -> GHCi ()
+fileLoop :: Handle -> Bool -> GHCi (Maybe String)
fileLoop hdl show_prompt = 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 -> return (Just l)
+
+mkPrompt :: GHCi String
mkPrompt = do
session <- getSession
(toplevs,exports) <- io (GHC.getContext session)
context_bit <-
case resumes of
[] -> return empty
- r:rs -> do
+ r:_ -> do
let ix = GHC.resumeHistoryIx r
if ix == 0
then return (brackets (ppr (GHC.resumeSpan r)) <> space)
return (brackets (ppr (negate ix) <> char ':'
<+> ppr span) <> space)
let
- dots | r:rs <- resumes, not (null rs) = text "... "
+ dots | _:rs <- resumes, not (null rs) = text "... "
| otherwise = empty
modules_bit =
#ifdef USE_READLINE
-readlineLoop :: GHCi ()
+readlineLoop :: GHCi (Maybe String)
readlineLoop = do
- session <- getSession
- (mod,imports) <- io (GHC.getContext session)
io yield
saveSession -- for use by completion
- st <- getGHCiState
- mb_span <- getCurrentBreakSpan
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)
+ return (Just l)
#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
-- This version is for the GHC command-line option -e. The only difference
-- from runCommand is that it catches the ExitException exception and
-- exits, rather than printing out the exception.
+runCommandEval :: String -> GHCi Bool
runCommandEval c = ghciHandle handleEval (doCommand c)
where
handleEval (ExitException code) = io (exitWith code)
--afterRunStmt :: GHC.RunResult -> GHCi Bool
-- False <=> the statement failed to compile
+afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
afterRunStmt _ (GHC.RunException e) = throw e
afterRunStmt step_here run_result = do
session <- getSession
let mod = GHC.breakInfo_module info
nm = GHC.breakInfo_number info
st <- getGHCiState
- case [ loc | (i,loc) <- breaks st,
+ case [ loc | (_,loc) <- breaks st,
breakModule loc == mod, breakTick loc == nm ] of
[] -> return ()
loc:_ | null cmd -> return ()
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)
resumes <- io $ GHC.getResumeContext session
case resumes of
[] -> return Nothing
- (r:rs) -> do
+ (r:_) -> do
let ix = GHC.resumeHistoryIx r
if ix == 0
then return (Just (GHC.resumeSpan r))
resumes <- io $ GHC.getResumeContext session
case resumes of
[] -> return Nothing
- (r:rs) -> do
+ (r:_) -> do
let ix = GHC.resumeHistoryIx r
if ix == 0
then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
noArgs :: GHCi () -> String -> GHCi ()
noArgs m "" = m
-noArgs m _ = io $ putStrLn "This command takes no arguments"
+noArgs _ _ = io $ putStrLn "This command takes no arguments"
help :: String -> GHCi ()
help _ = io (putStr helpText)
infoThing pefas session str = io $ do
names <- GHC.parseName session str
mb_stuffs <- mapM (GHC.getInfo session) names
- let filtered = filterOutChildren (\(t,f,i) -> t) (catMaybes mb_stuffs)
+ let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
unqual <- GHC.getPrintUnqual session
putStrLn (showSDocForUser unqual $
vcat (intersperse (text "") $
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 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 ok session = do
+afterLoad :: SuccessFlag -> Session -> Maybe ([Module],[Module]) -> GHCi ()
+afterLoad ok session maybe_context = do
io (revertCAFs) -- always revert CAFs on load.
discardTickArrays
- graph <- io (GHC.getModuleGraph session)
- graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
- setContextAfterLoad session graph'
- modulesLoadedMsg ok (map GHC.ms_mod_name graph')
-
+ loaded_mods <- getLoadedModules session
+
+ -- 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
prel_mod <- getPrelude
io (GHC.setContext session [] [prel_mod])
= 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
+ _ `matches` _
= False
load_this summary | m <- GHC.ms_mod summary = do
-----------------------------------------------------------------------------
-- Browsing a module's contents
-browseCmd :: String -> GHCi ()
-browseCmd m =
+browseCmd :: Bool -> String -> GHCi ()
+browseCmd bang m =
case words m of
- ['*':m] | looksLikeModuleName m -> browseModule m False
- [m] | looksLikeModuleName m -> browseModule m True
+ ['*':s] | looksLikeModuleName s -> do
+ m <- wantInterpretedModule s
+ browseModule bang m False
+ [s] | looksLikeModuleName s -> do
+ m <- lookupModule s
+ browseModule bang m True
+ [] -> do
+ s <- getSession
+ (as,bs) <- io $ GHC.getContext s
+ -- Guess which module the user wants to browse. Pick
+ -- modules that are interpreted first. The most
+ -- recently-added module occurs last, it seems.
+ case (as,bs) of
+ (as@(_:_), _) -> browseModule bang (last as) True
+ ([], bs@(_:_)) -> browseModule bang (last bs) True
+ ([], []) -> throwDyn (CmdLineError ":browse: no current module")
_ -> throwDyn (CmdLineError "syntax: :browse <module>")
-browseModule m 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
- modl <- if exports_only then lookupModule m
- else wantInterpretedModule m
-
-- 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)
mb_mod_info <- io $ GHC.getModuleInfo s modl
case mb_mod_info of
- Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
+ 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
+setContext :: String -> GHCi ()
setContext str
| all sensible mods = fn mods
| otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
separate :: Session -> [String] -> [Module] -> [Module]
-> GHCi ([Module],[Module])
-separate session [] as bs = return (as,bs)
+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
("prog":prog) -> setProg prog
- ("prompt":prompt) -> setPrompt (after 6)
- ("editor":cmd) -> setEditor (after 6)
- ("stop":cmd) -> setStop (after 4)
+ ("prompt":_) -> setPrompt (after 6)
+ ("editor":_) -> setEditor (after 6)
+ ("stop":_) -> setStop (after 4)
wds -> setOptions wds
where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
+setArgs, setProg, setOptions :: [String] -> GHCi ()
+setEditor, setStop, setPrompt :: String -> GHCi ()
+
setArgs args = do
st <- getGHCiState
setGHCiState st{ args = args }
setOptions wds =
do -- first, deal with the GHCi opts (+s, +t, etc.)
- let (plus_opts, minus_opts) = partition isPlus wds
+ let (plus_opts, minus_opts) = partitionWith isPlus wds
mapM_ setOpt plus_opts
-- then, dynamic flags
newDynFlags minus_opts
+newDynFlags :: [String] -> GHCi ()
newDynFlags minus_opts = do
dflags <- getDynFlags
let pkg_flags = packageFlags dflags
= do -- first, deal with the GHCi opts (+s, +t, etc.)
let opts = words str
(minus_opts, rest1) = partition isMinus opts
- (plus_opts, rest2) = partition isPlus rest1
+ (plus_opts, rest2) = partitionWith isPlus rest1
if (not (null rest2))
then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
no_flags <- mapM no_flag minus_opts
newDynFlags no_flags
-isMinus ('-':s) = True
+isMinus :: String -> Bool
+isMinus ('-':_) = True
isMinus _ = False
-isPlus ('+':s) = True
-isPlus _ = False
+isPlus :: String -> Either String String
+isPlus ('+':opt) = Left opt
+isPlus other = Right other
-setOpt ('+':str)
+setOpt, unsetOpt :: String -> GHCi ()
+
+setOpt str
= case strToGHCiOpt str of
Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
Just o -> setOption o
-unsetOpt ('+':str)
+unsetOpt str
= case strToGHCiOpt str of
Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
Just o -> unsetOption o
-- ---------------------------------------------------------------------------
-- code for `:show'
+showCmd :: String -> GHCi ()
showCmd str = do
st <- getGHCiState
case words str of
["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 ()
showModules = do
session <- getSession
- let show_one ms = do m <- io (GHC.showModule session ms)
- io (putStrLn m)
+ loaded_mods <- getLoadedModules session
+ -- we want *loaded* modules only, see #1734
+ let show_one ms = do m <- io (GHC.showModule session ms); io (putStrLn m)
+ mapM_ show_one loaded_mods
+
+getLoadedModules :: GHC.Session -> GHCi [GHC.ModSummary]
+getLoadedModules session = do
graph <- io (GHC.getModuleGraph session)
- mapM_ show_one graph
+ filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
+showBindings :: GHCi ()
showBindings = do
s <- getSession
- unqual <- io (GHC.getPrintUnqual s)
bindings <- io (GHC.getBindings s)
mapM_ printTyThing $ sortBy compareTyThings bindings
return ()
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
completeNone :: String -> IO [String]
-completeNone w = return []
+completeNone _w = return []
+
+completeMacro, completeIdentifier, completeModule,
+ completeHomeModule, completeSetOptions, completeFilename,
+ completeHomeModuleOrFile
+ :: String -> IO [String]
#ifdef USE_READLINE
completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
| offset+length x >= start = (start-offset,take (end-offset) x)
| otherwise = selectWord xs
-
+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
getCommonPrefix :: [String] -> String
getCommonPrefix [] = ""
getCommonPrefix (s:ss) = foldl common s ss
- where common s "" = ""
- common "" s = ""
+ where common _s "" = ""
+ common "" _s = ""
common (c:cs) (d:ds)
| c == d = c : common cs ds
| otherwise = ""
allExposedModules :: DynFlags -> [ModuleName]
allExposedModules dflags
- = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
+ = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
where
pkg_db = pkgIdMap (pkgState dflags)
#else
-completeCmd = completeNone
completeMacro = completeNone
completeIdentifier = completeNone
completeModule = completeNone
completeSetOptions = completeNone
completeFilename = completeNone
completeHomeModuleOrFile=completeNone
-completeBkpt = completeNone
#endif
-- ---------------------------------------------------------------------------
io installSignalHandlers
ghciHandle handler (showException exception >> return False)
+showException :: Exception -> GHCi ()
showException (DynException dyn) =
case fromDynamic dyn of
Nothing -> io (putStrLn ("*** Exception: (unknown)"))
expandPath path =
case dropWhile isSpace path of
('~':d) -> do
- tilde <- io (getEnv "HOME") -- will fail if HOME not defined
+ tilde <- io getHomeDirectory -- will fail if HOME not defined
return (tilde ++ '/':d)
other ->
return other
throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
return modl
+wantNameFromInterpretedModule :: (Name -> SDoc -> GHCi ()) -> String
+ -> (Name -> GHCi ())
+ -> GHCi ()
wantNameFromInterpretedModule noCanDo str and_then = do
session <- getSession
names <- io $ GHC.parseName session str
-- 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.
+ -- 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
-- -----------------------------------------------------------------------------
-- commands for debugger
+sprintCmd, printCmd, forceCmd :: String -> GHCi ()
sprintCmd = pprintCommand False False
printCmd = pprintCommand True False
forceCmd = pprintCommand False True
+pprintCommand :: Bool -> Bool -> String -> GHCi ()
pprintCommand bind force str = do
session <- getSession
io $ pprintClosureCommand session bind force str
mb_span <- getCurrentBreakSpan
case mb_span of
Nothing -> stepCmd []
- Just loc -> do
+ Just _ -> do
Just span <- getCurrentBreakSpan
let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span
doContinue f GHC.SingleStep
continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
-- doContinue :: SingleStep -> GHCi ()
+doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
doContinue pred step = do
session <- getSession
runResult <- io $ GHC.resume session step
resumes <- io $ GHC.getResumeContext s
case resumes of
[] -> io $ putStrLn "Not stopped at a breakpoint"
- (r:rs) -> do
+ (r:_) -> do
let hist = GHC.resumeHistory r
(took,rest) = splitAt num hist
spans <- mapM (io . GHC.getHistorySpan s) took
(map (parens . ppr) spans)))
io $ putStrLn $ if null rest then "<end of history>" else "..."
+bold :: SDoc -> SDoc
bold c | do_bold = text start_bold <> c <> text end_bold
| otherwise = c
backCmd :: String -> GHCi ()
backCmd = noArgs $ do
s <- getSession
- (names, ix, span) <- io $ GHC.back s
+ (names, _, span) <- io $ GHC.back s
printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
printTypeOfNames s names
-- run the command set with ":set stop <cmd>"
breakSwitch :: Session -> [String] -> GHCi ()
breakSwitch _session [] = do
io $ putStrLn "The break command requires at least one argument."
-breakSwitch session args@(arg1:rest)
+breakSwitch session (arg1:rest)
| looksLikeModuleName arg1 = do
mod <- wantInterpretedModule arg1
- breakByModule session mod rest
+ breakByModule mod rest
| all isDigit arg1 = do
(toplevel, _) <- io $ GHC.getContext session
case toplevel of
noCanDo n why = printForUser $
text "cannot set breakpoint on " <> ppr n <> text ": " <> why
-breakByModule :: Session -> Module -> [String] -> GHCi ()
-breakByModule session mod args@(arg1:rest)
+breakByModule :: Module -> [String] -> GHCi ()
+breakByModule mod (arg1:rest)
| all isDigit arg1 = do -- looks like a line number
breakByModuleLine mod (read arg1) rest
-breakByModule session mod _
+breakByModule _ _
= breakSyntax
breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
| otherwise = breakSyntax
+breakSyntax :: a
breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
Nothing -> io $ putStrLn $ "No breakpoints found at that location."
Just (tick, span) -> do
success <- io $ setBreakFlag True breakArray tick
- session <- getSession
if success
then do
(alreadySet, nm) <-
where
ticks = arr ! line
- starts_here = [ tick | tick@(nm,span) <- ticks,
+ starts_here = [ tick | tick@(_,span) <- ticks,
GHC.srcSpanStartLine span == line ]
(complete,incomplete) = partition ends_here starts_here
- where ends_here (nm,span) = GHC.srcSpanEndLine span == line
+ where ends_here (_,span) = GHC.srcSpanEndLine span == line
findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
-> Maybe (BreakIndex,SrcSpan)
ticks = arr ! line
-- the ticks that span this coordinate
- contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
+ contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
is_correct_file span ]
is_correct_file span
| Just f <- mb_file = GHC.srcSpanFile span == f
| otherwise = True
- after_here = [ tick | tick@(nm,span) <- ticks,
+ after_here = [ tick | tick@(_,span) <- ticks,
GHC.srcSpanStartLine span == line,
GHC.srcSpanStartCol span >= col ]
-- TERM to vt100 for other reasons) we get carets.
-- We really ought to use a proper termcap/terminfo library.
do_bold :: Bool
-do_bold = unsafePerformIO mTerm `elem` ["xterm", "linux"]
+do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
where mTerm = System.Environment.getEnv "TERM"
- `Exception.catch` \e -> return "TERM not set"
+ `Exception.catch` \_ -> return "TERM not set"
start_bold :: String
start_bold = "\ESC[1m"
| otherwise -> printForUser $ text "unable to list source for" <+> ppr span
listCmd str = list2 (words str)
+list2 :: [String] -> GHCi ()
list2 [arg] | all isDigit arg = do
session <- getSession
(toplevel, _) <- io $ GHC.getContext session
-- | list a section of a source file around a particular SrcSpan.
-- If the highlight flag is True, also highlight the span using
-- start_bold/end_bold.
+listAround :: SrcSpan -> Bool -> IO ()
listAround span do_highlight = do
contents <- BS.readFile (unpackFS file)
let
bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
prefixed = zipWith ($) highlighted bs_line_nos
--
- BS.putStrLn (BS.join (BS.pack "\n") prefixed)
+ BS.putStrLn (BS.intercalate (BS.pack "\n") prefixed)
where
file = GHC.srcSpanFile span
line1 = GHC.srcSpanStartLine span
case lookupModuleEnv arrmap modl of
Just arr -> return arr
Nothing -> do
- (breakArray, ticks) <- getModBreak modl
+ (_breakArray, ticks) <- getModBreak modl
let arr = mkTickArray (assocs ticks)
setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
return arr
mapM (turnOffBreak.snd) this
setGHCiState $ st { breaks = rest }
+turnOffBreak :: BreakLocation -> GHCi Bool
turnOffBreak loc = do
(arr, _) <- getModBreak (breakModule loc)
io $ setBreakFlag False arr (breakTick loc)