1 {-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.115 2002/02/13 15:56:18 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, DataConDetails(..) )
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 GlaExts ( unsafeCoerce# )
72 import Foreign ( nullPtr )
73 import CString ( peekCString )
75 -----------------------------------------------------------------------------
79 \ / _ \\ /\\ /\\/ __(_)\n\
80 \ / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n\
81 \/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n\
82 \\\____/\\/ /_/\\____/|_| Type :? for help.\n"
84 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
86 builtin_commands :: [(String, String -> GHCi Bool)]
88 ("add", keepGoing addModule),
89 ("browse", keepGoing browseCmd),
90 ("cd", keepGoing changeDirectory),
91 ("def", keepGoing defineMacro),
92 ("help", keepGoing help),
93 ("?", keepGoing help),
94 ("info", keepGoing info),
95 ("load", keepGoing loadModule),
96 ("module", keepGoing setContext),
97 ("reload", keepGoing reloadModule),
98 ("set", keepGoing setCmd),
99 ("show", keepGoing showCmd),
100 ("type", keepGoing typeOfExpr),
101 ("unset", keepGoing unsetOptions),
102 ("undef", keepGoing undefineMacro),
106 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
107 keepGoing a str = a str >> return False
109 shortHelpText = "use :? for help.\n"
112 \ Commands available from the prompt:\n\
114 \ <stmt> evaluate/run <stmt>\n\
115 \ :add <filename> ... add module(s) to the current target set\n\
116 \ :browse [*]<module> display the names defined by <module>\n\
117 \ :cd <dir> change directory to <dir>\n\
118 \ :def <cmd> <expr> define a command :<cmd>\n\
119 \ :help, :? display this list of commands\n\
120 \ :info [<name> ...] display information about the given names\n\
121 \ :load <filename> ... load module(s) and their dependents\n\
122 \ :module <mod> set the context for expression evaluation to <mod>\n\
123 \ :reload reload the current module set\n\
125 \ :set <option> ... set options\n\
126 \ :set args <arg> ... set the arguments returned by System.getArgs\n\
127 \ :set prog <progname> set the value returned by System.getProgName\n\
129 \ :show modules show the currently loaded modules\n\
130 \ :show bindings show the current bindings made at the prompt\n\
132 \ :type <expr> show the type of <expr>\n\
133 \ :undef <cmd> undefine user-defined command :<cmd>\n\
134 \ :unset <option> ... unset options\n\
136 \ :!<command> run the shell command <command>\n\
138 \ Options for `:set' and `:unset':\n\
140 \ +r revert top-level expressions after each evaluation\n\
141 \ +s print timing/memory stats after each evaluation\n\
142 \ +t print type after evaluation\n\
143 \ -<flags> most GHC command line flags can also be set here\n\
144 \ (eg. -v2, -fglasgow-exts, etc.)\n\
147 interactiveUI :: CmState -> [FilePath] -> [LibrarySpec] -> IO ()
148 interactiveUI cmstate paths cmdline_libs = do
150 hSetBuffering stdout NoBuffering
152 dflags <- getDynFlags
154 -- link in the available packages
155 pkgs <- getPackageInfo
157 linkPackages dflags cmdline_libs pkgs
159 (cmstate, maybe_hval)
160 <- cmCompileExpr cmstate dflags "IO.hSetBuffering IO.stdout IO.NoBuffering Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
162 Just hval -> unsafeCoerce# hval :: IO ()
163 _ -> panic "interactiveUI:buffering"
165 (cmstate, maybe_hval)
166 <- cmCompileExpr cmstate dflags "IO.hFlush IO.stderr"
168 Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ())
169 _ -> panic "interactiveUI:stderr"
171 (cmstate, maybe_hval)
172 <- cmCompileExpr cmstate dflags "IO.hFlush IO.stdout"
174 Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ())
175 _ -> panic "interactiveUI:stdout"
177 -- We don't want the cmd line to buffer any input that might be
178 -- intended for the program, so unbuffer stdin.
179 hSetBuffering stdin NoBuffering
181 -- initial context is just the Prelude
182 cmstate <- cmSetContext cmstate dflags [] ["Prelude"]
184 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
188 startGHCi (runGHCi paths dflags)
189 GHCiState{ progname = "<interactive>",
195 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
196 Readline.resetTerminal Nothing
202 runGHCi :: [FilePath] -> DynFlags -> GHCi ()
203 runGHCi paths dflags = do
204 read_dot_files <- io (readIORef v_Read_DotGHCi)
206 when (read_dot_files) $ do
209 exists <- io (doesFileExist file)
211 dir_ok <- io (checkPerms ".")
212 file_ok <- io (checkPerms file)
213 when (dir_ok && file_ok) $ do
214 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
217 Right hdl -> fileLoop hdl False
219 when (read_dot_files) $ do
220 -- Read in $HOME/.ghci
221 either_dir <- io (IO.try (getEnv "HOME"))
225 cwd <- io (getCurrentDirectory)
226 when (dir /= cwd) $ do
227 let file = dir ++ "/.ghci"
228 ok <- io (checkPerms file)
230 either_hdl <- io (IO.try (openFile file ReadMode))
233 Right hdl -> fileLoop hdl False
235 -- perform a :load for files given on the GHCi command line
236 when (not (null paths)) $
237 ghciHandle showException $
238 loadModule (unwords paths)
240 -- enter the interactive loop
241 is_tty <- io (hIsTerminalDevice stdin)
242 interactiveLoop is_tty
245 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
248 interactiveLoop is_tty = do
249 -- ignore ^C exceptions caught here
250 ghciHandleDyn (\e -> case e of
251 Interrupted -> ghciUnblock (interactiveLoop is_tty)
252 _other -> return ()) $ do
254 -- read commands from stdin
255 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
258 else fileLoop stdin False -- turn off prompt for non-TTY input
264 -- NOTE: We only read .ghci files if they are owned by the current user,
265 -- and aren't world writable. Otherwise, we could be accidentally
266 -- running code planted by a malicious third party.
268 -- Furthermore, We only read ./.ghci if . is owned by the current user
269 -- and isn't writable by anyone else. I think this is sufficient: we
270 -- don't need to check .. and ../.. etc. because "." always refers to
271 -- the same directory while a process is running.
273 checkPerms :: String -> IO Bool
275 DriverUtil.handle (\_ -> return False) $ do
276 #ifdef mingw32_TARGET_OS
279 st <- getFileStatus name
281 if fileOwner st /= me then do
282 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
285 let mode = fileMode st
286 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
287 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
289 putStrLn $ "*** WARNING: " ++ name ++
290 " is writable by someone else, IGNORING!"
295 fileLoop :: Handle -> Bool -> GHCi ()
296 fileLoop hdl prompt = do
297 cmstate <- getCmState
298 (mod,imports) <- io (cmGetContext cmstate)
299 when prompt (io (putStr (mkPrompt mod imports)))
300 l <- io (IO.try (hGetLine hdl))
302 Left e | isEOFError e -> return ()
303 | otherwise -> throw e
305 case remove_spaces l of
306 "" -> fileLoop hdl prompt
307 l -> do quit <- runCommand l
308 if quit then return () else fileLoop hdl prompt
310 stringLoop :: [String] -> GHCi ()
311 stringLoop [] = return ()
312 stringLoop (s:ss) = do
313 case remove_spaces s of
315 l -> do quit <- runCommand l
316 if quit then return () else stringLoop ss
318 mkPrompt toplevs exports
319 = concat (intersperse " " (toplevs ++ map ('*':) exports)) ++ "> "
321 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
322 readlineLoop :: GHCi ()
324 cmstate <- getCmState
325 (mod,imports) <- io (cmGetContext cmstate)
327 l <- io (readline (mkPrompt mod imports))
331 case remove_spaces l of
336 if quit then return () else readlineLoop
339 -- Top level exception handler, just prints out the exception
341 runCommand :: String -> GHCi Bool
343 ghciHandle ( \exception -> do
345 showException exception
350 showException (DynException dyn) =
351 case fromDynamic dyn of
352 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
353 Just Interrupted -> io (putStrLn "Interrupted.")
354 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
355 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
356 Just other_ghc_ex -> io (print other_ghc_ex)
358 showException other_exception
359 = io (putStrLn ("*** Exception: " ++ show other_exception))
361 doCommand (':' : command) = specialCommand command
363 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
366 runStmt :: String -> GHCi [Name]
368 | null (filter (not.isSpace) stmt) = return []
370 = do st <- getGHCiState
371 dflags <- io getDynFlags
372 let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
373 (new_cmstate, result) <-
374 io $ withProgName (progname st) $ withArgs (args st) $
375 cmRunStmt (cmstate st) dflags' stmt
376 setGHCiState st{cmstate = new_cmstate}
378 CmRunFailed -> return []
379 CmRunException e -> showException e >> return []
380 CmRunOk names -> return names
382 -- possibly print the type and revert CAFs after evaluating an expression
384 = do b <- isOptionSet ShowType
385 cmstate <- getCmState
386 when b (mapM_ (showTypeOfName cmstate) names)
388 b <- isOptionSet RevertCAFs
389 io (when b revertCAFs)
393 showTypeOfName :: CmState -> Name -> GHCi ()
394 showTypeOfName cmstate n
395 = do maybe_str <- io (cmTypeOfName cmstate n)
398 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
400 flushEverything :: GHCi ()
402 = io $ do Monad.join (readIORef flush_stdout)
403 Monad.join (readIORef flush_stderr)
406 specialCommand :: String -> GHCi Bool
407 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
408 specialCommand str = do
409 let (cmd,rest) = break isSpace str
410 cmds <- io (readIORef commands)
411 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
412 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
413 ++ shortHelpText) >> return False)
414 [(_,f)] -> f (dropWhile isSpace rest)
415 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
416 " matches multiple commands (" ++
417 foldr1 (\a b -> a ++ ',':b) (map fst cs)
418 ++ ")") >> return False)
420 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
422 -----------------------------------------------------------------------------
425 help :: String -> GHCi ()
426 help _ = io (putStr helpText)
428 info :: String -> GHCi ()
429 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
432 init_cms <- getCmState
433 dflags <- io getDynFlags
435 infoThings cms [] = return cms
436 infoThings cms (name:names) = do
437 (cms, stuff) <- io (cmInfoThing cms dflags name)
438 io (putStrLn (showSDocForUser unqual (
439 vcat (intersperse (text "") (map showThing stuff))))
443 unqual = cmGetPrintUnqual init_cms
445 showThing (ty_thing, fixity)
446 = vcat [ text "-- " <> showTyThing ty_thing,
447 showFixity fixity (getName ty_thing),
448 ppr (ifaceTyThing ty_thing) ]
451 | fix == defaultFixity = empty
452 | otherwise = ppr fix <+>
453 (if isSymOcc (nameOccName name)
455 else char '`' <> ppr name <> char '`')
457 showTyThing (AClass cl)
458 = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
459 showTyThing (ATyCon ty)
461 = hcat [ppr ty, text " is a primitive type constructor"]
463 = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
464 showTyThing (AnId id)
465 = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
468 | isRecordSelector id =
469 case tyConClass_maybe (fieldLabelTyCon (
470 recordSelectorFieldLabel id)) of
471 Nothing -> text "record selector"
472 Just c -> text "method in class " <> ppr c
473 | isDataConWrapId id = text "data constructor"
474 | otherwise = text "variable"
476 -- also print out the source location for home things
478 | isHomePackageName name && isGoodSrcLoc loc
479 = hsep [ text ", defined at", ppr loc ]
482 where loc = nameSrcLoc name
484 cms <- infoThings init_cms names
488 addModule :: String -> GHCi ()
490 let files = words str
491 state <- getGHCiState
492 dflags <- io (getDynFlags)
493 io (revertCAFs) -- always revert CAFs on load/add.
494 let new_targets = files ++ targets state
495 graph <- io (cmDepAnal (cmstate state) dflags new_targets)
496 (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph)
497 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
498 setContextAfterLoad mods
499 modulesLoadedMsg ok mods dflags
501 changeDirectory :: String -> GHCi ()
502 changeDirectory ('~':d) = do
503 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
504 io (setCurrentDirectory (tilde ++ '/':d))
505 changeDirectory d = io (setCurrentDirectory d)
507 defineMacro :: String -> GHCi ()
509 let (macro_name, definition) = break isSpace s
510 cmds <- io (readIORef commands)
512 then throwDyn (CmdLineError "invalid macro name")
514 if (macro_name `elem` map fst cmds)
515 then throwDyn (CmdLineError
516 ("command `" ++ macro_name ++ "' is already defined"))
519 -- give the expression a type signature, so we can be sure we're getting
520 -- something of the right type.
521 let new_expr = '(' : definition ++ ") :: String -> IO String"
523 -- compile the expression
525 dflags <- io getDynFlags
526 (new_cmstate, maybe_hv) <- io (cmCompileExpr cms dflags new_expr)
527 setCmState new_cmstate
530 Just hv -> io (writeIORef commands --
531 ((macro_name, keepGoing (runMacro hv)) : cmds))
533 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
535 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
536 stringLoop (lines str)
538 undefineMacro :: String -> GHCi ()
539 undefineMacro macro_name = do
540 cmds <- io (readIORef commands)
541 if (macro_name `elem` map fst builtin_commands)
542 then throwDyn (CmdLineError
543 ("command `" ++ macro_name ++ "' cannot be undefined"))
545 if (macro_name `notElem` map fst cmds)
546 then throwDyn (CmdLineError
547 ("command `" ++ macro_name ++ "' not defined"))
549 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
552 loadModule :: String -> GHCi ()
553 loadModule str = timeIt (loadModule' str)
556 let files = words str
557 state <- getGHCiState
558 dflags <- io getDynFlags
560 -- do the dependency anal first, so that if it fails we don't throw
561 -- away the current set of modules.
562 graph <- io (cmDepAnal (cmstate state) dflags files)
564 -- Dependency anal ok, now unload everything
565 cmstate1 <- io (cmUnload (cmstate state) dflags)
566 setGHCiState state{ cmstate = cmstate1, targets = [] }
568 io (revertCAFs) -- always revert CAFs on load.
569 (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 dflags graph)
570 setGHCiState state{ cmstate = cmstate2, targets = files }
572 setContextAfterLoad mods
573 modulesLoadedMsg ok mods dflags
576 reloadModule :: String -> GHCi ()
578 state <- getGHCiState
579 dflags <- io getDynFlags
580 case targets state of
581 [] -> io (putStr "no current target\n")
583 -- do the dependency anal first, so that if it fails we don't throw
584 -- away the current set of modules.
585 graph <- io (cmDepAnal (cmstate state) dflags paths)
587 io (revertCAFs) -- always revert CAFs on reload.
589 <- io (cmLoadModules (cmstate state) dflags graph)
590 setGHCiState state{ cmstate=cmstate1 }
591 setContextAfterLoad mods
592 modulesLoadedMsg ok mods dflags
594 reloadModule _ = noArgs ":reload"
596 setContextAfterLoad [] = setContext prel
597 setContextAfterLoad (m:_) = do
598 cmstate <- getCmState
599 b <- io (cmModuleIsInterpreted cmstate m)
600 if b then setContext m else setContext ('*':m)
602 modulesLoadedMsg ok mods dflags =
603 when (verbosity dflags > 0) $ do
605 | null mods = text "none."
607 punctuate comma (map text mods)) <> text "."
610 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
612 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
615 typeOfExpr :: String -> GHCi ()
617 = do cms <- getCmState
618 dflags <- io getDynFlags
619 (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr cms dflags str)
620 setCmState new_cmstate
623 Just tystr -> io (putStrLn tystr)
625 quit :: String -> GHCi Bool
628 shellEscape :: String -> GHCi Bool
629 shellEscape str = io (system str >> return False)
631 -----------------------------------------------------------------------------
632 -- Browing a module's contents
634 browseCmd :: String -> GHCi ()
637 ['*':m] | looksLikeModuleName m -> browseModule m True
638 [m] | looksLikeModuleName m -> browseModule m False
639 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
641 browseModule m exports_only = do
643 dflags <- io getDynFlags
645 is_interpreted <- io (cmModuleIsInterpreted cms m)
646 when (not is_interpreted && not exports_only) $
647 throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
649 -- temporarily set the context to the module we're interested in,
650 -- just so we can get an appropriate PrintUnqualified
651 (as,bs) <- io (cmGetContext cms)
652 cms1 <- io (if exports_only then cmSetContext cms dflags [] [prel,m]
653 else cmSetContext cms dflags [m] [])
654 cms2 <- io (cmSetContext cms1 dflags as bs)
656 (cms3, things) <- io (cmBrowseModule cms2 dflags m exports_only)
660 let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
662 things' = filter wantToSee things
664 wantToSee (AnId id) = not (isDataConId id || isDataConWrapId id)
667 thing_names = map getName things
669 thingDecl thing@(AnId id) = ifaceTyThing thing
671 thingDecl thing@(AClass c) =
672 let rn_decl = ifaceTyThing thing in
674 ClassDecl { tcdSigs = cons } ->
675 rn_decl{ tcdSigs = filter methodIsVisible cons }
678 methodIsVisible (ClassOpSig n _ _ _) = n `elem` thing_names
680 thingDecl thing@(ATyCon t) =
681 let rn_decl = ifaceTyThing thing in
683 TyData { tcdCons = DataCons cons } ->
684 rn_decl{ tcdCons = DataCons (filter conIsVisible cons) }
687 conIsVisible (ConDecl n _ _ _ _ _) = n `elem` thing_names
689 io (putStrLn (showSDocForUser unqual (
690 vcat (map (ppr . thingDecl) things')))
695 -----------------------------------------------------------------------------
696 -- Setting the module context
699 | all sensible mods = fn mods
700 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
702 (fn, mods) = case str of
703 '+':stuff -> (addToContext, words stuff)
704 '-':stuff -> (removeFromContext, words stuff)
705 stuff -> (newContext, words stuff)
707 sensible ('*':m) = looksLikeModuleName m
708 sensible m = looksLikeModuleName m
712 dflags <- io getDynFlags
713 (as,bs) <- separate cms mods [] []
714 let bs' = if null as && prel `notElem` bs then prel:bs else bs
715 cms' <- io (cmSetContext cms dflags as bs')
718 separate cmstate [] as bs = return (as,bs)
719 separate cmstate (('*':m):ms) as bs = separate cmstate ms as (m:bs)
720 separate cmstate (m:ms) as bs = do
721 b <- io (cmModuleIsInterpreted cmstate m)
722 if b then separate cmstate ms (m:as) bs
723 else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
728 addToContext mods = do
730 dflags <- io getDynFlags
731 (as,bs) <- io (cmGetContext cms)
733 (as',bs') <- separate cms mods [] []
735 let as_to_add = as' \\ (as ++ bs)
736 bs_to_add = bs' \\ (as ++ bs)
738 cms' <- io (cmSetContext cms dflags
739 (as ++ as_to_add) (bs ++ bs_to_add))
743 removeFromContext mods = do
745 dflags <- io getDynFlags
746 (as,bs) <- io (cmGetContext cms)
748 (as_to_remove,bs_to_remove) <- separate cms mods [] []
750 let as' = as \\ (as_to_remove ++ bs_to_remove)
751 bs' = bs \\ (as_to_remove ++ bs_to_remove)
753 cms' <- io (cmSetContext cms dflags as' bs')
756 ----------------------------------------------------------------------------
759 -- set options in the interpreter. Syntax is exactly the same as the
760 -- ghc command line, except that certain options aren't available (-C,
763 -- This is pretty fragile: most options won't work as expected. ToDo:
764 -- figure out which ones & disallow them.
766 setCmd :: String -> GHCi ()
768 = do st <- getGHCiState
769 let opts = options st
770 io $ putStrLn (showSDoc (
771 text "options currently set: " <>
774 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
778 ("args":args) -> setArgs args
779 ("prog":prog) -> setProg prog
780 wds -> setOptions wds
784 setGHCiState st{ args = args }
788 setGHCiState st{ progname = prog }
790 io (hPutStrLn stderr "syntax: :set prog <progname>")
793 do -- first, deal with the GHCi opts (+s, +t, etc.)
794 let (plus_opts, minus_opts) = partition isPlus wds
795 mapM setOpt plus_opts
797 -- now, the GHC flags
798 pkgs_before <- io (readIORef v_Packages)
799 leftovers <- io (processArgs static_flags minus_opts [])
800 pkgs_after <- io (readIORef v_Packages)
802 -- update things if the users wants more packages
803 when (pkgs_before /= pkgs_after) $
804 newPackages (pkgs_after \\ pkgs_before)
806 -- then, dynamic flags
809 leftovers <- processArgs dynamic_flags leftovers []
812 if (not (null leftovers))
813 then throwDyn (CmdLineError ("unrecognised flags: " ++
818 unsetOptions :: String -> GHCi ()
820 = do -- first, deal with the GHCi opts (+s, +t, etc.)
822 (minus_opts, rest1) = partition isMinus opts
823 (plus_opts, rest2) = partition isPlus rest1
825 if (not (null rest2))
826 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
829 mapM unsetOpt plus_opts
831 -- can't do GHC flags for now
832 if (not (null minus_opts))
833 then throwDyn (CmdLineError "can't unset GHC command-line flags")
836 isMinus ('-':s) = True
839 isPlus ('+':s) = True
843 = case strToGHCiOpt str of
844 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
845 Just o -> setOption o
848 = case strToGHCiOpt str of
849 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
850 Just o -> unsetOption o
852 strToGHCiOpt :: String -> (Maybe GHCiOption)
853 strToGHCiOpt "s" = Just ShowTiming
854 strToGHCiOpt "t" = Just ShowType
855 strToGHCiOpt "r" = Just RevertCAFs
856 strToGHCiOpt _ = Nothing
858 optToStr :: GHCiOption -> String
859 optToStr ShowTiming = "s"
860 optToStr ShowType = "t"
861 optToStr RevertCAFs = "r"
863 newPackages new_pkgs = do
864 state <- getGHCiState
865 dflags <- io getDynFlags
866 cmstate1 <- io (cmUnload (cmstate state) dflags)
867 setGHCiState state{ cmstate = cmstate1, targets = [] }
870 pkgs <- getPackageInfo
871 flushPackageCache pkgs
873 new_pkg_info <- getPackageDetails new_pkgs
874 mapM_ (linkPackage dflags) (reverse new_pkg_info)
876 -----------------------------------------------------------------------------
881 ["modules" ] -> showModules
882 ["bindings"] -> showBindings
883 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
887 let mg = cmGetModuleGraph cms
888 ls = cmGetLinkables cms
889 maybe_linkables = map (findModuleLinkable_maybe ls)
890 (map (moduleName.ms_mod) mg)
891 zipWithM showModule mg maybe_linkables
894 showModule :: ModSummary -> Maybe Linkable -> GHCi ()
895 showModule m (Just l) = do
896 io (putStrLn (showModMsg (isObjectLinkable l) (ms_mod m) (ms_location m)))
897 showModule _ Nothing = panic "missing linkable"
902 unqual = cmGetPrintUnqual cms
903 showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
905 io (mapM showBinding (cmGetBindings cms))
908 -----------------------------------------------------------------------------
911 data GHCiState = GHCiState
915 targets :: [FilePath],
917 options :: [GHCiOption]
921 = ShowTiming -- show time/allocs after evaluation
922 | ShowType -- show the type of expressions
923 | RevertCAFs -- revert CAFs after every evaluation
926 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
927 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
929 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
931 startGHCi :: GHCi a -> GHCiState -> IO a
932 startGHCi g state = do ref <- newIORef state; unGHCi g ref
934 instance Monad GHCi where
935 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
936 return a = GHCi $ \s -> return a
938 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
939 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
940 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
942 getGHCiState = GHCi $ \r -> readIORef r
943 setGHCiState s = GHCi $ \r -> writeIORef r s
945 -- for convenience...
946 getCmState = getGHCiState >>= return . cmstate
947 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
949 isOptionSet :: GHCiOption -> GHCi Bool
951 = do st <- getGHCiState
952 return (opt `elem` options st)
954 setOption :: GHCiOption -> GHCi ()
956 = do st <- getGHCiState
957 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
959 unsetOption :: GHCiOption -> GHCi ()
961 = do st <- getGHCiState
962 setGHCiState (st{ options = filter (/= opt) (options st) })
965 io m = GHCi { unGHCi = \s -> m >>= return }
967 -----------------------------------------------------------------------------
968 -- recursive exception handlers
970 -- Don't forget to unblock async exceptions in the handler, or if we're
971 -- in an exception loop (eg. let a = error a in a) the ^C exception
972 -- may never be delivered. Thanks to Marcin for pointing out the bug.
974 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
975 ghciHandle h (GHCi m) = GHCi $ \s ->
976 Exception.catch (m s)
977 (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
979 ghciUnblock :: GHCi a -> GHCi a
980 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
982 -----------------------------------------------------------------------------
985 -- Left: full path name of a .o file, including trailing .o
986 -- Right: "unadorned" name of a .DLL/.so
987 -- e.g. On unix "qt" denotes "libqt.so"
988 -- On WinDoze "burble" denotes "burble.DLL"
989 -- addDLL is platform-specific and adds the lib/.so/.DLL
990 -- suffixes platform-dependently; we don't do that here.
992 -- For dynamic objects only, try to find the object file in all the
993 -- directories specified in v_Library_Paths before giving up.
996 = Either FilePath String
998 showLS (Left nm) = "(static) " ++ nm
999 showLS (Right nm) = "(dynamic) " ++ nm
1001 linkPackages :: DynFlags -> [LibrarySpec] -> [PackageConfig] -> IO ()
1002 linkPackages dflags cmdline_lib_specs pkgs
1003 = do mapM_ (linkPackage dflags) (reverse pkgs)
1004 lib_paths <- readIORef v_Library_paths
1005 mapM_ (preloadLib dflags lib_paths) cmdline_lib_specs
1006 if (null cmdline_lib_specs)
1008 else do maybePutStr dflags "final link ... "
1010 if ok then maybePutStrLn dflags "done."
1011 else throwDyn (InstallationError
1012 "linking extra libraries/objects failed")
1014 preloadLib :: DynFlags -> [String] -> LibrarySpec -> IO ()
1015 preloadLib dflags lib_paths lib_spec
1016 = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
1019 -> do b <- preload_static lib_paths static_ish
1020 maybePutStrLn dflags (if b then "done."
1023 -> -- We add "" to the set of paths to try, so that
1024 -- if none of the real paths match, we force addDLL
1025 -- to look in the default dynamic-link search paths.
1026 do maybe_errstr <- preload_dynamic (lib_paths++[""])
1028 case maybe_errstr of
1029 Nothing -> return ()
1030 Just mm -> preloadFailed mm lib_paths lib_spec
1031 maybePutStrLn dflags "done"
1033 preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
1034 preloadFailed sys_errmsg paths spec
1035 = do maybePutStr dflags
1036 ("failed.\nDynamic linker error message was:\n "
1037 ++ sys_errmsg ++ "\nWhilst trying to load: "
1038 ++ showLS spec ++ "\nDirectories to search are:\n"
1039 ++ unlines (map (" "++) paths) )
1042 -- not interested in the paths in the static case.
1043 preload_static paths name
1044 = do b <- doesFileExist name
1045 if not b then return False
1046 else loadObj name >> return True
1048 -- return Nothing == success, else Just error message from addDLL
1049 preload_dynamic [] name
1051 preload_dynamic (path:paths) rootname
1052 = do -- addDLL returns NULL on success
1053 maybe_errmsg <- addDLL path rootname
1054 if maybe_errmsg == nullPtr
1055 then preload_dynamic paths rootname
1056 else do str <- peekCString maybe_errmsg
1060 = (throwDyn . CmdLineError)
1061 "user specified .o/.so/.DLL could not be loaded."
1063 -- Packages that don't need loading, because the compiler shares them with
1064 -- the interpreted program.
1065 dont_load_these = [ "gmp", "rts" ]
1067 -- Packages that are already linked into GHCi. For mingw32, we only
1068 -- skip gmp and rts, since std and after need to load the msvcrt.dll
1069 -- library which std depends on.
1071 # ifndef mingw32_TARGET_OS
1072 = [ "std", "concurrent", "posix", "text", "util" ]
1077 linkPackage :: DynFlags -> PackageConfig -> IO ()
1078 linkPackage dflags pkg
1079 | name pkg `elem` dont_load_these = return ()
1082 -- For each obj, try obj.o and if that fails, obj.so.
1083 -- Complication: all the .so's must be loaded before any of the .o's.
1084 let dirs = library_dirs pkg
1085 let objs = hs_libraries pkg ++ extra_libraries pkg
1086 classifieds <- mapM (locateOneObj dirs) objs
1088 -- Don't load the .so libs if this is a package GHCi is already
1089 -- linked against, because we'll already have the .so linked in.
1090 let (so_libs, obj_libs) = partition isRight classifieds
1091 let sos_first | name pkg `elem` loaded_in_ghci = obj_libs
1092 | otherwise = so_libs ++ obj_libs
1094 maybePutStr dflags ("Loading package " ++ name pkg ++ " ... ")
1095 mapM loadClassified sos_first
1096 maybePutStr dflags "linking ... "
1098 if ok then maybePutStrLn dflags "done."
1099 else panic ("can't load package `" ++ name pkg ++ "'")
1101 isRight (Right _) = True
1102 isRight (Left _) = False
1104 loadClassified :: LibrarySpec -> IO ()
1105 loadClassified (Left obj_absolute_filename)
1106 = do loadObj obj_absolute_filename
1107 loadClassified (Right dll_unadorned)
1108 = do maybe_errmsg <- addDLL "" dll_unadorned -- doesn't seem right to me
1109 if maybe_errmsg == nullPtr
1111 else do str <- peekCString maybe_errmsg
1112 throwDyn (CmdLineError ("can't load .so/.DLL for: "
1113 ++ dll_unadorned ++ " (" ++ str ++ ")" ))
1115 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
1117 = return (Right obj) -- we assume
1118 locateOneObj (d:ds) obj
1119 = do let path = d ++ '/':obj ++ ".o"
1120 b <- doesFileExist path
1121 if b then return (Left path) else locateOneObj ds obj
1123 -----------------------------------------------------------------------------
1124 -- timing & statistics
1126 timeIt :: GHCi a -> GHCi a
1128 = do b <- isOptionSet ShowTiming
1131 else do allocs1 <- io $ getAllocations
1132 time1 <- io $ getCPUTime
1134 allocs2 <- io $ getAllocations
1135 time2 <- io $ getCPUTime
1136 io $ printTimes (allocs2 - allocs1) (time2 - time1)
1139 foreign import "getAllocations" getAllocations :: IO Int
1141 printTimes :: Int -> Integer -> IO ()
1142 printTimes allocs psecs
1143 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1144 secs_str = showFFloat (Just 2) secs
1145 putStrLn (showSDoc (
1146 parens (text (secs_str "") <+> text "secs" <> comma <+>
1147 int allocs <+> text "bytes")))
1149 -----------------------------------------------------------------------------
1152 looksLikeModuleName [] = False
1153 looksLikeModuleName (c:cs) = isUpper c && all isAlphaNumEx cs
1155 isAlphaNumEx c = isAlphaNum c || c == '_'
1157 maybePutStr dflags s | verbosity dflags > 0 = putStr s
1158 | otherwise = return ()
1160 maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
1161 | otherwise = return ()
1163 -----------------------------------------------------------------------------
1166 foreign import revertCAFs :: IO () -- make it "safe", just in case