1 {-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.121 2002/04/24 09:42: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"
111 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
113 \ Commands available from the prompt:\n\
115 \ <stmt> evaluate/run <stmt>\n\
116 \ :add <filename> ... add module(s) to the current target set\n\
117 \ :browse [*]<module> display the names defined by <module>\n\
118 \ :cd <dir> change directory to <dir>\n\
119 \ :def <cmd> <expr> define a command :<cmd>\n\
120 \ :help, :? display this list of commands\n\
121 \ :info [<name> ...] display information about the given names\n\
122 \ :load <filename> ... load module(s) and their dependents\n\
123 \ :module [+/-] [*]<mod> ... set the context for expression evaluation\n\
124 \ :reload reload the current module set\n\
126 \ :set <option> ... set options\n\
127 \ :set args <arg> ... set the arguments returned by System.getArgs\n\
128 \ :set prog <progname> set the value returned by System.getProgName\n\
130 \ :show modules show the currently loaded modules\n\
131 \ :show bindings show the current bindings made at the prompt\n\
133 \ :type <expr> show the type of <expr>\n\
134 \ :undef <cmd> undefine user-defined command :<cmd>\n\
135 \ :unset <option> ... unset options\n\
137 \ :!<command> run the shell command <command>\n\
139 \ Options for `:set' and `:unset':\n\
141 \ +r revert top-level expressions after each evaluation\n\
142 \ +s print timing/memory stats after each evaluation\n\
143 \ +t print type after evaluation\n\
144 \ -<flags> most GHC command line flags can also be set here\n\
145 \ (eg. -v2, -fglasgow-exts, etc.)\n\
148 interactiveUI :: CmState -> [FilePath] -> [LibrarySpec] -> IO ()
149 interactiveUI cmstate paths cmdline_libs = do
151 hSetBuffering stdout NoBuffering
153 dflags <- getDynFlags
155 -- link in the available packages
156 pkgs <- getPackageInfo
158 linkPackages dflags cmdline_libs pkgs
160 (cmstate, maybe_hval)
161 <- cmCompileExpr cmstate dflags "IO.hSetBuffering IO.stdout IO.NoBuffering Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
163 Just hval -> unsafeCoerce# hval :: IO ()
164 _ -> panic "interactiveUI:buffering"
166 (cmstate, maybe_hval)
167 <- cmCompileExpr cmstate dflags "IO.hFlush IO.stderr"
169 Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ())
170 _ -> panic "interactiveUI:stderr"
172 (cmstate, maybe_hval)
173 <- cmCompileExpr cmstate dflags "IO.hFlush IO.stdout"
175 Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ())
176 _ -> panic "interactiveUI:stdout"
178 -- We don't want the cmd line to buffer any input that might be
179 -- intended for the program, so unbuffer stdin.
180 hSetBuffering stdin NoBuffering
182 -- initial context is just the Prelude
183 cmstate <- cmSetContext cmstate dflags [] ["Prelude"]
185 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
189 startGHCi (runGHCi paths dflags)
190 GHCiState{ progname = "<interactive>",
196 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
197 Readline.resetTerminal Nothing
203 runGHCi :: [FilePath] -> DynFlags -> GHCi ()
204 runGHCi paths dflags = do
205 read_dot_files <- io (readIORef v_Read_DotGHCi)
207 when (read_dot_files) $ do
210 exists <- io (doesFileExist file)
212 dir_ok <- io (checkPerms ".")
213 file_ok <- io (checkPerms file)
214 when (dir_ok && file_ok) $ do
215 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
218 Right hdl -> fileLoop hdl False
220 when (read_dot_files) $ do
221 -- Read in $HOME/.ghci
222 either_dir <- io (IO.try (getEnv "HOME"))
226 cwd <- io (getCurrentDirectory)
227 when (dir /= cwd) $ do
228 let file = dir ++ "/.ghci"
229 ok <- io (checkPerms file)
231 either_hdl <- io (IO.try (openFile file ReadMode))
234 Right hdl -> fileLoop hdl False
236 -- perform a :load for files given on the GHCi command line
237 when (not (null paths)) $
238 ghciHandle showException $
239 loadModule (unwords paths)
241 -- enter the interactive loop
242 is_tty <- io (hIsTerminalDevice stdin)
243 interactiveLoop is_tty
246 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
249 interactiveLoop is_tty = do
250 -- ignore ^C exceptions caught here
251 ghciHandleDyn (\e -> case e of
252 Interrupted -> ghciUnblock (interactiveLoop is_tty)
253 _other -> return ()) $ do
255 -- read commands from stdin
256 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
259 else fileLoop stdin False -- turn off prompt for non-TTY input
265 -- NOTE: We only read .ghci files if they are owned by the current user,
266 -- and aren't world writable. Otherwise, we could be accidentally
267 -- running code planted by a malicious third party.
269 -- Furthermore, We only read ./.ghci if . is owned by the current user
270 -- and isn't writable by anyone else. I think this is sufficient: we
271 -- don't need to check .. and ../.. etc. because "." always refers to
272 -- the same directory while a process is running.
274 checkPerms :: String -> IO Bool
276 #ifdef mingw32_TARGET_OS
279 DriverUtil.handle (\_ -> return False) $ do
280 st <- getFileStatus name
282 if fileOwner st /= me then do
283 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
286 let mode = fileMode st
287 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
288 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
290 putStrLn $ "*** WARNING: " ++ name ++
291 " is writable by someone else, IGNORING!"
296 fileLoop :: Handle -> Bool -> GHCi ()
297 fileLoop hdl prompt = do
298 cmstate <- getCmState
299 (mod,imports) <- io (cmGetContext cmstate)
300 when prompt (io (putStr (mkPrompt mod imports)))
301 l <- io (IO.try (hGetLine hdl))
303 Left e | isEOFError e -> return ()
304 | otherwise -> throw e
306 case remove_spaces l of
307 "" -> fileLoop hdl prompt
308 l -> do quit <- runCommand l
309 if quit then return () else fileLoop hdl prompt
311 stringLoop :: [String] -> GHCi ()
312 stringLoop [] = return ()
313 stringLoop (s:ss) = do
314 case remove_spaces s of
316 l -> do quit <- runCommand l
317 if quit then return () else stringLoop ss
319 mkPrompt toplevs exports
320 = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> "
322 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
323 readlineLoop :: GHCi ()
325 cmstate <- getCmState
326 (mod,imports) <- io (cmGetContext cmstate)
328 l <- io (readline (mkPrompt mod imports))
332 case remove_spaces l of
337 if quit then return () else readlineLoop
340 -- Top level exception handler, just prints out the exception
342 runCommand :: String -> GHCi Bool
344 ghciHandle ( \exception -> do
346 showException exception
351 showException (DynException dyn) =
352 case fromDynamic dyn of
353 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
354 Just Interrupted -> io (putStrLn "Interrupted.")
355 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
356 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
357 Just other_ghc_ex -> io (print other_ghc_ex)
359 showException other_exception
360 = io (putStrLn ("*** Exception: " ++ show other_exception))
362 doCommand (':' : command) = specialCommand command
364 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
367 runStmt :: String -> GHCi [Name]
369 | null (filter (not.isSpace) stmt) = return []
371 = do st <- getGHCiState
372 dflags <- io getDynFlags
373 let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
374 (new_cmstate, result) <-
375 io $ withProgName (progname st) $ withArgs (args st) $
376 cmRunStmt (cmstate st) dflags' stmt
377 setGHCiState st{cmstate = new_cmstate}
379 CmRunFailed -> return []
380 CmRunException e -> showException e >> return []
381 CmRunOk names -> return names
383 -- possibly print the type and revert CAFs after evaluating an expression
385 = do b <- isOptionSet ShowType
386 cmstate <- getCmState
387 when b (mapM_ (showTypeOfName cmstate) names)
389 b <- isOptionSet RevertCAFs
390 io (when b revertCAFs)
394 showTypeOfName :: CmState -> Name -> GHCi ()
395 showTypeOfName cmstate n
396 = do maybe_str <- io (cmTypeOfName cmstate n)
399 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
401 flushEverything :: GHCi ()
403 = io $ do Monad.join (readIORef flush_stdout)
404 Monad.join (readIORef flush_stderr)
407 specialCommand :: String -> GHCi Bool
408 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
409 specialCommand str = do
410 let (cmd,rest) = break isSpace str
411 cmds <- io (readIORef commands)
412 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
413 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
414 ++ shortHelpText) >> return False)
415 [(_,f)] -> f (dropWhile isSpace rest)
416 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
417 " matches multiple commands (" ++
418 foldr1 (\a b -> a ++ ',':b) (map fst cs)
419 ++ ")") >> return False)
421 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
423 -----------------------------------------------------------------------------
426 help :: String -> GHCi ()
427 help _ = io (putStr helpText)
429 info :: String -> GHCi ()
430 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
433 init_cms <- getCmState
434 dflags <- io getDynFlags
436 infoThings cms [] = return cms
437 infoThings cms (name:names) = do
438 (cms, stuff) <- io (cmInfoThing cms dflags name)
439 io (putStrLn (showSDocForUser unqual (
440 vcat (intersperse (text "") (map showThing stuff))))
444 unqual = cmGetPrintUnqual init_cms
446 showThing (ty_thing, fixity)
447 = vcat [ text "-- " <> showTyThing ty_thing,
448 showFixity fixity (getName ty_thing),
449 ppr (ifaceTyThing ty_thing) ]
452 | fix == defaultFixity = empty
453 | otherwise = ppr fix <+>
454 (if isSymOcc (nameOccName name)
456 else char '`' <> ppr name <> char '`')
458 showTyThing (AClass cl)
459 = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
460 showTyThing (ATyCon ty)
462 = hcat [ppr ty, text " is a primitive type constructor"]
464 = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
465 showTyThing (AnId id)
466 = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
469 | isRecordSelector id =
470 case tyConClass_maybe (fieldLabelTyCon (
471 recordSelectorFieldLabel id)) of
472 Nothing -> text "record selector"
473 Just c -> text "method in class " <> ppr c
474 | isDataConWrapId id = text "data constructor"
475 | otherwise = text "variable"
477 -- also print out the source location for home things
479 | isHomePackageName name && isGoodSrcLoc loc
480 = hsep [ text ", defined at", ppr loc ]
483 where loc = nameSrcLoc name
485 cms <- infoThings init_cms names
489 addModule :: String -> GHCi ()
491 let files = words str
492 state <- getGHCiState
493 dflags <- io (getDynFlags)
494 io (revertCAFs) -- always revert CAFs on load/add.
495 let new_targets = files ++ targets state
496 graph <- io (cmDepAnal (cmstate state) dflags new_targets)
497 (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph)
498 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
499 setContextAfterLoad mods
500 modulesLoadedMsg ok mods dflags
502 changeDirectory :: String -> GHCi ()
503 changeDirectory ('~':d) = do
504 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
505 io (setCurrentDirectory (tilde ++ '/':d))
506 changeDirectory d = io (setCurrentDirectory d)
508 defineMacro :: String -> GHCi ()
510 let (macro_name, definition) = break isSpace s
511 cmds <- io (readIORef commands)
513 then throwDyn (CmdLineError "invalid macro name")
515 if (macro_name `elem` map fst cmds)
516 then throwDyn (CmdLineError
517 ("command `" ++ macro_name ++ "' is already defined"))
520 -- give the expression a type signature, so we can be sure we're getting
521 -- something of the right type.
522 let new_expr = '(' : definition ++ ") :: String -> IO String"
524 -- compile the expression
526 dflags <- io getDynFlags
527 (new_cmstate, maybe_hv) <- io (cmCompileExpr cms dflags new_expr)
528 setCmState new_cmstate
531 Just hv -> io (writeIORef commands --
532 ((macro_name, keepGoing (runMacro hv)) : cmds))
534 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
536 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
537 stringLoop (lines str)
539 undefineMacro :: String -> GHCi ()
540 undefineMacro macro_name = do
541 cmds <- io (readIORef commands)
542 if (macro_name `elem` map fst builtin_commands)
543 then throwDyn (CmdLineError
544 ("command `" ++ macro_name ++ "' cannot be undefined"))
546 if (macro_name `notElem` map fst cmds)
547 then throwDyn (CmdLineError
548 ("command `" ++ macro_name ++ "' not defined"))
550 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
553 loadModule :: String -> GHCi ()
554 loadModule str = timeIt (loadModule' str)
557 let files = words str
558 state <- getGHCiState
559 dflags <- io getDynFlags
561 -- do the dependency anal first, so that if it fails we don't throw
562 -- away the current set of modules.
563 graph <- io (cmDepAnal (cmstate state) dflags files)
565 -- Dependency anal ok, now unload everything
566 cmstate1 <- io (cmUnload (cmstate state) dflags)
567 setGHCiState state{ cmstate = cmstate1, targets = [] }
569 io (revertCAFs) -- always revert CAFs on load.
570 (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 dflags graph)
571 setGHCiState state{ cmstate = cmstate2, targets = files }
573 setContextAfterLoad mods
574 modulesLoadedMsg ok mods dflags
577 reloadModule :: String -> GHCi ()
579 state <- getGHCiState
580 dflags <- io getDynFlags
581 case targets state of
582 [] -> io (putStr "no current target\n")
584 -- do the dependency anal first, so that if it fails we don't throw
585 -- away the current set of modules.
586 graph <- io (cmDepAnal (cmstate state) dflags paths)
588 io (revertCAFs) -- always revert CAFs on reload.
590 <- io (cmLoadModules (cmstate state) dflags graph)
591 setGHCiState state{ cmstate=cmstate1 }
592 setContextAfterLoad mods
593 modulesLoadedMsg ok mods dflags
595 reloadModule _ = noArgs ":reload"
597 setContextAfterLoad [] = setContext prel
598 setContextAfterLoad (m:_) = do
599 cmstate <- getCmState
600 b <- io (cmModuleIsInterpreted cmstate m)
601 if b then setContext ('*':m) else setContext m
603 modulesLoadedMsg ok mods dflags =
604 when (verbosity dflags > 0) $ do
606 | null mods = text "none."
608 punctuate comma (map text mods)) <> text "."
611 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
613 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
616 typeOfExpr :: String -> GHCi ()
618 = do cms <- getCmState
619 dflags <- io getDynFlags
620 (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr cms dflags str)
621 setCmState new_cmstate
624 Just tystr -> io (putStrLn tystr)
626 quit :: String -> GHCi Bool
629 shellEscape :: String -> GHCi Bool
630 shellEscape str = io (system str >> return False)
632 -----------------------------------------------------------------------------
633 -- Browing a module's contents
635 browseCmd :: String -> GHCi ()
638 ['*':m] | looksLikeModuleName m -> browseModule m False
639 [m] | looksLikeModuleName m -> browseModule m True
640 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
642 browseModule m exports_only = do
644 dflags <- io getDynFlags
646 is_interpreted <- io (cmModuleIsInterpreted cms m)
647 when (not is_interpreted && not exports_only) $
648 throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
650 -- temporarily set the context to the module we're interested in,
651 -- just so we can get an appropriate PrintUnqualified
652 (as,bs) <- io (cmGetContext cms)
653 cms1 <- io (if exports_only then cmSetContext cms dflags [] [prel,m]
654 else cmSetContext cms dflags [m] [])
655 cms2 <- io (cmSetContext cms1 dflags as bs)
657 (cms3, things) <- io (cmBrowseModule cms2 dflags m exports_only)
661 let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
663 things' = filter wantToSee things
665 wantToSee (AnId id) = not (isDataConId id || isDataConWrapId id)
668 thing_names = map getName things
670 thingDecl thing@(AnId id) = ifaceTyThing thing
672 thingDecl thing@(AClass c) =
673 let rn_decl = ifaceTyThing thing in
675 ClassDecl { tcdSigs = cons } ->
676 rn_decl{ tcdSigs = filter methodIsVisible cons }
679 methodIsVisible (ClassOpSig n _ _ _) = n `elem` thing_names
681 thingDecl thing@(ATyCon t) =
682 let rn_decl = ifaceTyThing thing in
684 TyData { tcdCons = DataCons cons } ->
685 rn_decl{ tcdCons = DataCons (filter conIsVisible cons) }
688 conIsVisible (ConDecl n _ _ _ _ _) = n `elem` thing_names
690 io (putStrLn (showSDocForUser unqual (
691 vcat (map (ppr . thingDecl) things')))
696 -----------------------------------------------------------------------------
697 -- Setting the module context
700 | all sensible mods = fn mods
701 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
703 (fn, mods) = case str of
704 '+':stuff -> (addToContext, words stuff)
705 '-':stuff -> (removeFromContext, words stuff)
706 stuff -> (newContext, words stuff)
708 sensible ('*':m) = looksLikeModuleName m
709 sensible m = looksLikeModuleName m
713 dflags <- io getDynFlags
714 (as,bs) <- separate cms mods [] []
715 let bs' = if null as && prel `notElem` bs then prel:bs else bs
716 cms' <- io (cmSetContext cms dflags as bs')
719 separate cmstate [] as bs = return (as,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"))
724 separate cmstate (m:ms) as bs = separate cmstate ms as (m:bs)
729 addToContext mods = do
731 dflags <- io getDynFlags
732 (as,bs) <- io (cmGetContext cms)
734 (as',bs') <- separate cms mods [] []
736 let as_to_add = as' \\ (as ++ bs)
737 bs_to_add = bs' \\ (as ++ bs)
739 cms' <- io (cmSetContext cms dflags
740 (as ++ as_to_add) (bs ++ bs_to_add))
744 removeFromContext mods = do
746 dflags <- io getDynFlags
747 (as,bs) <- io (cmGetContext cms)
749 (as_to_remove,bs_to_remove) <- separate cms mods [] []
751 let as' = as \\ (as_to_remove ++ bs_to_remove)
752 bs' = bs \\ (as_to_remove ++ bs_to_remove)
754 cms' <- io (cmSetContext cms dflags as' bs')
757 ----------------------------------------------------------------------------
760 -- set options in the interpreter. Syntax is exactly the same as the
761 -- ghc command line, except that certain options aren't available (-C,
764 -- This is pretty fragile: most options won't work as expected. ToDo:
765 -- figure out which ones & disallow them.
767 setCmd :: String -> GHCi ()
769 = do st <- getGHCiState
770 let opts = options st
771 io $ putStrLn (showSDoc (
772 text "options currently set: " <>
775 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
779 ("args":args) -> setArgs args
780 ("prog":prog) -> setProg prog
781 wds -> setOptions wds
785 setGHCiState st{ args = args }
789 setGHCiState st{ progname = prog }
791 io (hPutStrLn stderr "syntax: :set prog <progname>")
794 do -- first, deal with the GHCi opts (+s, +t, etc.)
795 let (plus_opts, minus_opts) = partition isPlus wds
796 mapM setOpt plus_opts
798 -- now, the GHC flags
799 pkgs_before <- io (readIORef v_Packages)
800 leftovers <- io (processArgs static_flags minus_opts [])
801 pkgs_after <- io (readIORef v_Packages)
803 -- update things if the users wants more packages
804 when (pkgs_before /= pkgs_after) $
805 newPackages (pkgs_after \\ pkgs_before)
807 -- then, dynamic flags
810 leftovers <- processArgs dynamic_flags leftovers []
813 if (not (null leftovers))
814 then throwDyn (CmdLineError ("unrecognised flags: " ++
819 unsetOptions :: String -> GHCi ()
821 = do -- first, deal with the GHCi opts (+s, +t, etc.)
823 (minus_opts, rest1) = partition isMinus opts
824 (plus_opts, rest2) = partition isPlus rest1
826 if (not (null rest2))
827 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
830 mapM unsetOpt plus_opts
832 -- can't do GHC flags for now
833 if (not (null minus_opts))
834 then throwDyn (CmdLineError "can't unset GHC command-line flags")
837 isMinus ('-':s) = True
840 isPlus ('+':s) = True
844 = case strToGHCiOpt str of
845 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
846 Just o -> setOption o
849 = case strToGHCiOpt str of
850 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
851 Just o -> unsetOption o
853 strToGHCiOpt :: String -> (Maybe GHCiOption)
854 strToGHCiOpt "s" = Just ShowTiming
855 strToGHCiOpt "t" = Just ShowType
856 strToGHCiOpt "r" = Just RevertCAFs
857 strToGHCiOpt _ = Nothing
859 optToStr :: GHCiOption -> String
860 optToStr ShowTiming = "s"
861 optToStr ShowType = "t"
862 optToStr RevertCAFs = "r"
864 newPackages new_pkgs = do
865 state <- getGHCiState
866 dflags <- io getDynFlags
867 cmstate1 <- io (cmUnload (cmstate state) dflags)
868 setGHCiState state{ cmstate = cmstate1, targets = [] }
871 pkgs <- getPackageInfo
872 flushPackageCache pkgs
874 new_pkg_info <- getPackageDetails new_pkgs
875 mapM_ (linkPackage dflags) (reverse new_pkg_info)
877 -----------------------------------------------------------------------------
882 ["modules" ] -> showModules
883 ["bindings"] -> showBindings
884 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
888 let mg = cmGetModuleGraph cms
889 ls = cmGetLinkables cms
890 maybe_linkables = map (findModuleLinkable_maybe ls)
891 (map (moduleName.ms_mod) mg)
892 zipWithM showModule mg maybe_linkables
895 showModule :: ModSummary -> Maybe Linkable -> GHCi ()
896 showModule m (Just l) = do
897 io (putStrLn (showModMsg (isObjectLinkable l) (ms_mod m) (ms_location m)))
898 showModule _ Nothing = panic "missing linkable"
903 unqual = cmGetPrintUnqual cms
904 showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
906 io (mapM showBinding (cmGetBindings cms))
909 -----------------------------------------------------------------------------
912 data GHCiState = GHCiState
916 targets :: [FilePath],
918 options :: [GHCiOption]
922 = ShowTiming -- show time/allocs after evaluation
923 | ShowType -- show the type of expressions
924 | RevertCAFs -- revert CAFs after every evaluation
927 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
928 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
930 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
932 startGHCi :: GHCi a -> GHCiState -> IO a
933 startGHCi g state = do ref <- newIORef state; unGHCi g ref
935 instance Monad GHCi where
936 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
937 return a = GHCi $ \s -> return a
939 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
940 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
941 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
943 getGHCiState = GHCi $ \r -> readIORef r
944 setGHCiState s = GHCi $ \r -> writeIORef r s
946 -- for convenience...
947 getCmState = getGHCiState >>= return . cmstate
948 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
950 isOptionSet :: GHCiOption -> GHCi Bool
952 = do st <- getGHCiState
953 return (opt `elem` options st)
955 setOption :: GHCiOption -> GHCi ()
957 = do st <- getGHCiState
958 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
960 unsetOption :: GHCiOption -> GHCi ()
962 = do st <- getGHCiState
963 setGHCiState (st{ options = filter (/= opt) (options st) })
966 io m = GHCi { unGHCi = \s -> m >>= return }
968 -----------------------------------------------------------------------------
969 -- recursive exception handlers
971 -- Don't forget to unblock async exceptions in the handler, or if we're
972 -- in an exception loop (eg. let a = error a in a) the ^C exception
973 -- may never be delivered. Thanks to Marcin for pointing out the bug.
975 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
976 ghciHandle h (GHCi m) = GHCi $ \s ->
977 Exception.catch (m s)
978 (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
980 ghciUnblock :: GHCi a -> GHCi a
981 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
983 -----------------------------------------------------------------------------
986 -- Left: full path name of a .o file, including trailing .o
987 -- Right: "unadorned" name of a .DLL/.so
988 -- e.g. On unix "qt" denotes "libqt.so"
989 -- On WinDoze "burble" denotes "burble.DLL"
990 -- addDLL is platform-specific and adds the lib/.so/.DLL
991 -- suffixes platform-dependently; we don't do that here.
993 -- For dynamic objects only, try to find the object file in all the
994 -- directories specified in v_Library_Paths before giving up.
997 = Either FilePath String
999 showLS (Left nm) = "(static) " ++ nm
1000 showLS (Right nm) = "(dynamic) " ++ nm
1002 linkPackages :: DynFlags -> [LibrarySpec] -> [PackageConfig] -> IO ()
1003 linkPackages dflags cmdline_lib_specs pkgs
1004 = do mapM_ (linkPackage dflags) (reverse pkgs)
1005 lib_paths <- readIORef v_Library_paths
1006 mapM_ (preloadLib dflags lib_paths) cmdline_lib_specs
1007 if (null cmdline_lib_specs)
1009 else do maybePutStr dflags "final link ... "
1011 if ok then maybePutStrLn dflags "done."
1012 else throwDyn (InstallationError
1013 "linking extra libraries/objects failed")
1015 preloadLib :: DynFlags -> [String] -> LibrarySpec -> IO ()
1016 preloadLib dflags lib_paths lib_spec
1017 = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
1020 -> do b <- preload_static lib_paths static_ish
1021 maybePutStrLn dflags (if b then "done."
1024 -> -- We add "" to the set of paths to try, so that
1025 -- if none of the real paths match, we force addDLL
1026 -- to look in the default dynamic-link search paths.
1027 do maybe_errstr <- preload_dynamic (lib_paths++[""])
1029 case maybe_errstr of
1030 Nothing -> return ()
1031 Just mm -> preloadFailed mm lib_paths lib_spec
1032 maybePutStrLn dflags "done"
1034 preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
1035 preloadFailed sys_errmsg paths spec
1036 = do maybePutStr dflags
1037 ("failed.\nDynamic linker error message was:\n "
1038 ++ sys_errmsg ++ "\nWhilst trying to load: "
1039 ++ showLS spec ++ "\nDirectories to search are:\n"
1040 ++ unlines (map (" "++) paths) )
1043 -- not interested in the paths in the static case.
1044 preload_static paths name
1045 = do b <- doesFileExist name
1046 if not b then return False
1047 else loadObj name >> return True
1049 -- return Nothing == success, else Just error message from addDLL
1050 preload_dynamic [] name
1052 preload_dynamic (path:paths) rootname
1053 = do -- addDLL returns NULL on success
1054 maybe_errmsg <- addDLL path rootname
1055 if maybe_errmsg == nullPtr
1056 then preload_dynamic paths rootname
1057 else do str <- peekCString maybe_errmsg
1061 = (throwDyn . CmdLineError)
1062 "user specified .o/.so/.DLL could not be loaded."
1064 -- Packages that don't need loading, because the compiler shares them with
1065 -- the interpreted program.
1066 dont_load_these = [ "rts" ]
1068 -- Packages that are already linked into GHCi. For mingw32, we only
1069 -- skip gmp and rts, since std and after need to load the msvcrt.dll
1070 -- library which std depends on.
1072 # ifndef mingw32_TARGET_OS
1073 = [ "std", "concurrent", "posix", "text", "util" ]
1078 linkPackage :: DynFlags -> PackageConfig -> IO ()
1079 linkPackage dflags pkg
1080 | name pkg `elem` dont_load_these = return ()
1083 -- For each obj, try obj.o and if that fails, obj.so.
1084 -- Complication: all the .so's must be loaded before any of the .o's.
1085 let dirs = library_dirs pkg
1086 let objs = hs_libraries pkg ++ extra_libraries pkg
1087 classifieds <- mapM (locateOneObj dirs) objs
1089 -- Don't load the .so libs if this is a package GHCi is already
1090 -- linked against, because we'll already have the .so linked in.
1091 let (so_libs, obj_libs) = partition isRight classifieds
1092 let sos_first | name pkg `elem` loaded_in_ghci = obj_libs
1093 | otherwise = so_libs ++ obj_libs
1095 maybePutStr dflags ("Loading package " ++ name pkg ++ " ... ")
1096 mapM loadClassified sos_first
1097 maybePutStr dflags "linking ... "
1099 if ok then maybePutStrLn dflags "done."
1100 else panic ("can't load package `" ++ name pkg ++ "'")
1102 isRight (Right _) = True
1103 isRight (Left _) = False
1105 loadClassified :: LibrarySpec -> IO ()
1106 loadClassified (Left obj_absolute_filename)
1107 = do loadObj obj_absolute_filename
1108 loadClassified (Right dll_unadorned)
1109 = do maybe_errmsg <- addDLL "" dll_unadorned -- doesn't seem right to me
1110 if maybe_errmsg == nullPtr
1112 else do str <- peekCString maybe_errmsg
1113 throwDyn (CmdLineError ("can't load .so/.DLL for: "
1114 ++ dll_unadorned ++ " (" ++ str ++ ")" ))
1116 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
1118 = return (Right obj) -- we assume
1119 locateOneObj (d:ds) obj
1120 = do let path = d ++ '/':obj ++ ".o"
1121 b <- doesFileExist path
1122 if b then return (Left path) else locateOneObj ds obj
1124 -----------------------------------------------------------------------------
1125 -- timing & statistics
1127 timeIt :: GHCi a -> GHCi a
1129 = do b <- isOptionSet ShowTiming
1132 else do allocs1 <- io $ getAllocations
1133 time1 <- io $ getCPUTime
1135 allocs2 <- io $ getAllocations
1136 time2 <- io $ getCPUTime
1137 io $ printTimes (allocs2 - allocs1) (time2 - time1)
1140 foreign import "getAllocations" getAllocations :: IO Int
1142 printTimes :: Int -> Integer -> IO ()
1143 printTimes allocs psecs
1144 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1145 secs_str = showFFloat (Just 2) secs
1146 putStrLn (showSDoc (
1147 parens (text (secs_str "") <+> text "secs" <> comma <+>
1148 int allocs <+> text "bytes")))
1150 -----------------------------------------------------------------------------
1153 looksLikeModuleName [] = False
1154 looksLikeModuleName (c:cs) = isUpper c && all isAlphaNumEx cs
1156 isAlphaNumEx c = isAlphaNum c || c == '_' || c == '.'
1158 maybePutStr dflags s | verbosity dflags > 0 = putStr s
1159 | otherwise = return ()
1161 maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
1162 | otherwise = return ()
1164 -----------------------------------------------------------------------------
1167 foreign import revertCAFs :: IO () -- make it "safe", just in case