1 {-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.112 2002/01/28 13:34:10 simonmar Exp $
5 -- GHC Interactive User Interface
7 -- (c) The GHC Team 2000
9 -----------------------------------------------------------------------------
10 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
12 #include "../includes/config.h"
13 #include "HsVersions.h"
18 import CmTypes ( Linkable, isObjectLinkable, ModSummary(..) )
19 import CmLink ( findModuleLinkable_maybe )
21 import HscTypes ( TyThing(..), showModMsg, InteractiveContext(..) )
22 import HsSyn ( TyClDecl(..), ConDecl(..), Sig(..) )
23 import MkIface ( ifaceTyThing )
26 import DriverUtil ( handle, remove_spaces )
28 import Finder ( flushPackageCache )
30 import Id ( isRecordSelector, recordSelectorFieldLabel,
31 isDataConWrapId, isDataConId, idName )
32 import Class ( className )
33 import TyCon ( tyConName, tyConClass_maybe, isPrimTyCon )
34 import FieldLabel ( fieldLabelTyCon )
35 import SrcLoc ( isGoodSrcLoc )
36 import Module ( moduleName )
37 import NameEnv ( nameEnvElts )
38 import Name ( Name, isHomePackageName, nameSrcLoc, nameOccName,
40 import OccName ( isSymOcc )
41 import BasicTypes ( defaultFixity )
43 import CmdLineOpts ( DynFlag(..), DynFlags(..), getDynFlags, saveDynFlags,
44 restoreDynFlags, dopt_unset )
45 import Panic ( GhcException(..), showGhcException )
48 #ifndef mingw32_TARGET_OS
54 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
70 import PrelGHC ( unsafeCoerce# )
71 import Foreign ( nullPtr )
72 import CString ( peekCString )
74 -----------------------------------------------------------------------------
78 \ / _ \\ /\\ /\\/ __(_)\n\
79 \ / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n\
80 \/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n\
81 \\\____/\\/ /_/\\____/|_| Type :? for help.\n"
83 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
85 builtin_commands :: [(String, String -> GHCi Bool)]
87 ("add", keepGoing addModule),
88 ("browse", keepGoing browseCmd),
89 ("cd", keepGoing changeDirectory),
90 ("def", keepGoing defineMacro),
91 ("help", keepGoing help),
92 ("?", keepGoing help),
93 ("info", keepGoing info),
94 ("load", keepGoing loadModule),
95 ("module", keepGoing setContext),
96 ("reload", keepGoing reloadModule),
97 ("set", keepGoing setCmd),
98 ("show", keepGoing showCmd),
99 ("type", keepGoing typeOfExpr),
100 ("unset", keepGoing unsetOptions),
101 ("undef", keepGoing undefineMacro),
105 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
106 keepGoing a str = a str >> return False
108 shortHelpText = "use :? for help.\n"
111 \ Commands available from the prompt:\n\
113 \ <stmt> evaluate/run <stmt>\n\
114 \ :add <filename> ... add module(s) to the current target set\n\
115 \ :browse [*]<module> display the names defined by <module>\n\
116 \ :cd <dir> change directory to <dir>\n\
117 \ :def <cmd> <expr> define a command :<cmd>\n\
118 \ :help, :? display this list of commands\n\
119 \ :info [<name> ...] display information about the given names\n\
120 \ :load <filename> ... load module(s) and their dependents\n\
121 \ :module <mod> set the context for expression evaluation to <mod>\n\
122 \ :reload reload the current module set\n\
124 \ :set <option> ... set options\n\
125 \ :set args <arg> ... set the arguments returned by System.getArgs\n\
126 \ :set prog <progname> set the value returned by System.getProgName\n\
128 \ :show modules show the currently loaded modules\n\
129 \ :show bindings show the current bindings made at the prompt\n\
131 \ :type <expr> show the type of <expr>\n\
132 \ :undef <cmd> undefine user-defined command :<cmd>\n\
133 \ :unset <option> ... unset options\n\
135 \ :!<command> run the shell command <command>\n\
137 \ Options for `:set' and `:unset':\n\
139 \ +r revert top-level expressions after each evaluation\n\
140 \ +s print timing/memory stats after each evaluation\n\
141 \ +t print type after evaluation\n\
142 \ -<flags> most GHC command line flags can also be set here\n\
143 \ (eg. -v2, -fglasgow-exts, etc.)\n\
146 interactiveUI :: CmState -> [FilePath] -> [LibrarySpec] -> IO ()
147 interactiveUI cmstate paths cmdline_libs = do
149 hSetBuffering stdout NoBuffering
151 dflags <- getDynFlags
153 -- link in the available packages
154 pkgs <- getPackageInfo
156 linkPackages dflags cmdline_libs pkgs
158 (cmstate, maybe_hval)
159 <- cmCompileExpr cmstate dflags "IO.hSetBuffering IO.stdout IO.NoBuffering Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
161 Just hval -> unsafeCoerce# hval :: IO ()
162 _ -> panic "interactiveUI:buffering"
164 (cmstate, maybe_hval)
165 <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stderr"
167 Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ())
168 _ -> panic "interactiveUI:stderr"
170 (cmstate, maybe_hval)
171 <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stdout"
173 Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ())
174 _ -> panic "interactiveUI:stdout"
176 -- We don't want the cmd line to buffer any input that might be
177 -- intended for the program, so unbuffer stdin.
178 hSetBuffering stdin NoBuffering
180 -- initial context is just the Prelude
181 cmstate <- cmSetContext cmstate dflags [] ["Prelude"]
183 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
187 startGHCi (runGHCi paths dflags)
188 GHCiState{ progname = "<interactive>",
194 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
195 Readline.resetTerminal Nothing
201 runGHCi :: [FilePath] -> DynFlags -> GHCi ()
202 runGHCi paths dflags = do
203 read_dot_files <- io (readIORef v_Read_DotGHCi)
205 when (read_dot_files) $ do
208 exists <- io (doesFileExist file)
210 dir_ok <- io (checkPerms ".")
211 file_ok <- io (checkPerms file)
212 when (dir_ok && file_ok) $ do
213 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
216 Right hdl -> fileLoop hdl False
218 when (read_dot_files) $ do
219 -- Read in $HOME/.ghci
220 either_dir <- io (IO.try (getEnv "HOME"))
224 cwd <- io (getCurrentDirectory)
225 when (dir /= cwd) $ do
226 let file = dir ++ "/.ghci"
227 ok <- io (checkPerms file)
229 either_hdl <- io (IO.try (openFile file ReadMode))
232 Right hdl -> fileLoop hdl False
234 -- perform a :load for files given on the GHCi command line
235 when (not (null paths)) $
236 ghciHandle showException $
237 loadModule (unwords paths)
239 -- enter the interactive loop
240 is_tty <- io (hIsTerminalDevice stdin)
241 interactiveLoop is_tty
244 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
247 interactiveLoop is_tty = do
248 -- ignore ^C exceptions caught here
249 ghciHandleDyn (\e -> case e of
250 Interrupted -> ghciUnblock (interactiveLoop is_tty)
251 _other -> return ()) $ do
253 -- read commands from stdin
254 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
257 else fileLoop stdin False -- turn off prompt for non-TTY input
263 -- NOTE: We only read .ghci files if they are owned by the current user,
264 -- and aren't world writable. Otherwise, we could be accidentally
265 -- running code planted by a malicious third party.
267 -- Furthermore, We only read ./.ghci if . is owned by the current user
268 -- and isn't writable by anyone else. I think this is sufficient: we
269 -- don't need to check .. and ../.. etc. because "." always refers to
270 -- the same directory while a process is running.
272 checkPerms :: String -> IO Bool
274 handle (\_ -> return False) $ do
275 #ifdef mingw32_TARGET_OS
278 st <- getFileStatus name
280 if fileOwner st /= me then do
281 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
284 let mode = fileMode st
285 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
286 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
288 putStrLn $ "*** WARNING: " ++ name ++
289 " is writable by someone else, IGNORING!"
294 fileLoop :: Handle -> Bool -> GHCi ()
295 fileLoop hdl prompt = do
296 cmstate <- getCmState
297 (mod,imports) <- io (cmGetContext cmstate)
298 when prompt (io (putStr (mkPrompt mod imports)))
299 l <- io (IO.try (hGetLine hdl))
301 Left e | isEOFError e -> return ()
302 | otherwise -> throw e
304 case remove_spaces l of
305 "" -> fileLoop hdl prompt
306 l -> do quit <- runCommand l
307 if quit then return () else fileLoop hdl prompt
309 stringLoop :: [String] -> GHCi ()
310 stringLoop [] = return ()
311 stringLoop (s:ss) = do
312 case remove_spaces s of
314 l -> do quit <- runCommand l
315 if quit then return () else stringLoop ss
317 mkPrompt toplevs exports
318 = concat (intersperse " " (toplevs ++ map ('*':) exports)) ++ "> "
320 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
321 readlineLoop :: GHCi ()
323 cmstate <- getCmState
324 (mod,imports) <- io (cmGetContext cmstate)
326 l <- io (readline (mkPrompt mod imports))
330 case remove_spaces l of
335 if quit then return () else readlineLoop
338 -- Top level exception handler, just prints out the exception
340 runCommand :: String -> GHCi Bool
342 ghciHandle ( \exception -> do
344 showException exception
349 showException (DynException dyn) =
350 case fromDynamic dyn of
351 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
352 Just Interrupted -> io (putStrLn "Interrupted.")
353 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
354 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
355 Just other_ghc_ex -> io (print other_ghc_ex)
357 showException other_exception
358 = io (putStrLn ("*** Exception: " ++ show other_exception))
360 doCommand (':' : command) = specialCommand command
362 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
365 runStmt :: String -> GHCi [Name]
367 | null (filter (not.isSpace) stmt) = return []
369 = do st <- getGHCiState
370 dflags <- io getDynFlags
371 let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
372 (new_cmstate, result) <-
373 io $ withProgName (progname st) $ withArgs (args st) $
374 cmRunStmt (cmstate st) dflags' stmt
375 setGHCiState st{cmstate = new_cmstate}
377 CmRunFailed -> return []
378 CmRunException e -> showException e >> return []
379 CmRunOk names -> return names
381 -- possibly print the type and revert CAFs after evaluating an expression
383 = do b <- isOptionSet ShowType
384 cmstate <- getCmState
385 when b (mapM_ (showTypeOfName cmstate) names)
387 b <- isOptionSet RevertCAFs
388 io (when b revertCAFs)
392 showTypeOfName :: CmState -> Name -> GHCi ()
393 showTypeOfName cmstate n
394 = do maybe_str <- io (cmTypeOfName cmstate n)
397 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
399 flushEverything :: GHCi ()
401 = io $ do Monad.join (readIORef flush_stdout)
402 Monad.join (readIORef flush_stderr)
405 specialCommand :: String -> GHCi Bool
406 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
407 specialCommand str = do
408 let (cmd,rest) = break isSpace str
409 cmds <- io (readIORef commands)
410 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
411 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
412 ++ shortHelpText) >> return False)
413 [(_,f)] -> f (dropWhile isSpace rest)
414 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
415 " matches multiple commands (" ++
416 foldr1 (\a b -> a ++ ',':b) (map fst cs)
417 ++ ")") >> return False)
419 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
421 -----------------------------------------------------------------------------
424 help :: String -> GHCi ()
425 help _ = io (putStr helpText)
427 info :: String -> GHCi ()
428 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
431 init_cms <- getCmState
432 dflags <- io getDynFlags
434 infoThings cms [] = return cms
435 infoThings cms (name:names) = do
436 (cms, stuff) <- io (cmInfoThing cms dflags name)
437 io (putStrLn (showSDocForUser unqual (
438 vcat (intersperse (text "") (map showThing stuff))))
442 unqual = cmGetPrintUnqual init_cms
444 showThing (ty_thing, fixity)
445 = vcat [ text "-- " <> showTyThing ty_thing,
446 showFixity fixity (getName ty_thing),
447 ppr (ifaceTyThing ty_thing) ]
450 | fix == defaultFixity = empty
451 | otherwise = ppr fix <+>
452 (if isSymOcc (nameOccName name)
454 else char '`' <> ppr name <> char '`')
456 showTyThing (AClass cl)
457 = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
458 showTyThing (ATyCon ty)
460 = hcat [ppr ty, text " is a primitive type constructor"]
462 = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
463 showTyThing (AnId id)
464 = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
467 | isRecordSelector id =
468 case tyConClass_maybe (fieldLabelTyCon (
469 recordSelectorFieldLabel id)) of
470 Nothing -> text "record selector"
471 Just c -> text "method in class " <> ppr c
472 | isDataConWrapId id = text "data constructor"
473 | otherwise = text "variable"
475 -- also print out the source location for home things
477 | isHomePackageName name && isGoodSrcLoc loc
478 = hsep [ text ", defined at", ppr loc ]
481 where loc = nameSrcLoc name
483 cms <- infoThings init_cms names
487 addModule :: String -> GHCi ()
489 let files = words str
490 state <- getGHCiState
491 dflags <- io (getDynFlags)
492 io (revertCAFs) -- always revert CAFs on load/add.
493 let new_targets = files ++ targets state
494 graph <- io (cmDepAnal (cmstate state) dflags new_targets)
495 (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph)
496 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
497 setContextAfterLoad mods
498 modulesLoadedMsg ok mods dflags
500 changeDirectory :: String -> GHCi ()
501 changeDirectory ('~':d) = do
502 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
503 io (setCurrentDirectory (tilde ++ '/':d))
504 changeDirectory d = io (setCurrentDirectory d)
506 defineMacro :: String -> GHCi ()
508 let (macro_name, definition) = break isSpace s
509 cmds <- io (readIORef commands)
511 then throwDyn (CmdLineError "invalid macro name")
513 if (macro_name `elem` map fst cmds)
514 then throwDyn (CmdLineError
515 ("command `" ++ macro_name ++ "' is already defined"))
518 -- give the expression a type signature, so we can be sure we're getting
519 -- something of the right type.
520 let new_expr = '(' : definition ++ ") :: String -> IO String"
522 -- compile the expression
524 dflags <- io getDynFlags
525 (new_cmstate, maybe_hv) <- io (cmCompileExpr cms dflags new_expr)
526 setCmState new_cmstate
529 Just hv -> io (writeIORef commands --
530 ((macro_name, keepGoing (runMacro hv)) : cmds))
532 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
534 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
535 stringLoop (lines str)
537 undefineMacro :: String -> GHCi ()
538 undefineMacro macro_name = do
539 cmds <- io (readIORef commands)
540 if (macro_name `elem` map fst builtin_commands)
541 then throwDyn (CmdLineError
542 ("command `" ++ macro_name ++ "' cannot be undefined"))
544 if (macro_name `notElem` map fst cmds)
545 then throwDyn (CmdLineError
546 ("command `" ++ macro_name ++ "' not defined"))
548 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
551 loadModule :: String -> GHCi ()
552 loadModule str = timeIt (loadModule' str)
555 let files = words str
556 state <- getGHCiState
557 dflags <- io getDynFlags
559 -- do the dependency anal first, so that if it fails we don't throw
560 -- away the current set of modules.
561 graph <- io (cmDepAnal (cmstate state) dflags files)
563 -- Dependency anal ok, now unload everything
564 cmstate1 <- io (cmUnload (cmstate state) dflags)
565 setGHCiState state{ cmstate = cmstate1, targets = [] }
567 io (revertCAFs) -- always revert CAFs on load.
568 (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 dflags graph)
569 setGHCiState state{ cmstate = cmstate2, targets = files }
571 setContextAfterLoad mods
572 modulesLoadedMsg ok mods dflags
575 reloadModule :: String -> GHCi ()
577 state <- getGHCiState
578 dflags <- io getDynFlags
579 case targets state of
580 [] -> io (putStr "no current target\n")
582 -- do the dependency anal first, so that if it fails we don't throw
583 -- away the current set of modules.
584 graph <- io (cmDepAnal (cmstate state) dflags paths)
586 io (revertCAFs) -- always revert CAFs on reload.
588 <- io (cmLoadModules (cmstate state) dflags graph)
589 setGHCiState state{ cmstate=cmstate1 }
590 setContextAfterLoad mods
591 modulesLoadedMsg ok mods dflags
593 reloadModule _ = noArgs ":reload"
595 setContextAfterLoad [] = setContext prel
596 setContextAfterLoad (m:_) = do
597 cmstate <- getCmState
598 b <- io (cmModuleIsInterpreted cmstate m)
599 if b then setContext m else setContext ('*':m)
601 modulesLoadedMsg ok mods dflags =
602 when (verbosity dflags > 0) $ do
604 | null mods = text "none."
606 punctuate comma (map text mods)) <> text "."
609 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
611 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
614 typeOfExpr :: String -> GHCi ()
616 = do cms <- getCmState
617 dflags <- io getDynFlags
618 (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr cms dflags str)
619 setCmState new_cmstate
622 Just tystr -> io (putStrLn tystr)
624 quit :: String -> GHCi Bool
627 shellEscape :: String -> GHCi Bool
628 shellEscape str = io (system str >> return False)
630 -----------------------------------------------------------------------------
631 -- Browing a module's contents
633 browseCmd :: String -> GHCi ()
636 ['*':m] | looksLikeModuleName m -> browseModule m True
637 [m] | looksLikeModuleName m -> browseModule m False
638 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
640 browseModule m exports_only = do
642 dflags <- io getDynFlags
644 is_interpreted <- io (cmModuleIsInterpreted cms m)
645 when (not is_interpreted && not exports_only) $
646 throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
648 -- temporarily set the context to the module we're interested in,
649 -- just so we can get an appropriate PrintUnqualified
650 (as,bs) <- io (cmGetContext cms)
651 cms1 <- io (if exports_only then cmSetContext cms dflags [] [prel,m]
652 else cmSetContext cms dflags [m] [])
653 cms2 <- io (cmSetContext cms1 dflags as bs)
655 (cms3, things) <- io (cmBrowseModule cms2 dflags m exports_only)
659 let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
661 things' = filter wantToSee things
663 wantToSee (AnId id) = not (isDataConId id || isDataConWrapId id)
666 thing_names = map getName things
668 thingDecl thing@(AnId id) = ifaceTyThing thing
670 thingDecl thing@(AClass c) =
671 let rn_decl = ifaceTyThing thing in
673 ClassDecl { tcdSigs = cons } ->
674 rn_decl{ tcdSigs = filter methodIsVisible cons }
677 methodIsVisible (ClassOpSig n _ _ _) = n `elem` thing_names
679 thingDecl thing@(ATyCon t) =
680 let rn_decl = ifaceTyThing thing in
682 TyData { tcdCons = cons } ->
683 rn_decl{ tcdCons = filter conIsVisible cons }
686 conIsVisible (ConDecl n _ _ _ _ _) = n `elem` thing_names
688 io (putStrLn (showSDocForUser unqual (
689 vcat (map (ppr . thingDecl) things')))
694 -----------------------------------------------------------------------------
695 -- Setting the module context
698 | all sensible mods = fn mods
699 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
701 (fn, mods) = case str of
702 '+':stuff -> (addToContext, words stuff)
703 '-':stuff -> (removeFromContext, words stuff)
704 stuff -> (newContext, words stuff)
706 sensible ('*':m) = looksLikeModuleName m
707 sensible m = looksLikeModuleName m
711 dflags <- io getDynFlags
712 (as,bs) <- separate cms mods [] []
713 let bs' = if null as && prel `notElem` bs then prel:bs else bs
714 cms' <- io (cmSetContext cms dflags as bs')
717 separate cmstate [] as bs = return (as,bs)
718 separate cmstate (('*':m):ms) as bs = separate cmstate ms as (m:bs)
719 separate cmstate (m:ms) as bs = do
720 b <- io (cmModuleIsInterpreted cmstate m)
721 if b then separate cmstate ms (m:as) bs
722 else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
727 addToContext mods = do
729 dflags <- io getDynFlags
730 (as,bs) <- io (cmGetContext cms)
732 (as',bs') <- separate cms mods [] []
734 let as_to_add = as' \\ (as ++ bs)
735 bs_to_add = bs' \\ (as ++ bs)
737 cms' <- io (cmSetContext cms dflags
738 (as ++ as_to_add) (bs ++ bs_to_add))
742 removeFromContext mods = do
744 dflags <- io getDynFlags
745 (as,bs) <- io (cmGetContext cms)
747 (as_to_remove,bs_to_remove) <- separate cms mods [] []
749 let as' = as \\ (as_to_remove ++ bs_to_remove)
750 bs' = bs \\ (as_to_remove ++ bs_to_remove)
752 cms' <- io (cmSetContext cms dflags as' bs')
755 ----------------------------------------------------------------------------
758 -- set options in the interpreter. Syntax is exactly the same as the
759 -- ghc command line, except that certain options aren't available (-C,
762 -- This is pretty fragile: most options won't work as expected. ToDo:
763 -- figure out which ones & disallow them.
765 setCmd :: String -> GHCi ()
767 = do st <- getGHCiState
768 let opts = options st
769 io $ putStrLn (showSDoc (
770 text "options currently set: " <>
773 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
777 ("args":args) -> setArgs args
778 ("prog":prog) -> setProg prog
779 wds -> setOptions wds
783 setGHCiState st{ args = args }
787 setGHCiState st{ progname = prog }
789 io (hPutStrLn stderr "syntax: :set prog <progname>")
792 do -- first, deal with the GHCi opts (+s, +t, etc.)
793 let (plus_opts, minus_opts) = partition isPlus wds
794 mapM setOpt plus_opts
796 -- now, the GHC flags
797 pkgs_before <- io (readIORef v_Packages)
798 leftovers <- io (processArgs static_flags minus_opts [])
799 pkgs_after <- io (readIORef v_Packages)
801 -- update things if the users wants more packages
802 when (pkgs_before /= pkgs_after) $
803 newPackages (pkgs_after \\ pkgs_before)
805 -- then, dynamic flags
808 leftovers <- processArgs dynamic_flags leftovers []
811 if (not (null leftovers))
812 then throwDyn (CmdLineError ("unrecognised flags: " ++
817 unsetOptions :: String -> GHCi ()
819 = do -- first, deal with the GHCi opts (+s, +t, etc.)
821 (minus_opts, rest1) = partition isMinus opts
822 (plus_opts, rest2) = partition isPlus rest1
824 if (not (null rest2))
825 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
828 mapM unsetOpt plus_opts
830 -- can't do GHC flags for now
831 if (not (null minus_opts))
832 then throwDyn (CmdLineError "can't unset GHC command-line flags")
835 isMinus ('-':s) = True
838 isPlus ('+':s) = True
842 = case strToGHCiOpt str of
843 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
844 Just o -> setOption o
847 = case strToGHCiOpt str of
848 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
849 Just o -> unsetOption o
851 strToGHCiOpt :: String -> (Maybe GHCiOption)
852 strToGHCiOpt "s" = Just ShowTiming
853 strToGHCiOpt "t" = Just ShowType
854 strToGHCiOpt "r" = Just RevertCAFs
855 strToGHCiOpt _ = Nothing
857 optToStr :: GHCiOption -> String
858 optToStr ShowTiming = "s"
859 optToStr ShowType = "t"
860 optToStr RevertCAFs = "r"
862 newPackages new_pkgs = do
863 state <- getGHCiState
864 dflags <- io getDynFlags
865 cmstate1 <- io (cmUnload (cmstate state) dflags)
866 setGHCiState state{ cmstate = cmstate1, targets = [] }
869 pkgs <- getPackageInfo
870 flushPackageCache pkgs
872 new_pkg_info <- getPackageDetails new_pkgs
873 mapM_ (linkPackage dflags) (reverse new_pkg_info)
875 -----------------------------------------------------------------------------
880 ["modules" ] -> showModules
881 ["bindings"] -> showBindings
882 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
886 let mg = cmGetModuleGraph cms
887 ls = cmGetLinkables cms
888 maybe_linkables = map (findModuleLinkable_maybe ls)
889 (map (moduleName.ms_mod) mg)
890 zipWithM showModule mg maybe_linkables
893 showModule :: ModSummary -> Maybe Linkable -> GHCi ()
894 showModule m (Just l) = do
895 io (putStrLn (showModMsg (isObjectLinkable l) (ms_mod m) (ms_location m)))
896 showModule _ Nothing = panic "missing linkable"
901 unqual = cmGetPrintUnqual cms
902 showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
904 io (mapM showBinding (cmGetBindings cms))
907 -----------------------------------------------------------------------------
910 data GHCiState = GHCiState
914 targets :: [FilePath],
916 options :: [GHCiOption]
920 = ShowTiming -- show time/allocs after evaluation
921 | ShowType -- show the type of expressions
922 | RevertCAFs -- revert CAFs after every evaluation
925 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
926 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
928 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
930 startGHCi :: GHCi a -> GHCiState -> IO a
931 startGHCi g state = do ref <- newIORef state; unGHCi g ref
933 instance Monad GHCi where
934 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
935 return a = GHCi $ \s -> return a
937 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
938 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
939 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
941 getGHCiState = GHCi $ \r -> readIORef r
942 setGHCiState s = GHCi $ \r -> writeIORef r s
944 -- for convenience...
945 getCmState = getGHCiState >>= return . cmstate
946 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
948 isOptionSet :: GHCiOption -> GHCi Bool
950 = do st <- getGHCiState
951 return (opt `elem` options st)
953 setOption :: GHCiOption -> GHCi ()
955 = do st <- getGHCiState
956 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
958 unsetOption :: GHCiOption -> GHCi ()
960 = do st <- getGHCiState
961 setGHCiState (st{ options = filter (/= opt) (options st) })
964 io m = GHCi { unGHCi = \s -> m >>= return }
966 -----------------------------------------------------------------------------
967 -- recursive exception handlers
969 -- Don't forget to unblock async exceptions in the handler, or if we're
970 -- in an exception loop (eg. let a = error a in a) the ^C exception
971 -- may never be delivered. Thanks to Marcin for pointing out the bug.
973 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
974 ghciHandle h (GHCi m) = GHCi $ \s ->
975 Exception.catch (m s)
976 (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
978 ghciUnblock :: GHCi a -> GHCi a
979 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
981 -----------------------------------------------------------------------------
984 -- Left: full path name of a .o file, including trailing .o
985 -- Right: "unadorned" name of a .DLL/.so
986 -- e.g. On unix "qt" denotes "libqt.so"
987 -- On WinDoze "burble" denotes "burble.DLL"
988 -- addDLL is platform-specific and adds the lib/.so/.DLL
989 -- suffixes platform-dependently; we don't do that here.
991 -- For dynamic objects only, try to find the object file in all the
992 -- directories specified in v_Library_Paths before giving up.
995 = Either FilePath String
997 showLS (Left nm) = "(static) " ++ nm
998 showLS (Right nm) = "(dynamic) " ++ nm
1000 linkPackages :: DynFlags -> [LibrarySpec] -> [PackageConfig] -> IO ()
1001 linkPackages dflags cmdline_lib_specs pkgs
1002 = do mapM_ (linkPackage dflags) (reverse pkgs)
1003 lib_paths <- readIORef v_Library_paths
1004 mapM_ (preloadLib dflags lib_paths) cmdline_lib_specs
1005 if (null cmdline_lib_specs)
1007 else do maybePutStr dflags "final link ... "
1009 if ok then maybePutStrLn dflags "done."
1010 else throwDyn (InstallationError
1011 "linking extra libraries/objects failed")
1013 preloadLib :: DynFlags -> [String] -> LibrarySpec -> IO ()
1014 preloadLib dflags lib_paths lib_spec
1015 = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
1018 -> do b <- preload_static lib_paths static_ish
1019 maybePutStrLn dflags (if b then "done."
1022 -> -- We add "" to the set of paths to try, so that
1023 -- if none of the real paths match, we force addDLL
1024 -- to look in the default dynamic-link search paths.
1025 do maybe_errstr <- preload_dynamic (lib_paths++[""])
1027 case maybe_errstr of
1028 Nothing -> return ()
1029 Just mm -> preloadFailed mm lib_paths lib_spec
1030 maybePutStrLn dflags "done"
1032 preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
1033 preloadFailed sys_errmsg paths spec
1034 = do maybePutStr dflags
1035 ("failed.\nDynamic linker error message was:\n "
1036 ++ sys_errmsg ++ "\nWhilst trying to load: "
1037 ++ showLS spec ++ "\nDirectories to search are:\n"
1038 ++ unlines (map (" "++) paths) )
1041 -- not interested in the paths in the static case.
1042 preload_static paths name
1043 = do b <- doesFileExist name
1044 if not b then return False
1045 else loadObj name >> return True
1047 -- return Nothing == success, else Just error message from addDLL
1048 preload_dynamic [] name
1050 preload_dynamic (path:paths) rootname
1051 = do -- addDLL returns NULL on success
1052 maybe_errmsg <- addDLL path rootname
1053 if maybe_errmsg == nullPtr
1054 then preload_dynamic paths rootname
1055 else do str <- peekCString maybe_errmsg
1059 = (throwDyn . CmdLineError)
1060 "user specified .o/.so/.DLL could not be loaded."
1062 -- Packages that don't need loading, because the compiler shares them with
1063 -- the interpreted program.
1064 dont_load_these = [ "gmp", "rts" ]
1066 -- Packages that are already linked into GHCi. For mingw32, we only
1067 -- skip gmp and rts, since std and after need to load the msvcrt.dll
1068 -- library which std depends on.
1070 # ifndef mingw32_TARGET_OS
1071 = [ "std", "concurrent", "posix", "text", "util" ]
1076 linkPackage :: DynFlags -> PackageConfig -> IO ()
1077 linkPackage dflags pkg
1078 | name pkg `elem` dont_load_these = return ()
1081 -- For each obj, try obj.o and if that fails, obj.so.
1082 -- Complication: all the .so's must be loaded before any of the .o's.
1083 let dirs = library_dirs pkg
1084 let objs = hs_libraries pkg ++ extra_libraries pkg
1085 classifieds <- mapM (locateOneObj dirs) objs
1087 -- Don't load the .so libs if this is a package GHCi is already
1088 -- linked against, because we'll already have the .so linked in.
1089 let (so_libs, obj_libs) = partition isRight classifieds
1090 let sos_first | name pkg `elem` loaded_in_ghci = obj_libs
1091 | otherwise = so_libs ++ obj_libs
1093 maybePutStr dflags ("Loading package " ++ name pkg ++ " ... ")
1094 mapM loadClassified sos_first
1095 maybePutStr dflags "linking ... "
1097 if ok then maybePutStrLn dflags "done."
1098 else panic ("can't load package `" ++ name pkg ++ "'")
1100 isRight (Right _) = True
1101 isRight (Left _) = False
1103 loadClassified :: LibrarySpec -> IO ()
1104 loadClassified (Left obj_absolute_filename)
1105 = do loadObj obj_absolute_filename
1106 loadClassified (Right dll_unadorned)
1107 = do maybe_errmsg <- addDLL "" dll_unadorned -- doesn't seem right to me
1108 if maybe_errmsg == nullPtr
1110 else do str <- peekCString maybe_errmsg
1111 throwDyn (CmdLineError ("can't load .so/.DLL for: "
1112 ++ dll_unadorned ++ " (" ++ str ++ ")" ))
1114 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
1116 = return (Right obj) -- we assume
1117 locateOneObj (d:ds) obj
1118 = do let path = d ++ '/':obj ++ ".o"
1119 b <- doesFileExist path
1120 if b then return (Left path) else locateOneObj ds obj
1122 -----------------------------------------------------------------------------
1123 -- timing & statistics
1125 timeIt :: GHCi a -> GHCi a
1127 = do b <- isOptionSet ShowTiming
1130 else do allocs1 <- io $ getAllocations
1131 time1 <- io $ getCPUTime
1133 allocs2 <- io $ getAllocations
1134 time2 <- io $ getCPUTime
1135 io $ printTimes (allocs2 - allocs1) (time2 - time1)
1138 foreign import "getAllocations" getAllocations :: IO Int
1140 printTimes :: Int -> Integer -> IO ()
1141 printTimes allocs psecs
1142 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1143 secs_str = showFFloat (Just 2) secs
1144 putStrLn (showSDoc (
1145 parens (text (secs_str "") <+> text "secs" <> comma <+>
1146 int allocs <+> text "bytes")))
1148 -----------------------------------------------------------------------------
1151 looksLikeModuleName [] = False
1152 looksLikeModuleName (c:cs) = isUpper c && all isAlphaNumEx cs
1154 isAlphaNumEx c = isAlphaNum c || c == '_'
1156 maybePutStr dflags s | verbosity dflags > 0 = putStr s
1157 | otherwise = return ()
1159 maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
1160 | otherwise = return ()
1162 -----------------------------------------------------------------------------
1165 foreign import revertCAFs :: IO () -- make it "safe", just in case