e7a5a37edb9c793863fe6e09842344ae3849bdb8
[ghc.git] / compiler / ghci / InteractiveUI.hs
1 {-# OPTIONS -#include "Linker.h" #-}
2 -----------------------------------------------------------------------------
3 --
4 -- GHC Interactive User Interface
5 --
6 -- (c) The GHC Team 2005-2006
7 --
8 -----------------------------------------------------------------------------
9 module InteractiveUI (
10 interactiveUI,
11 ghciWelcomeMsg
12 ) where
13
14 #include "HsVersions.h"
15
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 )
20 import Var
21 import HscTypes
22 import RdrName
23 import NameEnv
24 import TcType
25 import qualified Id
26 import IdInfo
27 import PrelNames
28 #endif
29
30 -- The GHC interface
31 import qualified GHC
32 import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
33 Type, Module, ModuleName, TyThing(..), Phase )
34 import DynFlags
35 import Packages
36 import PackageConfig
37 import UniqFM
38 import PprTyThing
39 import Outputable
40
41 -- for createtags
42 import Name
43 import OccName
44 import SrcLoc
45
46 -- Other random utilities
47 import Digraph
48 import BasicTypes
49 import Panic hiding (showException)
50 import Config
51 import StaticFlags
52 import Linker
53 import Util
54
55 #ifndef mingw32_HOST_OS
56 import System.Posix
57 #if __GLASGOW_HASKELL__ > 504
58 hiding (getEnv)
59 #endif
60 #else
61 import GHC.ConsoleHandler ( flushConsole )
62 import System.Win32 ( setConsoleCP, setConsoleOutputCP )
63 import qualified System.Win32
64 #endif
65
66 #ifdef USE_READLINE
67 import Control.Concurrent ( yield ) -- Used in readline loop
68 import System.Console.Readline as Readline
69 #endif
70
71 --import SystemExts
72
73 import Control.Exception as Exception
74 -- import Control.Concurrent
75
76 import Numeric
77 import Data.List
78 import Data.Int ( Int64 )
79 import Data.Maybe ( isJust, isNothing, fromMaybe, catMaybes )
80 import System.Cmd
81 import System.Environment
82 import System.Exit ( exitWith, ExitCode(..) )
83 import System.Directory
84 import System.IO
85 import System.IO.Error as IO
86 import Data.Char
87 import Control.Monad as Monad
88 import Foreign.StablePtr ( newStablePtr )
89
90 import GHC.Exts ( unsafeCoerce# )
91 import GHC.IOBase ( IOErrorType(InvalidArgument) )
92
93 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
94
95 import System.Posix.Internals ( setNonBlockingFD )
96
97 -----------------------------------------------------------------------------
98
99 ghciWelcomeMsg =
100 " ___ ___ _\n"++
101 " / _ \\ /\\ /\\/ __(_)\n"++
102 " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
103 "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
104 "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
105
106 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
107 cmdName (n,_,_,_) = n
108
109 GLOBAL_VAR(commands, builtin_commands, [Command])
110
111 builtin_commands :: [Command]
112 builtin_commands = [
113 ("add", keepGoingPaths addModule, False, completeFilename),
114 ("browse", keepGoing browseCmd, False, completeModule),
115 ("cd", keepGoing changeDirectory, False, completeFilename),
116 ("def", keepGoing defineMacro, False, completeIdentifier),
117 ("e", keepGoing editFile, False, completeFilename),
118 -- Hugs users are accustomed to :e, so make sure it doesn't overlap
119 ("edit", keepGoing editFile, False, completeFilename),
120 ("help", keepGoing help, False, completeNone),
121 ("?", keepGoing help, False, completeNone),
122 ("info", keepGoing info, False, completeIdentifier),
123 ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
124 ("module", keepGoing setContext, False, completeModule),
125 ("main", keepGoing runMain, False, completeIdentifier),
126 ("reload", keepGoing reloadModule, False, completeNone),
127 ("check", keepGoing checkModule, False, completeHomeModule),
128 ("set", keepGoing setCmd, True, completeSetOptions),
129 ("show", keepGoing showCmd, False, completeNone),
130 ("etags", keepGoing createETagsFileCmd, False, completeFilename),
131 ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
132 ("type", keepGoing typeOfExpr, False, completeIdentifier),
133 ("kind", keepGoing kindOfType, False, completeIdentifier),
134 ("unset", keepGoing unsetOptions, True, completeSetOptions),
135 ("undef", keepGoing undefineMacro, False, completeMacro),
136 ("quit", quit, False, completeNone)
137 ]
138
139 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
140 keepGoing a str = a str >> return False
141
142 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
143 keepGoingPaths a str = a (toArgs str) >> return False
144
145 shortHelpText = "use :? for help.\n"
146
147 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
148 helpText =
149 " Commands available from the prompt:\n" ++
150 "\n" ++
151 " <stmt> evaluate/run <stmt>\n" ++
152 " :add <filename> ... add module(s) to the current target set\n" ++
153 " :browse [*]<module> display the names defined by <module>\n" ++
154 " :cd <dir> change directory to <dir>\n" ++
155 " :def <cmd> <expr> define a command :<cmd>\n" ++
156 " :edit <file> edit file\n" ++
157 " :edit edit last module\n" ++
158 " :help, :? display this list of commands\n" ++
159 " :info [<name> ...] display information about the given names\n" ++
160 " :load <filename> ... load module(s) and their dependents\n" ++
161 " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
162 " :main [<arguments> ...] run the main function with the given arguments\n" ++
163 " :reload reload the current module set\n" ++
164 "\n" ++
165 " :set <option> ... set options\n" ++
166 " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
167 " :set prog <progname> set the value returned by System.getProgName\n" ++
168 " :set prompt <prompt> set the prompt used in GHCi\n" ++
169 " :set editor <cmd> set the command used for :edit\n" ++
170 "\n" ++
171 " :show modules show the currently loaded modules\n" ++
172 " :show bindings show the current bindings made at the prompt\n" ++
173 "\n" ++
174 " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
175 " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
176 " :type <expr> show the type of <expr>\n" ++
177 " :kind <type> show the kind of <type>\n" ++
178 " :undef <cmd> undefine user-defined command :<cmd>\n" ++
179 " :unset <option> ... unset options\n" ++
180 " :quit exit GHCi\n" ++
181 " :!<command> run the shell command <command>\n" ++
182 "\n" ++
183 " Options for ':set' and ':unset':\n" ++
184 "\n" ++
185 " +r revert top-level expressions after each evaluation\n" ++
186 " +s print timing/memory stats after each evaluation\n" ++
187 " +t print type after evaluation\n" ++
188 " -<flags> most GHC command line flags can also be set here\n" ++
189 " (eg. -v2, -fglasgow-exts, etc.)\n"
190
191
192 #if defined(GHCI) && defined(BREAKPOINT)
193 globaliseAndTidy :: Id -> Id
194 globaliseAndTidy id
195 -- Give the Id a Global Name, and tidy its type
196 = Id.setIdType (globaliseId VanillaGlobal id) tidy_type
197 where
198 tidy_type = tidyTopType (idType id)
199
200
201 printScopeMsg :: Session -> String -> [Id] -> IO ()
202 printScopeMsg session location ids
203 = GHC.getPrintUnqual session >>= \unqual ->
204 printForUser stdout unqual $
205 text "Local bindings in scope:" $$
206 nest 2 (pprWithCommas showId ids)
207 where showId id = ppr (idName id) <+> dcolon <+> ppr (idType id)
208
209 jumpCondFunction :: Session -> Int -> [HValue] -> String -> Bool -> b -> b
210 jumpCondFunction session ptr hValues location True b = b
211 jumpCondFunction session ptr hValues location False b
212 = jumpFunction session ptr hValues location b
213
214 jumpFunction :: Session -> Int -> [HValue] -> String -> b -> b
215 jumpFunction session@(Session ref) (I# idsPtr) hValues location b
216 = unsafePerformIO $
217 do ids <- deRefStablePtr (castPtrToStablePtr (Ptr (int2Addr# idsPtr)))
218 let names = map idName ids
219 ASSERT (length names == length hValues) return ()
220 printScopeMsg session location ids
221 hsc_env <- readIORef ref
222
223 let ictxt = hsc_IC hsc_env
224 global_ids = map globaliseAndTidy ids
225 rn_env = ic_rn_local_env ictxt
226 type_env = ic_type_env ictxt
227 bound_names = map idName global_ids
228 new_rn_env = extendLocalRdrEnv rn_env bound_names
229 -- Remove any shadowed bindings from the type_env;
230 -- they are inaccessible but might, I suppose, cause
231 -- a space leak if we leave them there
232 shadowed = [ n | name <- bound_names,
233 let rdr_name = mkRdrUnqual (nameOccName name),
234 Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
235 filtered_type_env = delListFromNameEnv type_env shadowed
236 new_type_env = extendTypeEnvWithIds filtered_type_env global_ids
237 new_ic = ictxt { ic_rn_local_env = new_rn_env,
238 ic_type_env = new_type_env }
239 writeIORef ref (hsc_env { hsc_IC = new_ic })
240 is_tty <- hIsTerminalDevice stdin
241 prel_mod <- GHC.findModule session prel_name Nothing
242 default_editor <- findEditor
243 withExtendedLinkEnv (zip names hValues) $
244 startGHCi (interactiveLoop is_tty True)
245 GHCiState{ progname = "<interactive>",
246 args = [],
247 prompt = location++"> ",
248 editor = default_editor,
249 session = session,
250 options = [],
251 prelude = prel_mod }
252 writeIORef ref hsc_env
253 putStrLn $ "Returning to normal execution..."
254 return b
255 #endif
256
257 findEditor = do
258 getEnv "EDITOR"
259 `IO.catch` \_ -> do
260 #if mingw32_HOST_OS
261 win <- System.Win32.getWindowsDirectory
262 return (win `joinFileName` "notepad.exe")
263 #else
264 return ""
265 #endif
266
267 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
268 interactiveUI session srcs maybe_expr = do
269 #if defined(GHCI) && defined(BREAKPOINT)
270 initDynLinker =<< GHC.getSessionDynFlags session
271 extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))
272 ,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))]
273 #endif
274 -- HACK! If we happen to get into an infinite loop (eg the user
275 -- types 'let x=x in x' at the prompt), then the thread will block
276 -- on a blackhole, and become unreachable during GC. The GC will
277 -- detect that it is unreachable and send it the NonTermination
278 -- exception. However, since the thread is unreachable, everything
279 -- it refers to might be finalized, including the standard Handles.
280 -- This sounds like a bug, but we don't have a good solution right
281 -- now.
282 newStablePtr stdin
283 newStablePtr stdout
284 newStablePtr stderr
285
286 -- Initialise buffering for the *interpreted* I/O system
287 initInterpBuffering session
288
289 when (isNothing maybe_expr) $ do
290 -- Only for GHCi (not runghc and ghc -e):
291 -- Turn buffering off for the compiled program's stdout/stderr
292 turnOffBuffering
293 -- Turn buffering off for GHCi's stdout
294 hFlush stdout
295 hSetBuffering stdout NoBuffering
296 -- We don't want the cmd line to buffer any input that might be
297 -- intended for the program, so unbuffer stdin.
298 hSetBuffering stdin NoBuffering
299
300 -- initial context is just the Prelude
301 prel_mod <- GHC.findModule session prel_name Nothing
302 GHC.setContext session [] [prel_mod]
303
304 #ifdef USE_READLINE
305 Readline.initialize
306 Readline.setAttemptedCompletionFunction (Just completeWord)
307 --Readline.parseAndBind "set show-all-if-ambiguous 1"
308
309 let symbols = "!#$%&*+/<=>?@\\^|-~"
310 specials = "(),;[]`{}"
311 spaces = " \t\n"
312 word_break_chars = spaces ++ specials ++ symbols
313
314 Readline.setBasicWordBreakCharacters word_break_chars
315 Readline.setCompleterWordBreakCharacters word_break_chars
316 #endif
317
318 default_editor <- findEditor
319
320 startGHCi (runGHCi srcs maybe_expr)
321 GHCiState{ progname = "<interactive>",
322 args = [],
323 prompt = "%s> ",
324 editor = default_editor,
325 session = session,
326 options = [],
327 prelude = prel_mod }
328
329 #ifdef USE_READLINE
330 Readline.resetTerminal Nothing
331 #endif
332
333 return ()
334
335 prel_name = GHC.mkModuleName "Prelude"
336
337 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
338 runGHCi paths maybe_expr = do
339 let read_dot_files = not opt_IgnoreDotGhci
340
341 when (read_dot_files) $ do
342 -- Read in ./.ghci.
343 let file = "./.ghci"
344 exists <- io (doesFileExist file)
345 when exists $ do
346 dir_ok <- io (checkPerms ".")
347 file_ok <- io (checkPerms file)
348 when (dir_ok && file_ok) $ do
349 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
350 case either_hdl of
351 Left e -> return ()
352 Right hdl -> fileLoop hdl False
353
354 when (read_dot_files) $ do
355 -- Read in $HOME/.ghci
356 either_dir <- io (IO.try (getEnv "HOME"))
357 case either_dir of
358 Left e -> return ()
359 Right dir -> do
360 cwd <- io (getCurrentDirectory)
361 when (dir /= cwd) $ do
362 let file = dir ++ "/.ghci"
363 ok <- io (checkPerms file)
364 when ok $ do
365 either_hdl <- io (IO.try (openFile file ReadMode))
366 case either_hdl of
367 Left e -> return ()
368 Right hdl -> fileLoop hdl False
369
370 -- Perform a :load for files given on the GHCi command line
371 -- When in -e mode, if the load fails then we want to stop
372 -- immediately rather than going on to evaluate the expression.
373 when (not (null paths)) $ do
374 ok <- ghciHandle (\e -> do showException e; return Failed) $
375 loadModule paths
376 when (isJust maybe_expr && failed ok) $
377 io (exitWith (ExitFailure 1))
378
379 -- if verbosity is greater than 0, or we are connected to a
380 -- terminal, display the prompt in the interactive loop.
381 is_tty <- io (hIsTerminalDevice stdin)
382 dflags <- getDynFlags
383 let show_prompt = verbosity dflags > 0 || is_tty
384
385 case maybe_expr of
386 Nothing ->
387 do
388 #if defined(mingw32_HOST_OS)
389 -- The win32 Console API mutates the first character of
390 -- type-ahead when reading from it in a non-buffered manner. Work
391 -- around this by flushing the input buffer of type-ahead characters,
392 -- but only if stdin is available.
393 flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
394 case flushed of
395 Left err | isDoesNotExistError err -> return ()
396 | otherwise -> io (ioError err)
397 Right () -> return ()
398 #endif
399 -- initialise the console if necessary
400 io setUpConsole
401
402 -- enter the interactive loop
403 interactiveLoop is_tty show_prompt
404 Just expr -> do
405 -- just evaluate the expression we were given
406 runCommandEval expr
407 return ()
408
409 -- and finally, exit
410 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
411
412
413 interactiveLoop is_tty show_prompt =
414 -- Ignore ^C exceptions caught here
415 ghciHandleDyn (\e -> case e of
416 Interrupted -> do
417 #if defined(mingw32_HOST_OS)
418 io (putStrLn "")
419 #endif
420 interactiveLoop is_tty show_prompt
421 _other -> return ()) $
422
423 ghciUnblock $ do -- unblock necessary if we recursed from the
424 -- exception handler above.
425
426 -- read commands from stdin
427 #ifdef USE_READLINE
428 if (is_tty)
429 then readlineLoop
430 else fileLoop stdin show_prompt
431 #else
432 fileLoop stdin show_prompt
433 #endif
434
435
436 -- NOTE: We only read .ghci files if they are owned by the current user,
437 -- and aren't world writable. Otherwise, we could be accidentally
438 -- running code planted by a malicious third party.
439
440 -- Furthermore, We only read ./.ghci if . is owned by the current user
441 -- and isn't writable by anyone else. I think this is sufficient: we
442 -- don't need to check .. and ../.. etc. because "." always refers to
443 -- the same directory while a process is running.
444
445 checkPerms :: String -> IO Bool
446 checkPerms name =
447 #ifdef mingw32_HOST_OS
448 return True
449 #else
450 Util.handle (\_ -> return False) $ do
451 st <- getFileStatus name
452 me <- getRealUserID
453 if fileOwner st /= me then do
454 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
455 return False
456 else do
457 let mode = fileMode st
458 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
459 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
460 then do
461 putStrLn $ "*** WARNING: " ++ name ++
462 " is writable by someone else, IGNORING!"
463 return False
464 else return True
465 #endif
466
467 fileLoop :: Handle -> Bool -> GHCi ()
468 fileLoop hdl show_prompt = do
469 session <- getSession
470 (mod,imports) <- io (GHC.getContext session)
471 st <- getGHCiState
472 when show_prompt (io (putStr (mkPrompt mod imports (prompt st))))
473 l <- io (IO.try (hGetLine hdl))
474 case l of
475 Left e | isEOFError e -> return ()
476 | InvalidArgument <- etype -> return ()
477 | otherwise -> io (ioError e)
478 where etype = ioeGetErrorType e
479 -- treat InvalidArgument in the same way as EOF:
480 -- this can happen if the user closed stdin, or
481 -- perhaps did getContents which closes stdin at
482 -- EOF.
483 Right l ->
484 case removeSpaces l of
485 "" -> fileLoop hdl show_prompt
486 l -> do quit <- runCommand l
487 if quit then return () else fileLoop hdl show_prompt
488
489 stringLoop :: [String] -> GHCi Bool{-True: we quit-}
490 stringLoop [] = return False
491 stringLoop (s:ss) = do
492 case removeSpaces s of
493 "" -> stringLoop ss
494 l -> do quit <- runCommand l
495 if quit then return True else stringLoop ss
496
497 mkPrompt toplevs exports prompt
498 = showSDoc $ f prompt
499 where
500 f ('%':'s':xs) = perc_s <> f xs
501 f ('%':'%':xs) = char '%' <> f xs
502 f (x:xs) = char x <> f xs
503 f [] = empty
504
505 perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
506 hsep (map (ppr . GHC.moduleName) exports)
507
508
509 #ifdef USE_READLINE
510 readlineLoop :: GHCi ()
511 readlineLoop = do
512 session <- getSession
513 (mod,imports) <- io (GHC.getContext session)
514 io yield
515 saveSession -- for use by completion
516 st <- getGHCiState
517 l <- io (readline (mkPrompt mod imports (prompt st))
518 `finally` setNonBlockingFD 0)
519 -- readline sometimes puts stdin into blocking mode,
520 -- so we need to put it back for the IO library
521 splatSavedSession
522 case l of
523 Nothing -> return ()
524 Just l ->
525 case removeSpaces l of
526 "" -> readlineLoop
527 l -> do
528 io (addHistory l)
529 quit <- runCommand l
530 if quit then return () else readlineLoop
531 #endif
532
533 runCommand :: String -> GHCi Bool
534 runCommand c = ghciHandle handler (doCommand c)
535 where
536 doCommand (':' : command) = specialCommand command
537 doCommand stmt
538 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
539 return False
540
541 -- This version is for the GHC command-line option -e. The only difference
542 -- from runCommand is that it catches the ExitException exception and
543 -- exits, rather than printing out the exception.
544 runCommandEval c = ghciHandle handleEval (doCommand c)
545 where
546 handleEval (ExitException code) = io (exitWith code)
547 handleEval e = do handler e
548 io (exitWith (ExitFailure 1))
549
550 doCommand (':' : command) = specialCommand command
551 doCommand stmt
552 = do nms <- runStmt stmt
553 case nms of
554 Nothing -> io (exitWith (ExitFailure 1))
555 -- failure to run the command causes exit(1) for ghc -e.
556 _ -> finishEvalExpr nms
557
558 runStmt :: String -> GHCi (Maybe [Name])
559 runStmt stmt
560 | null (filter (not.isSpace) stmt) = return (Just [])
561 | otherwise
562 = do st <- getGHCiState
563 session <- getSession
564 result <- io $ withProgName (progname st) $ withArgs (args st) $
565 GHC.runStmt session stmt
566 case result of
567 GHC.RunFailed -> return Nothing
568 GHC.RunException e -> throw e -- this is caught by runCommand(Eval)
569 GHC.RunOk names -> return (Just names)
570
571 -- possibly print the type and revert CAFs after evaluating an expression
572 finishEvalExpr mb_names
573 = do b <- isOptionSet ShowType
574 session <- getSession
575 case mb_names of
576 Nothing -> return ()
577 Just names -> when b (mapM_ (showTypeOfName session) names)
578
579 flushInterpBuffers
580 io installSignalHandlers
581 b <- isOptionSet RevertCAFs
582 io (when b revertCAFs)
583 return True
584
585 showTypeOfName :: Session -> Name -> GHCi ()
586 showTypeOfName session n
587 = do maybe_tything <- io (GHC.lookupName session n)
588 case maybe_tything of
589 Nothing -> return ()
590 Just thing -> showTyThing thing
591
592 specialCommand :: String -> GHCi Bool
593 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
594 specialCommand str = do
595 let (cmd,rest) = break isSpace str
596 maybe_cmd <- io (lookupCommand cmd)
597 case maybe_cmd of
598 Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
599 ++ shortHelpText) >> return False)
600 Just (_,f,_,_) -> f (dropWhile isSpace rest)
601
602 lookupCommand :: String -> IO (Maybe Command)
603 lookupCommand str = do
604 cmds <- readIORef commands
605 -- look for exact match first, then the first prefix match
606 case [ c | c <- cmds, str == cmdName c ] of
607 c:_ -> return (Just c)
608 [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
609 [] -> return Nothing
610 c:_ -> return (Just c)
611
612 -----------------------------------------------------------------------------
613 -- Commands
614
615 help :: String -> GHCi ()
616 help _ = io (putStr helpText)
617
618 info :: String -> GHCi ()
619 info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
620 info s = do { let names = words s
621 ; session <- getSession
622 ; dflags <- getDynFlags
623 ; let exts = dopt Opt_GlasgowExts dflags
624 ; mapM_ (infoThing exts session) names }
625 where
626 infoThing exts session str = io $ do
627 names <- GHC.parseName session str
628 let filtered = filterOutChildren names
629 mb_stuffs <- mapM (GHC.getInfo session) filtered
630 unqual <- GHC.getPrintUnqual session
631 putStrLn (showSDocForUser unqual $
632 vcat (intersperse (text "") $
633 [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
634
635 -- Filter out names whose parent is also there Good
636 -- example is '[]', which is both a type and data
637 -- constructor in the same type
638 filterOutChildren :: [Name] -> [Name]
639 filterOutChildren names = filter (not . parent_is_there) names
640 where parent_is_there n
641 -- | Just p <- GHC.nameParent_maybe n = p `elem` names
642 -- ToDo!!
643 | otherwise = False
644
645 pprInfo exts (thing, fixity, insts)
646 = pprTyThingInContextLoc exts thing
647 $$ show_fixity fixity
648 $$ vcat (map GHC.pprInstance insts)
649 where
650 show_fixity fix
651 | fix == GHC.defaultFixity = empty
652 | otherwise = ppr fix <+> ppr (GHC.getName thing)
653
654 -----------------------------------------------------------------------------
655 -- Commands
656
657 runMain :: String -> GHCi ()
658 runMain args = do
659 let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
660 runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
661 return ()
662
663 addModule :: [FilePath] -> GHCi ()
664 addModule files = do
665 io (revertCAFs) -- always revert CAFs on load/add.
666 files <- mapM expandPath files
667 targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
668 session <- getSession
669 io (mapM_ (GHC.addTarget session) targets)
670 ok <- io (GHC.load session LoadAllTargets)
671 afterLoad ok session
672
673 changeDirectory :: String -> GHCi ()
674 changeDirectory dir = do
675 session <- getSession
676 graph <- io (GHC.getModuleGraph session)
677 when (not (null graph)) $
678 io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
679 io (GHC.setTargets session [])
680 io (GHC.load session LoadAllTargets)
681 setContextAfterLoad session []
682 io (GHC.workingDirectoryChanged session)
683 dir <- expandPath dir
684 io (setCurrentDirectory dir)
685
686 editFile :: String -> GHCi ()
687 editFile str
688 | null str = do
689 -- find the name of the "topmost" file loaded
690 session <- getSession
691 graph0 <- io (GHC.getModuleGraph session)
692 graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
693 let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
694 case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
695 Just file -> do_edit file
696 Nothing -> throwDyn (CmdLineError "unknown file name")
697 | otherwise = do_edit str
698 where
699 do_edit file = do
700 st <- getGHCiState
701 let cmd = editor st
702 when (null cmd) $
703 throwDyn (CmdLineError "editor not set, use :set editor")
704 io $ system (cmd ++ ' ':file)
705 return ()
706
707 defineMacro :: String -> GHCi ()
708 defineMacro s = do
709 let (macro_name, definition) = break isSpace s
710 cmds <- io (readIORef commands)
711 if (null macro_name)
712 then throwDyn (CmdLineError "invalid macro name")
713 else do
714 if (macro_name `elem` map cmdName cmds)
715 then throwDyn (CmdLineError
716 ("command '" ++ macro_name ++ "' is already defined"))
717 else do
718
719 -- give the expression a type signature, so we can be sure we're getting
720 -- something of the right type.
721 let new_expr = '(' : definition ++ ") :: String -> IO String"
722
723 -- compile the expression
724 cms <- getSession
725 maybe_hv <- io (GHC.compileExpr cms new_expr)
726 case maybe_hv of
727 Nothing -> return ()
728 Just hv -> io (writeIORef commands --
729 (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
730
731 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
732 runMacro fun s = do
733 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
734 stringLoop (lines str)
735
736 undefineMacro :: String -> GHCi ()
737 undefineMacro macro_name = do
738 cmds <- io (readIORef commands)
739 if (macro_name `elem` map cmdName builtin_commands)
740 then throwDyn (CmdLineError
741 ("command '" ++ macro_name ++ "' cannot be undefined"))
742 else do
743 if (macro_name `notElem` map cmdName cmds)
744 then throwDyn (CmdLineError
745 ("command '" ++ macro_name ++ "' not defined"))
746 else do
747 io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
748
749
750 loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
751 loadModule fs = timeIt (loadModule' fs)
752
753 loadModule_ :: [FilePath] -> GHCi ()
754 loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
755
756 loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
757 loadModule' files = do
758 session <- getSession
759
760 -- unload first
761 io (GHC.setTargets session [])
762 io (GHC.load session LoadAllTargets)
763
764 -- expand tildes
765 let (filenames, phases) = unzip files
766 exp_filenames <- mapM expandPath filenames
767 let files' = zip exp_filenames phases
768 targets <- io (mapM (uncurry GHC.guessTarget) files')
769
770 -- NOTE: we used to do the dependency anal first, so that if it
771 -- fails we didn't throw away the current set of modules. This would
772 -- require some re-working of the GHC interface, so we'll leave it
773 -- as a ToDo for now.
774
775 io (GHC.setTargets session targets)
776 ok <- io (GHC.load session LoadAllTargets)
777 afterLoad ok session
778 return ok
779
780 checkModule :: String -> GHCi ()
781 checkModule m = do
782 let modl = GHC.mkModuleName m
783 session <- getSession
784 result <- io (GHC.checkModule session modl)
785 case result of
786 Nothing -> io $ putStrLn "Nothing"
787 Just r -> io $ putStrLn (showSDoc (
788 case GHC.checkedModuleInfo r of
789 Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
790 let
791 (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
792 in
793 (text "global names: " <+> ppr global) $$
794 (text "local names: " <+> ppr local)
795 _ -> empty))
796 afterLoad (successIf (isJust result)) session
797
798 reloadModule :: String -> GHCi ()
799 reloadModule "" = do
800 io (revertCAFs) -- always revert CAFs on reload.
801 session <- getSession
802 ok <- io (GHC.load session LoadAllTargets)
803 afterLoad ok session
804 reloadModule m = do
805 io (revertCAFs) -- always revert CAFs on reload.
806 session <- getSession
807 ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
808 afterLoad ok session
809
810 afterLoad ok session = do
811 io (revertCAFs) -- always revert CAFs on load.
812 graph <- io (GHC.getModuleGraph session)
813 graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
814 setContextAfterLoad session graph'
815 modulesLoadedMsg ok (map GHC.ms_mod_name graph')
816 #if defined(GHCI) && defined(BREAKPOINT)
817 io (extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))
818 ,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))])
819 #endif
820
821 setContextAfterLoad session [] = do
822 prel_mod <- getPrelude
823 io (GHC.setContext session [] [prel_mod])
824 setContextAfterLoad session ms = do
825 -- load a target if one is available, otherwise load the topmost module.
826 targets <- io (GHC.getTargets session)
827 case [ m | Just m <- map (findTarget ms) targets ] of
828 [] ->
829 let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
830 load_this (last graph')
831 (m:_) ->
832 load_this m
833 where
834 findTarget ms t
835 = case filter (`matches` t) ms of
836 [] -> Nothing
837 (m:_) -> Just m
838
839 summary `matches` Target (TargetModule m) _
840 = GHC.ms_mod_name summary == m
841 summary `matches` Target (TargetFile f _) _
842 | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
843 summary `matches` target
844 = False
845
846 load_this summary | m <- GHC.ms_mod summary = do
847 b <- io (GHC.moduleIsInterpreted session m)
848 if b then io (GHC.setContext session [m] [])
849 else do
850 prel_mod <- getPrelude
851 io (GHC.setContext session [] [prel_mod,m])
852
853
854 modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
855 modulesLoadedMsg ok mods = do
856 dflags <- getDynFlags
857 when (verbosity dflags > 0) $ do
858 let mod_commas
859 | null mods = text "none."
860 | otherwise = hsep (
861 punctuate comma (map ppr mods)) <> text "."
862 case ok of
863 Failed ->
864 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
865 Succeeded ->
866 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
867
868
869 typeOfExpr :: String -> GHCi ()
870 typeOfExpr str
871 = do cms <- getSession
872 maybe_ty <- io (GHC.exprType cms str)
873 case maybe_ty of
874 Nothing -> return ()
875 Just ty -> do ty' <- cleanType ty
876 tystr <- showForUser (ppr ty')
877 io (putStrLn (str ++ " :: " ++ tystr))
878
879 kindOfType :: String -> GHCi ()
880 kindOfType str
881 = do cms <- getSession
882 maybe_ty <- io (GHC.typeKind cms str)
883 case maybe_ty of
884 Nothing -> return ()
885 Just ty -> do tystr <- showForUser (ppr ty)
886 io (putStrLn (str ++ " :: " ++ tystr))
887
888 quit :: String -> GHCi Bool
889 quit _ = return True
890
891 shellEscape :: String -> GHCi Bool
892 shellEscape str = io (system str >> return False)
893
894 -----------------------------------------------------------------------------
895 -- create tags file for currently loaded modules.
896
897 createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
898
899 createCTagsFileCmd "" = ghciCreateTagsFile CTags "tags"
900 createCTagsFileCmd file = ghciCreateTagsFile CTags file
901
902 createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"
903 createETagsFileCmd file = ghciCreateTagsFile ETags file
904
905 data TagsKind = ETags | CTags
906
907 ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
908 ghciCreateTagsFile kind file = do
909 session <- getSession
910 io $ createTagsFile session kind file
911
912 -- ToDo:
913 -- - remove restriction that all modules must be interpreted
914 -- (problem: we don't know source locations for entities unless
915 -- we compiled the module.
916 --
917 -- - extract createTagsFile so it can be used from the command-line
918 -- (probably need to fix first problem before this is useful).
919 --
920 createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
921 createTagsFile session tagskind tagFile = do
922 graph <- GHC.getModuleGraph session
923 let ms = map GHC.ms_mod graph
924 tagModule m = do
925 is_interpreted <- GHC.moduleIsInterpreted session m
926 -- should we just skip these?
927 when (not is_interpreted) $
928 throwDyn (CmdLineError ("module '"
929 ++ GHC.moduleNameString (GHC.moduleName m)
930 ++ "' is not interpreted"))
931 mbModInfo <- GHC.getModuleInfo session m
932 let unqual
933 | Just modinfo <- mbModInfo,
934 Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
935 | otherwise = GHC.alwaysQualify
936
937 case mbModInfo of
938 Just modInfo -> return $! listTags unqual modInfo
939 _ -> return []
940
941 mtags <- mapM tagModule ms
942 either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
943 case either_res of
944 Left e -> hPutStrLn stderr $ ioeGetErrorString e
945 Right _ -> return ()
946
947 listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
948 listTags unqual modInfo =
949 [ tagInfo unqual name loc
950 | name <- GHC.modInfoExports modInfo
951 , let loc = nameSrcLoc name
952 , isGoodSrcLoc loc
953 ]
954
955 type TagInfo = (String -- tag name
956 ,String -- file name
957 ,Int -- line number
958 ,Int -- column number
959 )
960
961 -- get tag info, for later translation into Vim or Emacs style
962 tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
963 tagInfo unqual name loc
964 = ( showSDocForUser unqual $ pprOccName (nameOccName name)
965 , showSDocForUser unqual $ ftext (srcLocFile loc)
966 , srcLocLine loc
967 , srcLocCol loc
968 )
969
970 collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
971 collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
972 let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
973 IO.try (writeFile file tags)
974 collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
975 let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
976 groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
977 tagGroups <- mapM tagFileGroup groups
978 IO.try (writeFile file $ concat tagGroups)
979 where
980 tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
981 tagFileGroup group@((_,fileName,_,_):_) = do
982 file <- readFile fileName -- need to get additional info from sources..
983 let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
984 sortedGroup = sortLe byLine group
985 tags = unlines $ perFile sortedGroup 1 0 $ lines file
986 return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
987 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
988 perFile (tagInfo:tags) (count+1) (pos+length line) lines
989 perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
990 showETag tagInfo line pos : perFile tags count pos lines
991 perFile tags count pos lines = []
992
993 -- simple ctags format, for Vim et al
994 showTag :: TagInfo -> String
995 showTag (tag,file,lineNo,colNo)
996 = tag ++ "\t" ++ file ++ "\t" ++ show lineNo
997
998 -- etags format, for Emacs/XEmacs
999 showETag :: TagInfo -> String -> Int -> String
1000 showETag (tag,file,lineNo,colNo) line charPos
1001 = take colNo line ++ tag
1002 ++ "\x7f" ++ tag
1003 ++ "\x01" ++ show lineNo
1004 ++ "," ++ show charPos
1005
1006 -----------------------------------------------------------------------------
1007 -- Browsing a module's contents
1008
1009 browseCmd :: String -> GHCi ()
1010 browseCmd m =
1011 case words m of
1012 ['*':m] | looksLikeModuleName m -> browseModule m False
1013 [m] | looksLikeModuleName m -> browseModule m True
1014 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
1015
1016 browseModule m exports_only = do
1017 s <- getSession
1018 modl <- io $ GHC.findModule s (GHC.mkModuleName m) Nothing
1019 is_interpreted <- io (GHC.moduleIsInterpreted s modl)
1020 when (not is_interpreted && not exports_only) $
1021 throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
1022
1023 -- Temporarily set the context to the module we're interested in,
1024 -- just so we can get an appropriate PrintUnqualified
1025 (as,bs) <- io (GHC.getContext s)
1026 prel_mod <- getPrelude
1027 io (if exports_only then GHC.setContext s [] [prel_mod,modl]
1028 else GHC.setContext s [modl] [])
1029 unqual <- io (GHC.getPrintUnqual s)
1030 io (GHC.setContext s as bs)
1031
1032 mb_mod_info <- io $ GHC.getModuleInfo s modl
1033 case mb_mod_info of
1034 Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
1035 Just mod_info -> do
1036 let names
1037 | exports_only = GHC.modInfoExports mod_info
1038 | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
1039
1040 filtered = filterOutChildren names
1041
1042 things <- io $ mapM (GHC.lookupName s) filtered
1043
1044 dflags <- getDynFlags
1045 let exts = dopt Opt_GlasgowExts dflags
1046 io (putStrLn (showSDocForUser unqual (
1047 vcat (map (pprTyThingInContext exts) (catMaybes things))
1048 )))
1049 -- ToDo: modInfoInstances currently throws an exception for
1050 -- package modules. When it works, we can do this:
1051 -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
1052
1053 -----------------------------------------------------------------------------
1054 -- Setting the module context
1055
1056 setContext str
1057 | all sensible mods = fn mods
1058 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
1059 where
1060 (fn, mods) = case str of
1061 '+':stuff -> (addToContext, words stuff)
1062 '-':stuff -> (removeFromContext, words stuff)
1063 stuff -> (newContext, words stuff)
1064
1065 sensible ('*':m) = looksLikeModuleName m
1066 sensible m = looksLikeModuleName m
1067
1068 separate :: Session -> [String] -> [Module] -> [Module]
1069 -> GHCi ([Module],[Module])
1070 separate session [] as bs = return (as,bs)
1071 separate session (('*':str):ms) as bs = do
1072 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1073 b <- io $ GHC.moduleIsInterpreted session m
1074 if b then separate session ms (m:as) bs
1075 else throwDyn (CmdLineError ("module '"
1076 ++ GHC.moduleNameString (GHC.moduleName m)
1077 ++ "' is not interpreted"))
1078 separate session (str:ms) as bs = do
1079 m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
1080 separate session ms as (m:bs)
1081
1082 newContext :: [String] -> GHCi ()
1083 newContext strs = do
1084 s <- getSession
1085 (as,bs) <- separate s strs [] []
1086 prel_mod <- getPrelude
1087 let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
1088 io $ GHC.setContext s as bs'
1089
1090
1091 addToContext :: [String] -> GHCi ()
1092 addToContext strs = do
1093 s <- getSession
1094 (as,bs) <- io $ GHC.getContext s
1095
1096 (new_as,new_bs) <- separate s strs [] []
1097
1098 let as_to_add = new_as \\ (as ++ bs)
1099 bs_to_add = new_bs \\ (as ++ bs)
1100
1101 io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
1102
1103
1104 removeFromContext :: [String] -> GHCi ()
1105 removeFromContext strs = do
1106 s <- getSession
1107 (as,bs) <- io $ GHC.getContext s
1108
1109 (as_to_remove,bs_to_remove) <- separate s strs [] []
1110
1111 let as' = as \\ (as_to_remove ++ bs_to_remove)
1112 bs' = bs \\ (as_to_remove ++ bs_to_remove)
1113
1114 io $ GHC.setContext s as' bs'
1115
1116 ----------------------------------------------------------------------------
1117 -- Code for `:set'
1118
1119 -- set options in the interpreter. Syntax is exactly the same as the
1120 -- ghc command line, except that certain options aren't available (-C,
1121 -- -E etc.)
1122 --
1123 -- This is pretty fragile: most options won't work as expected. ToDo:
1124 -- figure out which ones & disallow them.
1125
1126 setCmd :: String -> GHCi ()
1127 setCmd ""
1128 = do st <- getGHCiState
1129 let opts = options st
1130 io $ putStrLn (showSDoc (
1131 text "options currently set: " <>
1132 if null opts
1133 then text "none."
1134 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
1135 ))
1136 setCmd str
1137 = case toArgs str of
1138 ("args":args) -> setArgs args
1139 ("prog":prog) -> setProg prog
1140 ("prompt":prompt) -> setPrompt (after 6)
1141 ("editor":cmd) -> setEditor (after 6)
1142 wds -> setOptions wds
1143 where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
1144
1145 setArgs args = do
1146 st <- getGHCiState
1147 setGHCiState st{ args = args }
1148
1149 setProg [prog] = do
1150 st <- getGHCiState
1151 setGHCiState st{ progname = prog }
1152 setProg _ = do
1153 io (hPutStrLn stderr "syntax: :set prog <progname>")
1154
1155 setEditor cmd = do
1156 st <- getGHCiState
1157 setGHCiState st{ editor = cmd }
1158
1159 setPrompt value = do
1160 st <- getGHCiState
1161 if null value
1162 then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
1163 else setGHCiState st{ prompt = remQuotes value }
1164 where
1165 remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
1166 remQuotes x = x
1167
1168 setOptions wds =
1169 do -- first, deal with the GHCi opts (+s, +t, etc.)
1170 let (plus_opts, minus_opts) = partition isPlus wds
1171 mapM_ setOpt plus_opts
1172
1173 -- then, dynamic flags
1174 dflags <- getDynFlags
1175 let pkg_flags = packageFlags dflags
1176 (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
1177
1178 if (not (null leftovers))
1179 then throwDyn (CmdLineError ("unrecognised flags: " ++
1180 unwords leftovers))
1181 else return ()
1182
1183 new_pkgs <- setDynFlags dflags'
1184
1185 -- if the package flags changed, we should reset the context
1186 -- and link the new packages.
1187 dflags <- getDynFlags
1188 when (packageFlags dflags /= pkg_flags) $ do
1189 io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
1190 session <- getSession
1191 io (GHC.setTargets session [])
1192 io (GHC.load session LoadAllTargets)
1193 io (linkPackages dflags new_pkgs)
1194 setContextAfterLoad session []
1195 return ()
1196
1197
1198 unsetOptions :: String -> GHCi ()
1199 unsetOptions str
1200 = do -- first, deal with the GHCi opts (+s, +t, etc.)
1201 let opts = words str
1202 (minus_opts, rest1) = partition isMinus opts
1203 (plus_opts, rest2) = partition isPlus rest1
1204
1205 if (not (null rest2))
1206 then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
1207 else do
1208
1209 mapM_ unsetOpt plus_opts
1210
1211 -- can't do GHC flags for now
1212 if (not (null minus_opts))
1213 then throwDyn (CmdLineError "can't unset GHC command-line flags")
1214 else return ()
1215
1216 isMinus ('-':s) = True
1217 isMinus _ = False
1218
1219 isPlus ('+':s) = True
1220 isPlus _ = False
1221
1222 setOpt ('+':str)
1223 = case strToGHCiOpt str of
1224 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1225 Just o -> setOption o
1226
1227 unsetOpt ('+':str)
1228 = case strToGHCiOpt str of
1229 Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
1230 Just o -> unsetOption o
1231
1232 strToGHCiOpt :: String -> (Maybe GHCiOption)
1233 strToGHCiOpt "s" = Just ShowTiming
1234 strToGHCiOpt "t" = Just ShowType
1235 strToGHCiOpt "r" = Just RevertCAFs
1236 strToGHCiOpt _ = Nothing
1237
1238 optToStr :: GHCiOption -> String
1239 optToStr ShowTiming = "s"
1240 optToStr ShowType = "t"
1241 optToStr RevertCAFs = "r"
1242
1243 -- ---------------------------------------------------------------------------
1244 -- code for `:show'
1245
1246 showCmd str =
1247 case words str of
1248 ["modules" ] -> showModules
1249 ["bindings"] -> showBindings
1250 ["linker"] -> io showLinkerState
1251 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
1252
1253 showModules = do
1254 session <- getSession
1255 let show_one ms = do m <- io (GHC.showModule session ms)
1256 io (putStrLn m)
1257 graph <- io (GHC.getModuleGraph session)
1258 mapM_ show_one graph
1259
1260 showBindings = do
1261 s <- getSession
1262 unqual <- io (GHC.getPrintUnqual s)
1263 bindings <- io (GHC.getBindings s)
1264 mapM_ showTyThing bindings
1265 return ()
1266
1267 showTyThing (AnId id) = do
1268 ty' <- cleanType (GHC.idType id)
1269 str <- showForUser (ppr id <> text " :: " <> ppr ty')
1270 io (putStrLn str)
1271 showTyThing _ = return ()
1272
1273 -- if -fglasgow-exts is on we show the foralls, otherwise we don't.
1274 cleanType :: Type -> GHCi Type
1275 cleanType ty = do
1276 dflags <- getDynFlags
1277 if dopt Opt_GlasgowExts dflags
1278 then return ty
1279 else return $! GHC.dropForAlls ty
1280
1281 -- -----------------------------------------------------------------------------
1282 -- Completion
1283
1284 completeNone :: String -> IO [String]
1285 completeNone w = return []
1286
1287 #ifdef USE_READLINE
1288 completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
1289 completeWord w start end = do
1290 line <- Readline.getLineBuffer
1291 case w of
1292 ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
1293 _other
1294 | Just c <- is_cmd line -> do
1295 maybe_cmd <- lookupCommand c
1296 let (n,w') = selectWord (words' 0 line)
1297 case maybe_cmd of
1298 Nothing -> return Nothing
1299 Just (_,_,False,complete) -> wrapCompleter complete w
1300 Just (_,_,True,complete) -> let complete' w = do rets <- complete w
1301 return (map (drop n) rets)
1302 in wrapCompleter complete' w'
1303 | otherwise -> do
1304 --printf "complete %s, start = %d, end = %d\n" w start end
1305 wrapCompleter completeIdentifier w
1306 where words' _ [] = []
1307 words' n str = let (w,r) = break isSpace str
1308 (s,r') = span isSpace r
1309 in (n,w):words' (n+length w+length s) r'
1310 -- In a Haskell expression we want to parse 'a-b' as three words
1311 -- where a compiler flag (ie. -fno-monomorphism-restriction) should
1312 -- only be a single word.
1313 selectWord [] = (0,w)
1314 selectWord ((offset,x):xs)
1315 | offset+length x >= start = (start-offset,take (end-offset) x)
1316 | otherwise = selectWord xs
1317
1318 is_cmd line
1319 | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
1320 | otherwise = Nothing
1321
1322 completeCmd w = do
1323 cmds <- readIORef commands
1324 return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
1325
1326 completeMacro w = do
1327 cmds <- readIORef commands
1328 let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
1329 return (filter (w `isPrefixOf`) cmds')
1330
1331 completeIdentifier w = do
1332 s <- restoreSession
1333 rdrs <- GHC.getRdrNamesInScope s
1334 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
1335
1336 completeModule w = do
1337 s <- restoreSession
1338 dflags <- GHC.getSessionDynFlags s
1339 let pkg_mods = allExposedModules dflags
1340 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
1341
1342 completeHomeModule w = do
1343 s <- restoreSession
1344 g <- GHC.getModuleGraph s
1345 let home_mods = map GHC.ms_mod_name g
1346 return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
1347
1348 completeSetOptions w = do
1349 return (filter (w `isPrefixOf`) options)
1350 where options = "args":"prog":allFlags
1351
1352 completeFilename = Readline.filenameCompletionFunction
1353
1354 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
1355
1356 unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
1357 unionComplete f1 f2 w = do
1358 s1 <- f1 w
1359 s2 <- f2 w
1360 return (s1 ++ s2)
1361
1362 wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
1363 wrapCompleter fun w = do
1364 strs <- fun w
1365 case strs of
1366 [] -> return Nothing
1367 [x] -> return (Just (x,[]))
1368 xs -> case getCommonPrefix xs of
1369 "" -> return (Just ("",xs))
1370 pref -> return (Just (pref,xs))
1371
1372 getCommonPrefix :: [String] -> String
1373 getCommonPrefix [] = ""
1374 getCommonPrefix (s:ss) = foldl common s ss
1375 where common s "" = s
1376 common "" s = ""
1377 common (c:cs) (d:ds)
1378 | c == d = c : common cs ds
1379 | otherwise = ""
1380
1381 allExposedModules :: DynFlags -> [ModuleName]
1382 allExposedModules dflags
1383 = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
1384 where
1385 pkg_db = pkgIdMap (pkgState dflags)
1386 #else
1387 completeCmd = completeNone
1388 completeMacro = completeNone
1389 completeIdentifier = completeNone
1390 completeModule = completeNone
1391 completeHomeModule = completeNone
1392 completeSetOptions = completeNone
1393 completeFilename = completeNone
1394 completeHomeModuleOrFile=completeNone
1395 #endif
1396
1397 -- ----------------------------------------------------------------------------
1398 -- Utils
1399
1400 expandPath :: String -> GHCi String
1401 expandPath path =
1402 case dropWhile isSpace path of
1403 ('~':d) -> do
1404 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
1405 return (tilde ++ '/':d)
1406 other ->
1407 return other
1408
1409 -- ----------------------------------------------------------------------------
1410 -- Windows console setup
1411
1412 setUpConsole :: IO ()
1413 setUpConsole = do
1414 #ifdef mingw32_HOST_OS
1415 -- On Windows we need to set a known code page, otherwise the characters
1416 -- we read from the console will be be in some strange encoding, and
1417 -- similarly for characters we write to the console.
1418 --
1419 -- At the moment, GHCi pretends all input is Latin-1. In the
1420 -- future we should support UTF-8, but for now we set the code pages
1421 -- to Latin-1.
1422 --
1423 -- It seems you have to set the font in the console window to
1424 -- a Unicode font in order for output to work properly,
1425 -- otherwise non-ASCII characters are mapped wrongly. sigh.
1426 -- (see MSDN for SetConsoleOutputCP()).
1427 --
1428 setConsoleCP 28591 -- ISO Latin-1
1429 setConsoleOutputCP 28591 -- ISO Latin-1
1430 #endif
1431 return ()