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
builtin_commands :: [Command]
builtin_commands = [
-- Hugs users are accustomed to :e, so make sure it doesn't overlap
- ("?", keepGoing help, False, completeNone),
- ("add", keepGoingPaths addModule, False, completeFilename),
- ("abandon", keepGoing abandonCmd, False, completeNone),
- ("break", keepGoing breakCmd, False, completeIdentifier),
- ("back", keepGoing backCmd, False, completeNone),
- ("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), False, completeIdentifier),
- ("def!", keepGoing (defineMacro True), False, completeIdentifier),
- ("delete", keepGoing deleteCmd, False, completeNone),
- ("e", keepGoing editFile, False, completeFilename),
- ("edit", keepGoing editFile, False, completeFilename),
- ("etags", keepGoing createETagsFileCmd, False, completeFilename),
- ("force", keepGoing forceCmd, False, completeIdentifier),
- ("forward", keepGoing forwardCmd, False, completeNone),
- ("help", keepGoing help, False, completeNone),
- ("history", keepGoing historyCmd, False, completeNone),
- ("info", keepGoing info, False, completeIdentifier),
- ("kind", keepGoing kindOfType, False, completeIdentifier),
- ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
- ("list", keepGoing listCmd, False, completeNone),
- ("module", keepGoing setContext, False, completeModule),
- ("main", keepGoing runMain, False, completeIdentifier),
- ("print", keepGoing printCmd, False, completeIdentifier),
- ("quit", quit, False, completeNone),
- ("reload", keepGoing reloadModule, False, completeNone),
- ("set", keepGoing setCmd, True, completeSetOptions),
- ("show", keepGoing showCmd, False, completeNone),
- ("sprint", keepGoing sprintCmd, False, completeIdentifier),
- ("step", keepGoing stepCmd, False, completeIdentifier),
- ("steplocal", keepGoing stepLocalCmd, False, completeIdentifier),
- ("stepmodule",keepGoing stepModuleCmd, False, completeIdentifier),
- ("type", keepGoing typeOfExpr, False, completeIdentifier),
- ("trace", keepGoing traceCmd, False, completeIdentifier),
- ("undef", keepGoing undefineMacro, False, completeMacro),
- ("unset", keepGoing unsetOptions, True, completeSetOptions)
+ ("?", keepGoing help, Nothing, completeNone),
+ ("add", keepGoingPaths addModule, Just filenameWordBreakChars, completeFilename),
+ ("abandon", keepGoing abandonCmd, Nothing, completeNone),
+ ("break", keepGoing breakCmd, Nothing, completeIdentifier),
+ ("back", keepGoing backCmd, Nothing, completeNone),
+ ("browse", keepGoing (browseCmd False), Nothing, completeModule),
+ ("browse!", keepGoing (browseCmd True), Nothing, completeModule),
+ ("cd", keepGoing changeDirectory, Just filenameWordBreakChars, completeFilename),
+ ("check", keepGoing checkModule, Nothing, completeHomeModule),
+ ("continue", keepGoing continueCmd, Nothing, completeNone),
+ ("cmd", keepGoing cmdCmd, Nothing, completeIdentifier),
+ ("ctags", keepGoing createCTagsFileCmd, Just filenameWordBreakChars, completeFilename),
+ ("def", keepGoing (defineMacro False), Nothing, completeIdentifier),
+ ("def!", keepGoing (defineMacro True), Nothing, completeIdentifier),
+ ("delete", keepGoing deleteCmd, Nothing, completeNone),
+ ("e", keepGoing editFile, Just filenameWordBreakChars, completeFilename),
+ ("edit", keepGoing editFile, Just filenameWordBreakChars, completeFilename),
+ ("etags", keepGoing createETagsFileCmd, Just filenameWordBreakChars, completeFilename),
+ ("force", keepGoing forceCmd, Nothing, completeIdentifier),
+ ("forward", keepGoing forwardCmd, Nothing, completeNone),
+ ("help", keepGoing help, Nothing, completeNone),
+ ("history", keepGoing historyCmd, Nothing, completeNone),
+ ("info", keepGoing info, Nothing, completeIdentifier),
+ ("kind", keepGoing kindOfType, Nothing, completeIdentifier),
+ ("load", keepGoingPaths loadModule_, Just filenameWordBreakChars, completeHomeModuleOrFile),
+ ("list", keepGoing listCmd, Nothing, completeNone),
+ ("module", keepGoing setContext, Nothing, completeModule),
+ ("main", keepGoing runMain, Nothing, completeIdentifier),
+ ("print", keepGoing printCmd, Nothing, completeIdentifier),
+ ("quit", quit, Nothing, completeNone),
+ ("reload", keepGoing reloadModule, Nothing, completeNone),
+ ("set", keepGoing setCmd, Just flagWordBreakChars, completeSetOptions),
+ ("show", keepGoing showCmd, Nothing, completeNone),
+ ("sprint", keepGoing sprintCmd, Nothing, completeIdentifier),
+ ("step", keepGoing stepCmd, Nothing, completeIdentifier),
+ ("steplocal", keepGoing stepLocalCmd, Nothing, completeIdentifier),
+ ("stepmodule",keepGoing stepModuleCmd, Nothing, completeIdentifier),
+ ("type", keepGoing typeOfExpr, Nothing, completeIdentifier),
+ ("trace", keepGoing traceCmd, Nothing, completeIdentifier),
+ ("undef", keepGoing undefineMacro, Nothing, completeMacro),
+ ("unset", keepGoing unsetOptions, Just flagWordBreakChars, completeSetOptions)
]
+
+-- We initialize readline (in the interactiveUI function) to use
+-- word_break_chars as the default set of completion word break characters.
+-- This can be overridden for a particular command (for example, filename
+-- expansion shouldn't consider '/' to be a word break) by setting the third
+-- entry in the Command tuple above.
+--
+-- NOTE: in order for us to override the default correctly, any custom entry
+-- must be a SUBSET of word_break_chars.
+word_break_chars, flagWordBreakChars, filenameWordBreakChars :: String
+word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
+ specials = "(),;[]`{}"
+ spaces = " \t\n"
+ in spaces ++ specials ++ symbols
+flagWordBreakChars = " \t\n"
+filenameWordBreakChars = " \t\n\\`@$><=;|&{(" -- bash defaults
+
+
keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
keepGoing a str = a str >> return False
" Commands available from the prompt:\n" ++
"\n" ++
" <statement> evaluate/run <statement>\n" ++
+ " : repeat last command\n" ++
" :{\\n ..lines.. \\n:}\\n multiline command\n" ++
" :add <filename> ... add module(s) to the current target set\n" ++
- " :browse[!] [-s] [[*]<mod>] display the names defined by module <mod>\n" ++
- " (!: more details; -s: sort; *: all top-level names)\n" ++
+ " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++
+ " (!: more details; *: 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" ++
Readline.setAttemptedCompletionFunction (Just completeWord)
--Readline.parseAndBind "set show-all-if-ambiguous 1"
- let symbols = "!#$%&*+/<=>?@\\^|-~"
- specials = "(),;[]`{}"
- spaces = " \t\n"
- word_break_chars = spaces ++ specials ++ symbols
-
Readline.setBasicWordBreakCharacters word_break_chars
Readline.setCompleterWordBreakCharacters word_break_chars
+ Readline.setCompletionAppendCharacter Nothing
#endif
default_editor <- findEditor
break_ctr = 0,
breaks = [],
tickarrays = emptyModuleEnv,
- cmdqueue = []
+ last_command = Nothing,
+ cmdqueue = [],
+ remembered_ctx = Nothing
}
#ifdef USE_READLINE
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
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
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 "" = do
+ -- :cd on its own changes to the user's home directory
+ either_dir <- io (IO.try getHomeDirectory)
+ case either_dir of
+ Left _e -> return ()
+ Right dir -> changeDirectory dir
changeDirectory dir = do
session <- getSession
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)
case maybe_hv of
Nothing -> return ()
Just hv -> io (writeIORef macros_ref --
- (filtered ++ [(macro_name, runMacro hv, False, completeNone)]))
+ (filtered ++ [(macro_name, runMacro hv, Nothing, completeNone)]))
runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
runMacro fun s = do
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
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: " ++
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
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 ()
':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
_other
| ((':':c) : _) <- line_words -> do
- maybe_cmd <- lookupCommand c
- let (n,w') = selectWord (words' 0 line)
- case maybe_cmd of
- Nothing -> return Nothing
- Just (_,_,False,complete) -> wrapCompleter complete w
- Just (_,_,True,complete) -> let complete' w = do rets <- complete w
- return (map (drop n) rets)
- in wrapCompleter complete' w'
+ completionVars <- lookupCompletionVars c
+ case completionVars of
+ (Nothing,complete) -> wrapCompleter complete w
+ (Just breakChars,complete)
+ -> let (n,w') = selectWord
+ (words' (`elem` breakChars) 0 line)
+ complete' w = do rets <- complete w
+ return (map (drop n) rets)
+ in wrapCompleter complete' w'
| ("import" : _) <- line_words ->
wrapCompleter completeModule w
| otherwise -> do
--printf "complete %s, start = %d, end = %d\n" w start end
wrapCompleter completeIdentifier w
- where words' _ [] = []
- words' n str = let (w,r) = break isSpace str
- (s,r') = span isSpace r
- in (n,w):words' (n+length w+length s) r'
+ where words' _ _ [] = []
+ words' isBreak n str = let (w,r) = break isBreak str
+ (s,r') = span isBreak r
+ in (n,w):words' isBreak (n+length w+length s) r'
-- In a Haskell expression we want to parse 'a-b' as three words
-- where a compiler flag (ie. -fno-monomorphism-restriction) should
-- only be a single word.
selectWord ((offset,x):xs)
| offset+length x >= start = (start-offset,take (end-offset) x)
| otherwise = selectWord xs
+
+ lookupCompletionVars ('!':_) = return (Just filenameWordBreakChars,
+ completeFilename)
+ lookupCompletionVars c = do
+ maybe_cmd <- lookupCommand' c
+ case maybe_cmd of
+ Just (_,_,ws,f) -> return (ws,f)
+ Nothing -> return (Just filenameWordBreakChars,
+ completeFilename)
+
completeCmd :: String -> IO [String]
completeCmd w = do
return (filter (w `isPrefixOf`) options)
where options = "args":"prog":allFlags
-completeFilename = Readline.filenameCompletionFunction
+completeFilename w = do
+ ws <- Readline.filenameCompletionFunction w
+ case ws of
+ -- If we only found one result, and it's a directory,
+ -- add a trailing slash.
+ [file] -> do
+ isDir <- expandPathIO file >>= doesDirectoryExist
+ if isDir && last file /= '/'
+ then return [file ++ "/"]
+ else return [file]
+ _ -> return ws
+
completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
wrapCompleter fun w = do
strs <- fun w
case strs of
- [] -> return Nothing
- [x] -> return (Just (x,[]))
+ [] -> Readline.setAttemptedCompletionOver True >> return Nothing
+ [x] -> -- Add a trailing space, unless it already has an appended slash.
+ let appended = if last x == '/' then x else x ++ " "
+ in return (Just (appended,[]))
xs -> case getCommonPrefix xs of
"" -> return (Just ("",xs))
pref -> return (Just (pref,xs))
-- Utils
expandPath :: String -> GHCi String
-expandPath path =
+expandPath path = io (expandPathIO path)
+
+expandPathIO :: String -> IO String
+expandPathIO path =
case dropWhile isSpace path of
('~':d) -> do
- tilde <- io getHomeDirectory -- will fail if HOME not defined
+ tilde <- getHomeDirectory -- will fail if HOME not defined
return (tilde ++ '/':d)
other ->
return other
(r:_) -> do
let hist = GHC.resumeHistory r
(took,rest) = splitAt num hist
- spans <- mapM (io . GHC.getHistorySpan s) took
- let nums = map (printf "-%-3d:") [(1::Int)..]
- let names = map GHC.historyEnclosingDecl took
- printForUser (vcat(zipWith3
- (\x y z -> x <+> y <+> z)
- (map text nums)
- (map (bold . ppr) names)
- (map (parens . ppr) spans)))
- io $ putStrLn $ if null rest then "<end of history>" else "..."
+ case hist of
+ [] -> io $ putStrLn $
+ "Empty history. Perhaps you forgot to use :trace?"
+ _ -> do
+ spans <- mapM (io . GHC.getHistorySpan s) took
+ let nums = map (printf "-%-3d:") [(1::Int)..]
+ names = map GHC.historyEnclosingDecl took
+ printForUser (vcat(zipWith3
+ (\x y z -> x <+> y <+> z)
+ (map text nums)
+ (map (bold . ppr) names)
+ (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