1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2005-2006
8 -----------------------------------------------------------------------------
14 #include "HsVersions.h"
16 #if defined(GHCI) && defined(BREAKPOINT)
17 import GHC.Exts ( Int(..), Ptr(..), int2Addr# )
18 import Foreign.StablePtr ( deRefStablePtr, castPtrToStablePtr )
19 import System.IO.Unsafe ( unsafePerformIO )
32 import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
33 Type, Module, ModuleName, TyThing(..), Phase )
46 -- Other random utilities
49 import Panic hiding (showException)
55 #ifndef mingw32_HOST_OS
57 #if __GLASGOW_HASKELL__ > 504
61 import GHC.ConsoleHandler ( flushConsole )
62 import System.Win32 ( setConsoleCP, setConsoleOutputCP )
63 import qualified System.Win32
67 import Control.Concurrent ( yield ) -- Used in readline loop
68 import System.Console.Readline as Readline
73 import Control.Exception as Exception
75 -- import Control.Concurrent
79 import Data.Int ( Int64 )
80 import Data.Maybe ( isJust, isNothing, fromMaybe, catMaybes )
83 import System.Environment
84 import System.Exit ( exitWith, ExitCode(..) )
85 import System.Directory
87 import System.IO.Error as IO
89 import Control.Monad as Monad
90 import Foreign.StablePtr ( newStablePtr )
92 import GHC.Exts ( unsafeCoerce# )
93 import GHC.IOBase ( IOErrorType(InvalidArgument) )
95 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
97 import System.Posix.Internals ( setNonBlockingFD )
99 -----------------------------------------------------------------------------
103 " / _ \\ /\\ /\\/ __(_)\n"++
104 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
105 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
106 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
108 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
109 cmdName (n,_,_,_) = n
111 GLOBAL_VAR(commands, builtin_commands, [Command])
113 builtin_commands :: [Command]
115 ("add", keepGoingPaths addModule, False, completeFilename),
116 ("browse", keepGoing browseCmd, False, completeModule),
117 ("cd", keepGoing changeDirectory, False, completeFilename),
118 ("def", keepGoing defineMacro, False, completeIdentifier),
119 ("e", keepGoing editFile, False, completeFilename),
120 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
121 ("edit", keepGoing editFile, False, completeFilename),
122 ("help", keepGoing help, False, completeNone),
123 ("?", keepGoing help, False, completeNone),
124 ("info", keepGoing info, False, completeIdentifier),
125 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
126 ("module", keepGoing setContext, False, completeModule),
127 ("main", keepGoing runMain, False, completeIdentifier),
128 ("reload", keepGoing reloadModule, False, completeNone),
129 ("check", keepGoing checkModule, False, completeHomeModule),
130 ("set", keepGoing setCmd, True, completeSetOptions),
131 ("show", keepGoing showCmd, False, completeNone),
132 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
133 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
134 ("type", keepGoing typeOfExpr, False, completeIdentifier),
135 ("kind", keepGoing kindOfType, False, completeIdentifier),
136 ("unset", keepGoing unsetOptions, True, completeSetOptions),
137 ("undef", keepGoing undefineMacro, False, completeMacro),
138 ("quit", quit, False, completeNone)
141 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
142 keepGoing a str = a str >> return False
144 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
145 keepGoingPaths a str = a (toArgs str) >> return False
147 shortHelpText = "use :? for help.\n"
149 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
151 " Commands available from the prompt:\n" ++
153 " <stmt> evaluate/run <stmt>\n" ++
154 " :add <filename> ... add module(s) to the current target set\n" ++
155 " :browse [*]<module> display the names defined by <module>\n" ++
156 " :cd <dir> change directory to <dir>\n" ++
157 " :def <cmd> <expr> define a command :<cmd>\n" ++
158 " :edit <file> edit file\n" ++
159 " :edit edit last module\n" ++
160 " :help, :? display this list of commands\n" ++
161 " :info [<name> ...] display information about the given names\n" ++
162 " :load <filename> ... load module(s) and their dependents\n" ++
163 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
164 " :main [<arguments> ...] run the main function with the given arguments\n" ++
165 " :reload reload the current module set\n" ++
167 " :set <option> ... set options\n" ++
168 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
169 " :set prog <progname> set the value returned by System.getProgName\n" ++
170 " :set prompt <prompt> set the prompt used in GHCi\n" ++
171 " :set editor <cmd> set the comand used for :edit\n" ++
173 " :show modules show the currently loaded modules\n" ++
174 " :show bindings show the current bindings made at the prompt\n" ++
176 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
177 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
178 " :type <expr> show the type of <expr>\n" ++
179 " :kind <type> show the kind of <type>\n" ++
180 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
181 " :unset <option> ... unset options\n" ++
182 " :quit exit GHCi\n" ++
183 " :!<command> run the shell command <command>\n" ++
185 " Options for ':set' and ':unset':\n" ++
187 " +r revert top-level expressions after each evaluation\n" ++
188 " +s print timing/memory stats after each evaluation\n" ++
189 " +t print type after evaluation\n" ++
190 " -<flags> most GHC command line flags can also be set here\n" ++
191 " (eg. -v2, -fglasgow-exts, etc.)\n"
194 #if defined(GHCI) && defined(BREAKPOINT)
195 globaliseAndTidy :: Id -> Id
197 -- Give the Id a Global Name, and tidy its type
198 = Id.setIdType (globaliseId VanillaGlobal id) tidy_type
200 tidy_type = tidyTopType (idType id)
203 printScopeMsg :: Session -> String -> [Id] -> IO ()
204 printScopeMsg session location ids
205 = GHC.getPrintUnqual session >>= \unqual ->
206 printForUser stdout unqual $
207 text "Local bindings in scope:" $$
208 nest 2 (pprWithCommas showId ids)
209 where showId id = ppr (idName id) <+> dcolon <+> ppr (idType id)
211 jumpCondFunction :: Session -> Int -> [HValue] -> String -> Bool -> b -> b
212 jumpCondFunction session ptr hValues location True b = b
213 jumpCondFunction session ptr hValues location False b
214 = jumpFunction session ptr hValues location b
216 jumpFunction :: Session -> Int -> [HValue] -> String -> b -> b
217 jumpFunction session@(Session ref) (I# idsPtr) hValues location b
219 do ids <- deRefStablePtr (castPtrToStablePtr (Ptr (int2Addr# idsPtr)))
220 let names = map idName ids
221 ASSERT (length names == length hValues) return ()
222 printScopeMsg session location ids
223 hsc_env <- readIORef ref
225 let ictxt = hsc_IC hsc_env
226 global_ids = map globaliseAndTidy ids
227 rn_env = ic_rn_local_env ictxt
228 type_env = ic_type_env ictxt
229 bound_names = map idName global_ids
230 new_rn_env = extendLocalRdrEnv rn_env bound_names
231 -- Remove any shadowed bindings from the type_env;
232 -- they are inaccessible but might, I suppose, cause
233 -- a space leak if we leave them there
234 shadowed = [ n | name <- bound_names,
235 let rdr_name = mkRdrUnqual (nameOccName name),
236 Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
237 filtered_type_env = delListFromNameEnv type_env shadowed
238 new_type_env = extendTypeEnvWithIds filtered_type_env global_ids
239 new_ic = ictxt { ic_rn_local_env = new_rn_env,
240 ic_type_env = new_type_env }
241 writeIORef ref (hsc_env { hsc_IC = new_ic })
242 is_tty <- hIsTerminalDevice stdin
243 prel_mod <- GHC.findModule session prel_name Nothing
244 default_editor <- findEditor
245 withExtendedLinkEnv (zip names hValues) $
246 startGHCi (interactiveLoop is_tty True)
247 GHCiState{ progname = "<interactive>",
249 prompt = location++"> ",
250 editor = default_editor,
254 writeIORef ref hsc_env
255 putStrLn $ "Returning to normal execution..."
263 win <- System.Win32.getWindowsDirectory
264 return (win `joinFileName` "notepad.exe")
269 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
270 interactiveUI session srcs maybe_expr = do
271 #if defined(GHCI) && defined(BREAKPOINT)
272 initDynLinker =<< GHC.getSessionDynFlags session
273 extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))
274 ,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))]
276 -- HACK! If we happen to get into an infinite loop (eg the user
277 -- types 'let x=x in x' at the prompt), then the thread will block
278 -- on a blackhole, and become unreachable during GC. The GC will
279 -- detect that it is unreachable and send it the NonTermination
280 -- exception. However, since the thread is unreachable, everything
281 -- it refers to might be finalized, including the standard Handles.
282 -- This sounds like a bug, but we don't have a good solution right
288 -- Initialise buffering for the *interpreted* I/O system
289 initInterpBuffering session
291 when (isNothing maybe_expr) $ do
292 -- Only for GHCi (not runghc and ghc -e):
293 -- Turn buffering off for the compiled program's stdout/stderr
295 -- Turn buffering off for GHCi's stdout
297 hSetBuffering stdout NoBuffering
298 -- We don't want the cmd line to buffer any input that might be
299 -- intended for the program, so unbuffer stdin.
300 hSetBuffering stdin NoBuffering
302 -- initial context is just the Prelude
303 prel_mod <- GHC.findModule session prel_name Nothing
304 GHC.setContext session [] [prel_mod]
308 Readline.setAttemptedCompletionFunction (Just completeWord)
309 --Readline.parseAndBind "set show-all-if-ambiguous 1"
311 let symbols = "!#$%&*+/<=>?@\\^|-~"
312 specials = "(),;[]`{}"
314 word_break_chars = spaces ++ specials ++ symbols
316 Readline.setBasicWordBreakCharacters word_break_chars
317 Readline.setCompleterWordBreakCharacters word_break_chars
320 default_editor <- findEditor
322 startGHCi (runGHCi srcs maybe_expr)
323 GHCiState{ progname = "<interactive>",
326 editor = default_editor,
332 Readline.resetTerminal Nothing
337 prel_name = GHC.mkModuleName "Prelude"
339 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
340 runGHCi paths maybe_expr = do
341 let read_dot_files = not opt_IgnoreDotGhci
343 when (read_dot_files) $ do
346 exists <- io (doesFileExist file)
348 dir_ok <- io (checkPerms ".")
349 file_ok <- io (checkPerms file)
350 when (dir_ok && file_ok) $ do
351 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
354 Right hdl -> fileLoop hdl False
356 when (read_dot_files) $ do
357 -- Read in $HOME/.ghci
358 either_dir <- io (IO.try (getEnv "HOME"))
362 cwd <- io (getCurrentDirectory)
363 when (dir /= cwd) $ do
364 let file = dir ++ "/.ghci"
365 ok <- io (checkPerms file)
367 either_hdl <- io (IO.try (openFile file ReadMode))
370 Right hdl -> fileLoop hdl False
372 -- Perform a :load for files given on the GHCi command line
373 -- When in -e mode, if the load fails then we want to stop
374 -- immediately rather than going on to evaluate the expression.
375 when (not (null paths)) $ do
376 ok <- ghciHandle (\e -> do showException e; return Failed) $
378 when (isJust maybe_expr && failed ok) $
379 io (exitWith (ExitFailure 1))
381 -- if verbosity is greater than 0, or we are connected to a
382 -- terminal, display the prompt in the interactive loop.
383 is_tty <- io (hIsTerminalDevice stdin)
384 dflags <- getDynFlags
385 let show_prompt = verbosity dflags > 0 || is_tty
390 #if defined(mingw32_HOST_OS)
391 -- The win32 Console API mutates the first character of
392 -- type-ahead when reading from it in a non-buffered manner. Work
393 -- around this by flushing the input buffer of type-ahead characters,
394 -- but only if stdin is available.
395 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
397 Left err | isDoesNotExistError err -> return ()
398 | otherwise -> io (ioError err)
399 Right () -> return ()
401 -- initialise the console if necessary
404 -- enter the interactive loop
405 interactiveLoop is_tty show_prompt
407 -- just evaluate the expression we were given
412 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
415 interactiveLoop is_tty show_prompt =
416 -- Ignore ^C exceptions caught here
417 ghciHandleDyn (\e -> case e of
419 #if defined(mingw32_HOST_OS)
422 interactiveLoop is_tty show_prompt
423 _other -> return ()) $
425 ghciUnblock $ do -- unblock necessary if we recursed from the
426 -- exception handler above.
428 -- read commands from stdin
432 else fileLoop stdin show_prompt
434 fileLoop stdin show_prompt
438 -- NOTE: We only read .ghci files if they are owned by the current user,
439 -- and aren't world writable. Otherwise, we could be accidentally
440 -- running code planted by a malicious third party.
442 -- Furthermore, We only read ./.ghci if . is owned by the current user
443 -- and isn't writable by anyone else. I think this is sufficient: we
444 -- don't need to check .. and ../.. etc. because "." always refers to
445 -- the same directory while a process is running.
447 checkPerms :: String -> IO Bool
449 #ifdef mingw32_HOST_OS
452 Util.handle (\_ -> return False) $ do
453 st <- getFileStatus name
455 if fileOwner st /= me then do
456 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
459 let mode = fileMode st
460 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
461 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
463 putStrLn $ "*** WARNING: " ++ name ++
464 " is writable by someone else, IGNORING!"
469 fileLoop :: Handle -> Bool -> GHCi ()
470 fileLoop hdl show_prompt = do
471 session <- getSession
472 (mod,imports) <- io (GHC.getContext session)
474 when show_prompt (io (putStr (mkPrompt mod imports (prompt st))))
475 l <- io (IO.try (hGetLine hdl))
477 Left e | isEOFError e -> return ()
478 | InvalidArgument <- etype -> return ()
479 | otherwise -> io (ioError e)
480 where etype = ioeGetErrorType e
481 -- treat InvalidArgument in the same way as EOF:
482 -- this can happen if the user closed stdin, or
483 -- perhaps did getContents which closes stdin at
486 case removeSpaces l of
487 "" -> fileLoop hdl show_prompt
488 l -> do quit <- runCommand l
489 if quit then return () else fileLoop hdl show_prompt
491 stringLoop :: [String] -> GHCi Bool{-True: we quit-}
492 stringLoop [] = return False
493 stringLoop (s:ss) = do
494 case removeSpaces s of
496 l -> do quit <- runCommand l
497 if quit then return True else stringLoop ss
499 mkPrompt toplevs exports prompt
500 = showSDoc $ f prompt
502 f ('%':'s':xs) = perc_s <> f xs
503 f ('%':'%':xs) = char '%' <> f xs
504 f (x:xs) = char x <> f xs
507 perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
508 hsep (map (ppr . GHC.moduleName) exports)
512 readlineLoop :: GHCi ()
514 session <- getSession
515 (mod,imports) <- io (GHC.getContext session)
517 saveSession -- for use by completion
519 l <- io (readline (mkPrompt mod imports (prompt st))
520 `finally` setNonBlockingFD 0)
521 -- readline sometimes puts stdin into blocking mode,
522 -- so we need to put it back for the IO library
527 case removeSpaces l of
532 if quit then return () else readlineLoop
535 runCommand :: String -> GHCi Bool
536 runCommand c = ghciHandle handler (doCommand c)
538 doCommand (':' : command) = specialCommand command
540 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
543 -- This version is for the GHC command-line option -e. The only difference
544 -- from runCommand is that it catches the ExitException exception and
545 -- exits, rather than printing out the exception.
546 runCommandEval c = ghciHandle handleEval (doCommand c)
548 handleEval (ExitException code) = io (exitWith code)
549 handleEval e = do handler e
550 io (exitWith (ExitFailure 1))
552 doCommand (':' : command) = specialCommand command
554 = do nms <- runStmt stmt
556 Nothing -> io (exitWith (ExitFailure 1))
557 -- failure to run the command causes exit(1) for ghc -e.
558 _ -> finishEvalExpr nms
560 -- This is the exception handler for exceptions generated by the
561 -- user's code; it normally just prints out the exception. The
562 -- handler must be recursive, in case showing the exception causes
563 -- more exceptions to be raised.
565 -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
566 -- raising another exception. We therefore don't put the recursive
567 -- handler arond the flushing operation, so if stderr is closed
568 -- GHCi will just die gracefully rather than going into an infinite loop.
569 handler :: Exception -> GHCi Bool
570 handler exception = do
572 io installSignalHandlers
573 ghciHandle handler (showException exception >> return False)
575 showException (DynException dyn) =
576 case fromDynamic dyn of
577 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
578 Just Interrupted -> io (putStrLn "Interrupted.")
579 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
580 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
581 Just other_ghc_ex -> io (print other_ghc_ex)
583 showException other_exception
584 = io (putStrLn ("*** Exception: " ++ show other_exception))
586 runStmt :: String -> GHCi (Maybe [Name])
588 | null (filter (not.isSpace) stmt) = return (Just [])
590 = do st <- getGHCiState
591 session <- getSession
592 result <- io $ withProgName (progname st) $ withArgs (args st) $
593 GHC.runStmt session stmt
595 GHC.RunFailed -> return Nothing
596 GHC.RunException e -> throw e -- this is caught by runCommand(Eval)
597 GHC.RunOk names -> return (Just names)
599 -- possibly print the type and revert CAFs after evaluating an expression
600 finishEvalExpr mb_names
601 = do b <- isOptionSet ShowType
602 session <- getSession
605 Just names -> when b (mapM_ (showTypeOfName session) names)
608 io installSignalHandlers
609 b <- isOptionSet RevertCAFs
610 io (when b revertCAFs)
613 showTypeOfName :: Session -> Name -> GHCi ()
614 showTypeOfName session n
615 = do maybe_tything <- io (GHC.lookupName session n)
616 case maybe_tything of
618 Just thing -> showTyThing thing
620 showForUser :: SDoc -> GHCi String
622 session <- getSession
623 unqual <- io (GHC.getPrintUnqual session)
624 return $! showSDocForUser unqual doc
626 specialCommand :: String -> GHCi Bool
627 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
628 specialCommand str = do
629 let (cmd,rest) = break isSpace str
630 maybe_cmd <- io (lookupCommand cmd)
632 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
633 ++ shortHelpText) >> return False)
634 Just (_,f,_,_) -> f (dropWhile isSpace rest)
636 lookupCommand :: String -> IO (Maybe Command)
637 lookupCommand str = do
638 cmds <- readIORef commands
639 -- look for exact match first, then the first prefix match
640 case [ c | c <- cmds, str == cmdName c ] of
641 c:_ -> return (Just c)
642 [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
644 c:_ -> return (Just c)
646 -----------------------------------------------------------------------------
647 -- To flush buffers for the *interpreted* computation we need
648 -- to refer to *its* stdout/stderr handles
650 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
651 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
653 no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
654 " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
655 flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr"
657 initInterpBuffering :: Session -> IO ()
658 initInterpBuffering session
659 = do maybe_hval <- GHC.compileExpr session no_buf_cmd
662 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
663 other -> panic "interactiveUI:setBuffering"
665 maybe_hval <- GHC.compileExpr session flush_cmd
667 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
668 _ -> panic "interactiveUI:flush"
673 flushInterpBuffers :: GHCi ()
675 = io $ do Monad.join (readIORef flush_interp)
678 turnOffBuffering :: IO ()
680 = do Monad.join (readIORef turn_off_buffering)
683 -----------------------------------------------------------------------------
686 help :: String -> GHCi ()
687 help _ = io (putStr helpText)
689 info :: String -> GHCi ()
690 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
691 info s = do { let names = words s
692 ; session <- getSession
693 ; dflags <- getDynFlags
694 ; let exts = dopt Opt_GlasgowExts dflags
695 ; mapM_ (infoThing exts session) names }
697 infoThing exts session str = io $ do
698 names <- GHC.parseName session str
699 let filtered = filterOutChildren names
700 mb_stuffs <- mapM (GHC.getInfo session) filtered
701 unqual <- GHC.getPrintUnqual session
702 putStrLn (showSDocForUser unqual $
703 vcat (intersperse (text "") $
704 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
706 -- Filter out names whose parent is also there Good
707 -- example is '[]', which is both a type and data
708 -- constructor in the same type
709 filterOutChildren :: [Name] -> [Name]
710 filterOutChildren names = filter (not . parent_is_there) names
711 where parent_is_there n
712 -- | Just p <- GHC.nameParent_maybe n = p `elem` names
716 pprInfo exts (thing, fixity, insts)
717 = pprTyThingInContextLoc exts thing
718 $$ show_fixity fixity
719 $$ vcat (map GHC.pprInstance insts)
722 | fix == GHC.defaultFixity = empty
723 | otherwise = ppr fix <+> ppr (GHC.getName thing)
725 -----------------------------------------------------------------------------
728 runMain :: String -> GHCi ()
730 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
731 runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
734 addModule :: [FilePath] -> GHCi ()
736 io (revertCAFs) -- always revert CAFs on load/add.
737 files <- mapM expandPath files
738 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
739 session <- getSession
740 io (mapM_ (GHC.addTarget session) targets)
741 ok <- io (GHC.load session LoadAllTargets)
744 changeDirectory :: String -> GHCi ()
745 changeDirectory dir = do
746 session <- getSession
747 graph <- io (GHC.getModuleGraph session)
748 when (not (null graph)) $
749 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
750 io (GHC.setTargets session [])
751 io (GHC.load session LoadAllTargets)
752 setContextAfterLoad session []
753 io (GHC.workingDirectoryChanged session)
754 dir <- expandPath dir
755 io (setCurrentDirectory dir)
757 editFile :: String -> GHCi ()
760 -- find the name of the "topmost" file loaded
761 session <- getSession
762 graph0 <- io (GHC.getModuleGraph session)
763 graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
764 let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
765 case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
766 Just file -> do_edit file
767 Nothing -> throwDyn (CmdLineError "unknown file name")
768 | otherwise = do_edit str
774 throwDyn (CmdLineError "editor not set, use :set editor")
775 io $ system (cmd ++ ' ':file)
778 defineMacro :: String -> GHCi ()
780 let (macro_name, definition) = break isSpace s
781 cmds <- io (readIORef commands)
783 then throwDyn (CmdLineError "invalid macro name")
785 if (macro_name `elem` map cmdName cmds)
786 then throwDyn (CmdLineError
787 ("command '" ++ macro_name ++ "' is already defined"))
790 -- give the expression a type signature, so we can be sure we're getting
791 -- something of the right type.
792 let new_expr = '(' : definition ++ ") :: String -> IO String"
794 -- compile the expression
796 maybe_hv <- io (GHC.compileExpr cms new_expr)
799 Just hv -> io (writeIORef commands --
800 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
802 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
804 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
805 stringLoop (lines str)
807 undefineMacro :: String -> GHCi ()
808 undefineMacro macro_name = do
809 cmds <- io (readIORef commands)
810 if (macro_name `elem` map cmdName builtin_commands)
811 then throwDyn (CmdLineError
812 ("command '" ++ macro_name ++ "' cannot be undefined"))
814 if (macro_name `notElem` map cmdName cmds)
815 then throwDyn (CmdLineError
816 ("command '" ++ macro_name ++ "' not defined"))
818 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
821 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
822 loadModule fs = timeIt (loadModule' fs)
824 loadModule_ :: [FilePath] -> GHCi ()
825 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
827 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
828 loadModule' files = do
829 session <- getSession
832 io (GHC.setTargets session [])
833 io (GHC.load session LoadAllTargets)
836 let (filenames, phases) = unzip files
837 exp_filenames <- mapM expandPath filenames
838 let files' = zip exp_filenames phases
839 targets <- io (mapM (uncurry GHC.guessTarget) files')
841 -- NOTE: we used to do the dependency anal first, so that if it
842 -- fails we didn't throw away the current set of modules. This would
843 -- require some re-working of the GHC interface, so we'll leave it
844 -- as a ToDo for now.
846 io (GHC.setTargets session targets)
847 ok <- io (GHC.load session LoadAllTargets)
851 checkModule :: String -> GHCi ()
853 let modl = GHC.mkModuleName m
854 session <- getSession
855 result <- io (GHC.checkModule session modl)
857 Nothing -> io $ putStrLn "Nothing"
858 Just r -> io $ putStrLn (showSDoc (
859 case GHC.checkedModuleInfo r of
860 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
862 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
864 (text "global names: " <+> ppr global) $$
865 (text "local names: " <+> ppr local)
867 afterLoad (successIf (isJust result)) session
869 reloadModule :: String -> GHCi ()
871 io (revertCAFs) -- always revert CAFs on reload.
872 session <- getSession
873 ok <- io (GHC.load session LoadAllTargets)
876 io (revertCAFs) -- always revert CAFs on reload.
877 session <- getSession
878 ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
881 afterLoad ok session = do
882 io (revertCAFs) -- always revert CAFs on load.
883 graph <- io (GHC.getModuleGraph session)
884 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
885 setContextAfterLoad session graph'
886 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
887 #if defined(GHCI) && defined(BREAKPOINT)
888 io (extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))
889 ,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))])
892 setContextAfterLoad session [] = do
893 prel_mod <- getPrelude
894 io (GHC.setContext session [] [prel_mod])
895 setContextAfterLoad session ms = do
896 -- load a target if one is available, otherwise load the topmost module.
897 targets <- io (GHC.getTargets session)
898 case [ m | Just m <- map (findTarget ms) targets ] of
900 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
901 load_this (last graph')
906 = case filter (`matches` t) ms of
910 summary `matches` Target (TargetModule m) _
911 = GHC.ms_mod_name summary == m
912 summary `matches` Target (TargetFile f _) _
913 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
914 summary `matches` target
917 load_this summary | m <- GHC.ms_mod summary = do
918 b <- io (GHC.moduleIsInterpreted session m)
919 if b then io (GHC.setContext session [m] [])
921 prel_mod <- getPrelude
922 io (GHC.setContext session [] [prel_mod,m])
925 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
926 modulesLoadedMsg ok mods = do
927 dflags <- getDynFlags
928 when (verbosity dflags > 0) $ do
930 | null mods = text "none."
932 punctuate comma (map ppr mods)) <> text "."
935 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
937 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
940 typeOfExpr :: String -> GHCi ()
942 = do cms <- getSession
943 maybe_ty <- io (GHC.exprType cms str)
946 Just ty -> do ty' <- cleanType ty
947 tystr <- showForUser (ppr ty')
948 io (putStrLn (str ++ " :: " ++ tystr))
950 kindOfType :: String -> GHCi ()
952 = do cms <- getSession
953 maybe_ty <- io (GHC.typeKind cms str)
956 Just ty -> do tystr <- showForUser (ppr ty)
957 io (putStrLn (str ++ " :: " ++ tystr))
959 quit :: String -> GHCi Bool
962 shellEscape :: String -> GHCi Bool
963 shellEscape str = io (system str >> return False)
965 -----------------------------------------------------------------------------
966 -- create tags file for currently loaded modules.
968 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
970 createCTagsFileCmd "" = ghciCreateTagsFile CTags "tags"
971 createCTagsFileCmd file = ghciCreateTagsFile CTags file
973 createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"
974 createETagsFileCmd file = ghciCreateTagsFile ETags file
976 data TagsKind = ETags | CTags
978 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
979 ghciCreateTagsFile kind file = do
980 session <- getSession
981 io $ createTagsFile session kind file
984 -- - remove restriction that all modules must be interpreted
985 -- (problem: we don't know source locations for entities unless
986 -- we compiled the module.
988 -- - extract createTagsFile so it can be used from the command-line
989 -- (probably need to fix first problem before this is useful).
991 createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
992 createTagsFile session tagskind tagFile = do
993 graph <- GHC.getModuleGraph session
994 let ms = map GHC.ms_mod graph
996 is_interpreted <- GHC.moduleIsInterpreted session m
997 -- should we just skip these?
998 when (not is_interpreted) $
999 throwDyn (CmdLineError ("module '"
1000 ++ GHC.moduleNameString (GHC.moduleName m)
1001 ++ "' is not interpreted"))
1002 mbModInfo <- GHC.getModuleInfo session m
1004 | Just modinfo <- mbModInfo,
1005 Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
1006 | otherwise = GHC.alwaysQualify
1009 Just modInfo -> return $! listTags unqual modInfo
1012 mtags <- mapM tagModule ms
1013 either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
1015 Left e -> hPutStrLn stderr $ ioeGetErrorString e
1016 Right _ -> return ()
1018 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
1019 listTags unqual modInfo =
1020 [ tagInfo unqual name loc
1021 | name <- GHC.modInfoExports modInfo
1022 , let loc = nameSrcLoc name
1026 type TagInfo = (String -- tag name
1027 ,String -- file name
1029 ,Int -- column number
1032 -- get tag info, for later translation into Vim or Emacs style
1033 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
1034 tagInfo unqual name loc
1035 = ( showSDocForUser unqual $ pprOccName (nameOccName name)
1036 , showSDocForUser unqual $ ftext (srcLocFile loc)
1041 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
1042 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
1043 let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
1044 IO.try (writeFile file tags)
1045 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
1046 let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
1047 groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
1048 tagGroups <- mapM tagFileGroup groups
1049 IO.try (writeFile file $ concat tagGroups)
1051 tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
1052 tagFileGroup group@((_,fileName,_,_):_) = do
1053 file <- readFile fileName -- need to get additional info from sources..
1054 let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
1055 sortedGroup = sortLe byLine group
1056 tags = unlines $ perFile sortedGroup 1 0 $ lines file
1057 return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
1058 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
1059 perFile (tagInfo:tags) (count+1) (pos+length line) lines
1060 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
1061 showETag tagInfo line pos : perFile tags count pos lines
1062 perFile tags count pos lines = []
1064 -- simple ctags format, for Vim et al
1065 showTag :: TagInfo -> String
1066 showTag (tag,file,lineNo,colNo)
1067 = tag ++ "\t" ++ file ++ "\t" ++ show lineNo
1069 -- etags format, for Emacs/XEmacs
1070 showETag :: TagInfo -> String -> Int -> String
1071 showETag (tag,file,lineNo,colNo) line charPos
1072 = take colNo line ++ tag
1074 ++ "\x01" ++ show lineNo
1075 ++ "," ++ show charPos
1077 -----------------------------------------------------------------------------
1078 -- Browsing a module's contents
1080 browseCmd :: String -> GHCi ()
1083 ['*':m] | looksLikeModuleName m -> browseModule m False
1084 [m] | looksLikeModuleName m -> browseModule m True
1085 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
1087 browseModule m exports_only = do
1089 modl <- io $ GHC.findModule s (GHC.mkModuleName m) Nothing
1090 is_interpreted <- io (GHC.moduleIsInterpreted s modl)
1091 when (not is_interpreted && not exports_only) $
1092 throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
1094 -- Temporarily set the context to the module we're interested in,
1095 -- just so we can get an appropriate PrintUnqualified
1096 (as,bs) <- io (GHC.getContext s)
1097 prel_mod <- getPrelude
1098 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1099 else GHC.setContext s [modl] [])
1100 unqual <- io (GHC.getPrintUnqual s)
1101 io (GHC.setContext s as bs)
1103 mb_mod_info <- io $ GHC.getModuleInfo s modl
1105 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
1108 | exports_only = GHC.modInfoExports mod_info
1109 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
1111 filtered = filterOutChildren names
1113 things <- io $ mapM (GHC.lookupName s) filtered
1115 dflags <- getDynFlags
1116 let exts = dopt Opt_GlasgowExts dflags
1117 io (putStrLn (showSDocForUser unqual (
1118 vcat (map (pprTyThingInContext exts) (catMaybes things))
1120 -- ToDo: modInfoInstances currently throws an exception for
1121 -- package modules. When it works, we can do this:
1122 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1124 -----------------------------------------------------------------------------
1125 -- Setting the module context
1128 | all sensible mods = fn mods
1129 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1131 (fn, mods) = case str of
1132 '+':stuff -> (addToContext, words stuff)
1133 '-':stuff -> (removeFromContext, words stuff)
1134 stuff -> (newContext, words stuff)
1136 sensible ('*':m) = looksLikeModuleName m
1137 sensible m = looksLikeModuleName m
1139 separate :: Session -> [String] -> [Module] -> [Module]
1140 -> GHCi ([Module],[Module])
1141 separate session [] as bs = return (as,bs)
1142 separate session (('*':str):ms) as bs = do
1143 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1144 b <- io $ GHC.moduleIsInterpreted session m
1145 if b then separate session ms (m:as) bs
1146 else throwDyn (CmdLineError ("module '"
1147 ++ GHC.moduleNameString (GHC.moduleName m)
1148 ++ "' is not interpreted"))
1149 separate session (str:ms) as bs = do
1150 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1151 separate session ms as (m:bs)
1153 newContext :: [String] -> GHCi ()
1154 newContext strs = do
1156 (as,bs) <- separate s strs [] []
1157 prel_mod <- getPrelude
1158 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1159 io $ GHC.setContext s as bs'
1162 addToContext :: [String] -> GHCi ()
1163 addToContext strs = do
1165 (as,bs) <- io $ GHC.getContext s
1167 (new_as,new_bs) <- separate s strs [] []
1169 let as_to_add = new_as \\ (as ++ bs)
1170 bs_to_add = new_bs \\ (as ++ bs)
1172 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1175 removeFromContext :: [String] -> GHCi ()
1176 removeFromContext strs = do
1178 (as,bs) <- io $ GHC.getContext s
1180 (as_to_remove,bs_to_remove) <- separate s strs [] []
1182 let as' = as \\ (as_to_remove ++ bs_to_remove)
1183 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1185 io $ GHC.setContext s as' bs'
1187 ----------------------------------------------------------------------------
1190 -- set options in the interpreter. Syntax is exactly the same as the
1191 -- ghc command line, except that certain options aren't available (-C,
1194 -- This is pretty fragile: most options won't work as expected. ToDo:
1195 -- figure out which ones & disallow them.
1197 setCmd :: String -> GHCi ()
1199 = do st <- getGHCiState
1200 let opts = options st
1201 io $ putStrLn (showSDoc (
1202 text "options currently set: " <>
1205 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1208 = case toArgs str of
1209 ("args":args) -> setArgs args
1210 ("prog":prog) -> setProg prog
1211 ("prompt":prompt) -> setPrompt (after 6)
1212 ("editor":cmd) -> setEditor (after 6)
1213 wds -> setOptions wds
1214 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1218 setGHCiState st{ args = args }
1222 setGHCiState st{ progname = prog }
1224 io (hPutStrLn stderr "syntax: :set prog <progname>")
1228 setGHCiState st{ editor = cmd }
1230 setPrompt value = do
1233 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1234 else setGHCiState st{ prompt = remQuotes value }
1236 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1240 do -- first, deal with the GHCi opts (+s, +t, etc.)
1241 let (plus_opts, minus_opts) = partition isPlus wds
1242 mapM_ setOpt plus_opts
1244 -- then, dynamic flags
1245 dflags <- getDynFlags
1246 let pkg_flags = packageFlags dflags
1247 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1249 if (not (null leftovers))
1250 then throwDyn (CmdLineError ("unrecognised flags: " ++
1254 new_pkgs <- setDynFlags dflags'
1256 -- if the package flags changed, we should reset the context
1257 -- and link the new packages.
1258 dflags <- getDynFlags
1259 when (packageFlags dflags /= pkg_flags) $ do
1260 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1261 session <- getSession
1262 io (GHC.setTargets session [])
1263 io (GHC.load session LoadAllTargets)
1264 io (linkPackages dflags new_pkgs)
1265 setContextAfterLoad session []
1269 unsetOptions :: String -> GHCi ()
1271 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1272 let opts = words str
1273 (minus_opts, rest1) = partition isMinus opts
1274 (plus_opts, rest2) = partition isPlus rest1
1276 if (not (null rest2))
1277 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1280 mapM_ unsetOpt plus_opts
1282 -- can't do GHC flags for now
1283 if (not (null minus_opts))
1284 then throwDyn (CmdLineError "can't unset GHC command-line flags")
1287 isMinus ('-':s) = True
1290 isPlus ('+':s) = True
1294 = case strToGHCiOpt str of
1295 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1296 Just o -> setOption o
1299 = case strToGHCiOpt str of
1300 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1301 Just o -> unsetOption o
1303 strToGHCiOpt :: String -> (Maybe GHCiOption)
1304 strToGHCiOpt "s" = Just ShowTiming
1305 strToGHCiOpt "t" = Just ShowType
1306 strToGHCiOpt "r" = Just RevertCAFs
1307 strToGHCiOpt _ = Nothing
1309 optToStr :: GHCiOption -> String
1310 optToStr ShowTiming = "s"
1311 optToStr ShowType = "t"
1312 optToStr RevertCAFs = "r"
1314 -- ---------------------------------------------------------------------------
1319 ["modules" ] -> showModules
1320 ["bindings"] -> showBindings
1321 ["linker"] -> io showLinkerState
1322 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
1325 session <- getSession
1326 let show_one ms = do m <- io (GHC.showModule session ms)
1328 graph <- io (GHC.getModuleGraph session)
1329 mapM_ show_one graph
1333 unqual <- io (GHC.getPrintUnqual s)
1334 bindings <- io (GHC.getBindings s)
1335 mapM_ showTyThing bindings
1338 showTyThing (AnId id) = do
1339 ty' <- cleanType (GHC.idType id)
1340 str <- showForUser (ppr id <> text " :: " <> ppr ty')
1342 showTyThing _ = return ()
1344 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1345 cleanType :: Type -> GHCi Type
1347 dflags <- getDynFlags
1348 if dopt Opt_GlasgowExts dflags
1350 else return $! GHC.dropForAlls ty
1352 -- -----------------------------------------------------------------------------
1355 completeNone :: String -> IO [String]
1356 completeNone w = return []
1359 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1360 completeWord w start end = do
1361 line <- Readline.getLineBuffer
1363 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1365 | Just c <- is_cmd line -> do
1366 maybe_cmd <- lookupCommand c
1367 let (n,w') = selectWord (words' 0 line)
1369 Nothing -> return Nothing
1370 Just (_,_,False,complete) -> wrapCompleter complete w
1371 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1372 return (map (drop n) rets)
1373 in wrapCompleter complete' w'
1375 --printf "complete %s, start = %d, end = %d\n" w start end
1376 wrapCompleter completeIdentifier w
1377 where words' _ [] = []
1378 words' n str = let (w,r) = break isSpace str
1379 (s,r') = span isSpace r
1380 in (n,w):words' (n+length w+length s) r'
1381 -- In a Haskell expression we want to parse 'a-b' as three words
1382 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1383 -- only be a single word.
1384 selectWord [] = (0,w)
1385 selectWord ((offset,x):xs)
1386 | offset+length x >= start = (start-offset,take (end-offset) x)
1387 | otherwise = selectWord xs
1390 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1391 | otherwise = Nothing
1394 cmds <- readIORef commands
1395 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1397 completeMacro w = do
1398 cmds <- readIORef commands
1399 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1400 return (filter (w `isPrefixOf`) cmds')
1402 completeIdentifier w = do
1404 rdrs <- GHC.getRdrNamesInScope s
1405 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1407 completeModule w = do
1409 dflags <- GHC.getSessionDynFlags s
1410 let pkg_mods = allExposedModules dflags
1411 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1413 completeHomeModule w = do
1415 g <- GHC.getModuleGraph s
1416 let home_mods = map GHC.ms_mod_name g
1417 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1419 completeSetOptions w = do
1420 return (filter (w `isPrefixOf`) options)
1421 where options = "args":"prog":allFlags
1423 completeFilename = Readline.filenameCompletionFunction
1425 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1427 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1428 unionComplete f1 f2 w = do
1433 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1434 wrapCompleter fun w = do
1437 [] -> return Nothing
1438 [x] -> return (Just (x,[]))
1439 xs -> case getCommonPrefix xs of
1440 "" -> return (Just ("",xs))
1441 pref -> return (Just (pref,xs))
1443 getCommonPrefix :: [String] -> String
1444 getCommonPrefix [] = ""
1445 getCommonPrefix (s:ss) = foldl common s ss
1446 where common s "" = s
1448 common (c:cs) (d:ds)
1449 | c == d = c : common cs ds
1452 allExposedModules :: DynFlags -> [ModuleName]
1453 allExposedModules dflags
1454 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1456 pkg_db = pkgIdMap (pkgState dflags)
1458 completeCmd = completeNone
1459 completeMacro = completeNone
1460 completeIdentifier = completeNone
1461 completeModule = completeNone
1462 completeHomeModule = completeNone
1463 completeSetOptions = completeNone
1464 completeFilename = completeNone
1465 completeHomeModuleOrFile=completeNone
1468 -----------------------------------------------------------------------------
1471 data GHCiState = GHCiState
1477 session :: GHC.Session,
1478 options :: [GHCiOption],
1483 = ShowTiming -- show time/allocs after evaluation
1484 | ShowType -- show the type of expressions
1485 | RevertCAFs -- revert CAFs after every evaluation
1488 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
1490 startGHCi :: GHCi a -> GHCiState -> IO a
1491 startGHCi g state = do ref <- newIORef state; unGHCi g ref
1493 instance Monad GHCi where
1494 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
1495 return a = GHCi $ \s -> return a
1497 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
1498 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
1499 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
1501 getGHCiState = GHCi $ \r -> readIORef r
1502 setGHCiState s = GHCi $ \r -> writeIORef r s
1504 -- for convenience...
1505 getSession = getGHCiState >>= return . session
1506 getPrelude = getGHCiState >>= return . prelude
1508 GLOBAL_VAR(saved_sess, no_saved_sess, Session)
1509 no_saved_sess = error "no saved_ses"
1510 saveSession = getSession >>= io . writeIORef saved_sess
1511 splatSavedSession = io (writeIORef saved_sess no_saved_sess)
1512 restoreSession = readIORef saved_sess
1516 io (GHC.getSessionDynFlags s)
1517 setDynFlags dflags = do
1519 io (GHC.setSessionDynFlags s dflags)
1521 isOptionSet :: GHCiOption -> GHCi Bool
1523 = do st <- getGHCiState
1524 return (opt `elem` options st)
1526 setOption :: GHCiOption -> GHCi ()
1528 = do st <- getGHCiState
1529 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
1531 unsetOption :: GHCiOption -> GHCi ()
1533 = do st <- getGHCiState
1534 setGHCiState (st{ options = filter (/= opt) (options st) })
1536 io :: IO a -> GHCi a
1537 io m = GHCi { unGHCi = \s -> m >>= return }
1539 -----------------------------------------------------------------------------
1540 -- recursive exception handlers
1542 -- Don't forget to unblock async exceptions in the handler, or if we're
1543 -- in an exception loop (eg. let a = error a in a) the ^C exception
1544 -- may never be delivered. Thanks to Marcin for pointing out the bug.
1546 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
1547 ghciHandle h (GHCi m) = GHCi $ \s ->
1548 Exception.catch (m s)
1549 (\e -> unGHCi (ghciUnblock (h e)) s)
1551 ghciUnblock :: GHCi a -> GHCi a
1552 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
1554 -----------------------------------------------------------------------------
1555 -- timing & statistics
1557 timeIt :: GHCi a -> GHCi a
1559 = do b <- isOptionSet ShowTiming
1562 else do allocs1 <- io $ getAllocations
1563 time1 <- io $ getCPUTime
1565 allocs2 <- io $ getAllocations
1566 time2 <- io $ getCPUTime
1567 io $ printTimes (fromIntegral (allocs2 - allocs1))
1571 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
1572 -- defined in ghc/rts/Stats.c
1574 printTimes :: Integer -> Integer -> IO ()
1575 printTimes allocs psecs
1576 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1577 secs_str = showFFloat (Just 2) secs
1578 putStrLn (showSDoc (
1579 parens (text (secs_str "") <+> text "secs" <> comma <+>
1580 text (show allocs) <+> text "bytes")))
1582 -----------------------------------------------------------------------------
1589 -- Have to turn off buffering again, because we just
1590 -- reverted stdout, stderr & stdin to their defaults.
1592 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
1593 -- Make it "safe", just in case
1595 -- ----------------------------------------------------------------------------
1598 expandPath :: String -> GHCi String
1600 case dropWhile isSpace path of
1602 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1603 return (tilde ++ '/':d)
1607 -- ----------------------------------------------------------------------------
1608 -- Windows console setup
1610 setUpConsole :: IO ()
1612 #ifdef mingw32_HOST_OS
1613 -- On Windows we need to set a known code page, otherwise the characters
1614 -- we read from the console will be be in some strange encoding, and
1615 -- similarly for characters we write to the console.
1617 -- At the moment, GHCi pretends all input is Latin-1. In the
1618 -- future we should support UTF-8, but for now we set the code pages
1621 -- It seems you have to set the font in the console window to
1622 -- a Unicode font in order for output to work properly,
1623 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1624 -- (see MSDN for SetConsoleOutputCP()).
1626 setConsoleCP 28591 -- ISO Latin-1
1627 setConsoleOutputCP 28591 -- ISO Latin-1