1 {-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.129 2002/07/17 13:49:15 simonmar Exp $
5 -- GHC Interactive User Interface
7 -- (c) The GHC Team 2000
9 -----------------------------------------------------------------------------
10 module InteractiveUI (
11 interactiveUI, -- :: CmState -> [FilePath] -> [LibrarySpec] -> IO ()
16 #include "../includes/config.h"
17 #include "HsVersions.h"
22 import CmTypes ( Linkable, isObjectLinkable, ModSummary(..) )
23 import CmLink ( findModuleLinkable_maybe )
25 import HscTypes ( TyThing(..), showModMsg, InteractiveContext(..) )
26 import HsSyn ( TyClDecl(..), ConDecl(..), Sig(..) )
27 import MkIface ( ifaceTyThing )
30 import DriverUtil ( handle, remove_spaces )
32 import Finder ( flushPackageCache )
34 import Id ( isRecordSelector, recordSelectorFieldLabel,
35 isDataConWrapId, isDataConId, idName )
36 import Class ( className )
37 import TyCon ( tyConName, tyConClass_maybe, isPrimTyCon, DataConDetails(..) )
38 import FieldLabel ( fieldLabelTyCon )
39 import SrcLoc ( isGoodSrcLoc )
40 import Module ( moduleName )
41 import NameEnv ( nameEnvElts )
42 import Name ( Name, isHomePackageName, nameSrcLoc, nameOccName,
44 import OccName ( isSymOcc )
45 import BasicTypes ( defaultFixity )
47 import CmdLineOpts ( DynFlag(..), DynFlags(..), getDynFlags, saveDynFlags,
48 restoreDynFlags, dopt_unset )
49 import Panic ( GhcException(..), showGhcException )
52 #ifndef mingw32_TARGET_OS
58 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
74 import GlaExts ( unsafeCoerce# )
76 import Foreign ( nullPtr )
77 import CString ( CString, peekCString, withCString )
79 -----------------------------------------------------------------------------
83 \ / _ \\ /\\ /\\/ __(_)\n\
84 \ / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n\
85 \/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n\
86 \\\____/\\/ /_/\\____/|_| Type :? for help.\n"
88 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
90 builtin_commands :: [(String, String -> GHCi Bool)]
92 ("add", keepGoing addModule),
93 ("browse", keepGoing browseCmd),
94 ("cd", keepGoing changeDirectory),
95 ("def", keepGoing defineMacro),
96 ("help", keepGoing help),
97 ("?", keepGoing help),
98 ("info", keepGoing info),
99 ("load", keepGoing loadModule),
100 ("module", keepGoing setContext),
101 ("reload", keepGoing reloadModule),
102 ("set", keepGoing setCmd),
103 ("show", keepGoing showCmd),
104 ("type", keepGoing typeOfExpr),
105 ("unset", keepGoing unsetOptions),
106 ("undef", keepGoing undefineMacro),
110 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
111 keepGoing a str = a str >> return False
113 shortHelpText = "use :? for help.\n"
115 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
117 \ Commands available from the prompt:\n\
119 \ <stmt> evaluate/run <stmt>\n\
120 \ :add <filename> ... add module(s) to the current target set\n\
121 \ :browse [*]<module> display the names defined by <module>\n\
122 \ :cd <dir> change directory to <dir>\n\
123 \ :def <cmd> <expr> define a command :<cmd>\n\
124 \ :help, :? display this list of commands\n\
125 \ :info [<name> ...] display information about the given names\n\
126 \ :load <filename> ... load module(s) and their dependents\n\
127 \ :module [+/-] [*]<mod> ... set the context for expression evaluation\n\
128 \ :reload reload the current module set\n\
130 \ :set <option> ... set options\n\
131 \ :set args <arg> ... set the arguments returned by System.getArgs\n\
132 \ :set prog <progname> set the value returned by System.getProgName\n\
134 \ :show modules show the currently loaded modules\n\
135 \ :show bindings show the current bindings made at the prompt\n\
137 \ :type <expr> show the type of <expr>\n\
138 \ :undef <cmd> undefine user-defined command :<cmd>\n\
139 \ :unset <option> ... unset options\n\
141 \ :!<command> run the shell command <command>\n\
143 \ Options for `:set' and `:unset':\n\
145 \ +r revert top-level expressions after each evaluation\n\
146 \ +s print timing/memory stats after each evaluation\n\
147 \ +t print type after evaluation\n\
148 \ -<flags> most GHC command line flags can also be set here\n\
149 \ (eg. -v2, -fglasgow-exts, etc.)\n\
152 interactiveUI :: CmState -> [FilePath] -> [LibrarySpec] -> IO ()
153 interactiveUI cmstate paths cmdline_libs = do
155 hSetBuffering stdout NoBuffering
157 dflags <- getDynFlags
159 -- link in the available packages
160 pkgs <- getPackageInfo
162 linkPackages dflags cmdline_libs pkgs
164 (cmstate, maybe_hval)
165 <- cmCompileExpr cmstate dflags "IO.hSetBuffering IO.stdout IO.NoBuffering Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
167 Just hval -> unsafeCoerce# hval :: IO ()
168 _ -> panic "interactiveUI:buffering"
170 (cmstate, maybe_hval)
171 <- cmCompileExpr cmstate dflags "IO.hFlush IO.stderr"
173 Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ())
174 _ -> panic "interactiveUI:stderr"
176 (cmstate, maybe_hval)
177 <- cmCompileExpr cmstate dflags "IO.hFlush IO.stdout"
179 Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ())
180 _ -> panic "interactiveUI:stdout"
182 -- We don't want the cmd line to buffer any input that might be
183 -- intended for the program, so unbuffer stdin.
184 hSetBuffering stdin NoBuffering
186 -- initial context is just the Prelude
187 cmstate <- cmSetContext cmstate dflags [] ["Prelude"]
189 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
193 startGHCi (runGHCi paths dflags)
194 GHCiState{ progname = "<interactive>",
200 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
201 Readline.resetTerminal Nothing
207 runGHCi :: [FilePath] -> DynFlags -> GHCi ()
208 runGHCi paths dflags = do
209 read_dot_files <- io (readIORef v_Read_DotGHCi)
211 when (read_dot_files) $ do
214 exists <- io (doesFileExist file)
216 dir_ok <- io (checkPerms ".")
217 file_ok <- io (checkPerms file)
218 when (dir_ok && file_ok) $ do
219 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
222 Right hdl -> fileLoop hdl False
224 when (read_dot_files) $ do
225 -- Read in $HOME/.ghci
226 either_dir <- io (IO.try (getEnv "HOME"))
230 cwd <- io (getCurrentDirectory)
231 when (dir /= cwd) $ do
232 let file = dir ++ "/.ghci"
233 ok <- io (checkPerms file)
235 either_hdl <- io (IO.try (openFile file ReadMode))
238 Right hdl -> fileLoop hdl False
240 -- perform a :load for files given on the GHCi command line
241 when (not (null paths)) $
242 ghciHandle showException $
243 loadModule (unwords paths)
245 -- enter the interactive loop
246 is_tty <- io (hIsTerminalDevice stdin)
247 interactiveLoop is_tty
250 io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
253 interactiveLoop is_tty = do
254 -- ignore ^C exceptions caught here
255 ghciHandleDyn (\e -> case e of
256 Interrupted -> ghciUnblock (interactiveLoop is_tty)
257 _other -> return ()) $ do
259 -- read commands from stdin
260 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
263 else fileLoop stdin False -- turn off prompt for non-TTY input
265 fileLoop stdin is_tty
269 -- NOTE: We only read .ghci files if they are owned by the current user,
270 -- and aren't world writable. Otherwise, we could be accidentally
271 -- running code planted by a malicious third party.
273 -- Furthermore, We only read ./.ghci if . is owned by the current user
274 -- and isn't writable by anyone else. I think this is sufficient: we
275 -- don't need to check .. and ../.. etc. because "." always refers to
276 -- the same directory while a process is running.
278 checkPerms :: String -> IO Bool
280 #ifdef mingw32_TARGET_OS
283 DriverUtil.handle (\_ -> return False) $ do
284 st <- getFileStatus name
286 if fileOwner st /= me then do
287 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
290 let mode = fileMode st
291 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
292 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
294 putStrLn $ "*** WARNING: " ++ name ++
295 " is writable by someone else, IGNORING!"
300 fileLoop :: Handle -> Bool -> GHCi ()
301 fileLoop hdl prompt = do
302 cmstate <- getCmState
303 (mod,imports) <- io (cmGetContext cmstate)
304 when prompt (io (putStr (mkPrompt mod imports)))
305 l <- io (IO.try (hGetLine hdl))
307 Left e | isEOFError e -> return ()
308 | otherwise -> throw e
310 case remove_spaces l of
311 "" -> fileLoop hdl prompt
312 l -> do quit <- runCommand l
313 if quit then return () else fileLoop hdl prompt
315 stringLoop :: [String] -> GHCi ()
316 stringLoop [] = return ()
317 stringLoop (s:ss) = do
318 case remove_spaces s of
320 l -> do quit <- runCommand l
321 if quit then return () else stringLoop ss
323 mkPrompt toplevs exports
324 = concat (intersperse " " (map ('*':) toplevs ++ exports)) ++ "> "
326 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
327 readlineLoop :: GHCi ()
329 cmstate <- getCmState
330 (mod,imports) <- io (cmGetContext cmstate)
332 l <- io (readline (mkPrompt mod imports))
336 case remove_spaces l of
341 if quit then return () else readlineLoop
344 -- Top level exception handler, just prints out the exception
346 runCommand :: String -> GHCi Bool
348 ghciHandle ( \exception -> do
350 showException exception
355 showException (DynException dyn) =
356 case fromDynamic dyn of
357 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
358 Just Interrupted -> io (putStrLn "Interrupted.")
359 Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
360 Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
361 Just other_ghc_ex -> io (print other_ghc_ex)
363 showException other_exception
364 = io (putStrLn ("*** Exception: " ++ show other_exception))
366 doCommand (':' : command) = specialCommand command
368 = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
371 runStmt :: String -> GHCi [Name]
373 | null (filter (not.isSpace) stmt) = return []
375 = do st <- getGHCiState
376 dflags <- io getDynFlags
377 let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
378 (new_cmstate, result) <-
379 io $ withProgName (progname st) $ withArgs (args st) $
380 cmRunStmt (cmstate st) dflags' stmt
381 setGHCiState st{cmstate = new_cmstate}
383 CmRunFailed -> return []
384 CmRunException e -> showException e >> return []
385 CmRunOk names -> return names
387 -- possibly print the type and revert CAFs after evaluating an expression
389 = do b <- isOptionSet ShowType
390 cmstate <- getCmState
391 when b (mapM_ (showTypeOfName cmstate) names)
393 b <- isOptionSet RevertCAFs
394 io (when b revertCAFs)
398 showTypeOfName :: CmState -> Name -> GHCi ()
399 showTypeOfName cmstate n
400 = do maybe_str <- io (cmTypeOfName cmstate n)
403 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
405 flushEverything :: GHCi ()
407 = io $ do Monad.join (readIORef flush_stdout)
408 Monad.join (readIORef flush_stderr)
411 specialCommand :: String -> GHCi Bool
412 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
413 specialCommand str = do
414 let (cmd,rest) = break isSpace str
415 cmds <- io (readIORef commands)
416 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
417 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
418 ++ shortHelpText) >> return False)
419 [(_,f)] -> f (dropWhile isSpace rest)
420 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
421 " matches multiple commands (" ++
422 foldr1 (\a b -> a ++ ',':b) (map fst cs)
423 ++ ")") >> return False)
425 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
427 -----------------------------------------------------------------------------
430 help :: String -> GHCi ()
431 help _ = io (putStr helpText)
433 info :: String -> GHCi ()
434 info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'")
437 init_cms <- getCmState
438 dflags <- io getDynFlags
440 infoThings cms [] = return cms
441 infoThings cms (name:names) = do
442 (cms, stuff) <- io (cmInfoThing cms dflags name)
443 io (putStrLn (showSDocForUser unqual (
444 vcat (intersperse (text "") (map showThing stuff))))
448 unqual = cmGetPrintUnqual init_cms
450 showThing (ty_thing, fixity)
451 = vcat [ text "-- " <> showTyThing ty_thing,
452 showFixity fixity (getName ty_thing),
453 ppr (ifaceTyThing ty_thing) ]
456 | fix == defaultFixity = empty
457 | otherwise = ppr fix <+>
458 (if isSymOcc (nameOccName name)
460 else char '`' <> ppr name <> char '`')
462 showTyThing (AClass cl)
463 = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
464 showTyThing (ATyCon ty)
466 = hcat [ppr ty, text " is a primitive type constructor"]
468 = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)]
469 showTyThing (AnId id)
470 = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
473 | isRecordSelector id =
474 case tyConClass_maybe (fieldLabelTyCon (
475 recordSelectorFieldLabel id)) of
476 Nothing -> text "record selector"
477 Just c -> text "method in class " <> ppr c
478 | isDataConWrapId id = text "data constructor"
479 | otherwise = text "variable"
481 -- also print out the source location for home things
483 | isHomePackageName name && isGoodSrcLoc loc
484 = hsep [ text ", defined at", ppr loc ]
487 where loc = nameSrcLoc name
489 cms <- infoThings init_cms names
493 addModule :: String -> GHCi ()
495 let files = words str
496 state <- getGHCiState
497 dflags <- io (getDynFlags)
498 io (revertCAFs) -- always revert CAFs on load/add.
499 let new_targets = files ++ targets state
500 graph <- io (cmDepAnal (cmstate state) dflags new_targets)
501 (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph)
502 setGHCiState state{ cmstate = cmstate1, targets = new_targets }
503 setContextAfterLoad mods
504 modulesLoadedMsg ok mods dflags
506 changeDirectory :: String -> GHCi ()
507 changeDirectory ('~':d) = do
508 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
509 io (setCurrentDirectory (tilde ++ '/':d))
510 changeDirectory d = io (setCurrentDirectory d)
512 defineMacro :: String -> GHCi ()
514 let (macro_name, definition) = break isSpace s
515 cmds <- io (readIORef commands)
517 then throwDyn (CmdLineError "invalid macro name")
519 if (macro_name `elem` map fst cmds)
520 then throwDyn (CmdLineError
521 ("command `" ++ macro_name ++ "' is already defined"))
524 -- give the expression a type signature, so we can be sure we're getting
525 -- something of the right type.
526 let new_expr = '(' : definition ++ ") :: String -> IO String"
528 -- compile the expression
530 dflags <- io getDynFlags
531 (new_cmstate, maybe_hv) <- io (cmCompileExpr cms dflags new_expr)
532 setCmState new_cmstate
535 Just hv -> io (writeIORef commands --
536 ((macro_name, keepGoing (runMacro hv)) : cmds))
538 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
540 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
541 stringLoop (lines str)
543 undefineMacro :: String -> GHCi ()
544 undefineMacro macro_name = do
545 cmds <- io (readIORef commands)
546 if (macro_name `elem` map fst builtin_commands)
547 then throwDyn (CmdLineError
548 ("command `" ++ macro_name ++ "' cannot be undefined"))
550 if (macro_name `notElem` map fst cmds)
551 then throwDyn (CmdLineError
552 ("command `" ++ macro_name ++ "' not defined"))
554 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
557 loadModule :: String -> GHCi ()
558 loadModule str = timeIt (loadModule' str)
561 let files = words str
562 state <- getGHCiState
563 dflags <- io getDynFlags
565 -- do the dependency anal first, so that if it fails we don't throw
566 -- away the current set of modules.
567 graph <- io (cmDepAnal (cmstate state) dflags files)
569 -- Dependency anal ok, now unload everything
570 cmstate1 <- io (cmUnload (cmstate state) dflags)
571 setGHCiState state{ cmstate = cmstate1, targets = [] }
573 io (revertCAFs) -- always revert CAFs on load.
574 (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 dflags graph)
575 setGHCiState state{ cmstate = cmstate2, targets = files }
577 setContextAfterLoad mods
578 modulesLoadedMsg ok mods dflags
581 reloadModule :: String -> GHCi ()
583 state <- getGHCiState
584 dflags <- io getDynFlags
585 case targets state of
586 [] -> io (putStr "no current target\n")
588 -- do the dependency anal first, so that if it fails we don't throw
589 -- away the current set of modules.
590 graph <- io (cmDepAnal (cmstate state) dflags paths)
592 io (revertCAFs) -- always revert CAFs on reload.
594 <- io (cmLoadModules (cmstate state) dflags graph)
595 setGHCiState state{ cmstate=cmstate1 }
596 setContextAfterLoad mods
597 modulesLoadedMsg ok mods dflags
599 reloadModule _ = noArgs ":reload"
601 setContextAfterLoad [] = setContext prel
602 setContextAfterLoad (m:_) = do
603 cmstate <- getCmState
604 b <- io (cmModuleIsInterpreted cmstate m)
605 if b then setContext ('*':m) else setContext m
607 modulesLoadedMsg ok mods dflags =
608 when (verbosity dflags > 0) $ do
610 | null mods = text "none."
612 punctuate comma (map text mods)) <> text "."
615 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
617 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
620 typeOfExpr :: String -> GHCi ()
622 = do cms <- getCmState
623 dflags <- io getDynFlags
624 (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr cms dflags str)
625 setCmState new_cmstate
628 Just tystr -> io (putStrLn tystr)
630 quit :: String -> GHCi Bool
633 shellEscape :: String -> GHCi Bool
634 shellEscape str = io (system str >> return False)
636 -----------------------------------------------------------------------------
637 -- Browing a module's contents
639 browseCmd :: String -> GHCi ()
642 ['*':m] | looksLikeModuleName m -> browseModule m False
643 [m] | looksLikeModuleName m -> browseModule m True
644 _ -> throwDyn (CmdLineError "syntax: :browse <module>")
646 browseModule m exports_only = do
648 dflags <- io getDynFlags
650 is_interpreted <- io (cmModuleIsInterpreted cms m)
651 when (not is_interpreted && not exports_only) $
652 throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
654 -- temporarily set the context to the module we're interested in,
655 -- just so we can get an appropriate PrintUnqualified
656 (as,bs) <- io (cmGetContext cms)
657 cms1 <- io (if exports_only then cmSetContext cms dflags [] [prel,m]
658 else cmSetContext cms dflags [m] [])
659 cms2 <- io (cmSetContext cms1 dflags as bs)
661 (cms3, things) <- io (cmBrowseModule cms2 dflags m exports_only)
665 let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context
667 things' = filter wantToSee things
669 wantToSee (AnId id) = not (isDataConId id || isDataConWrapId id)
672 thing_names = map getName things
674 thingDecl thing@(AnId id) = ifaceTyThing thing
676 thingDecl thing@(AClass c) =
677 let rn_decl = ifaceTyThing thing in
679 ClassDecl { tcdSigs = cons } ->
680 rn_decl{ tcdSigs = filter methodIsVisible cons }
683 methodIsVisible (ClassOpSig n _ _ _) = n `elem` thing_names
685 thingDecl thing@(ATyCon t) =
686 let rn_decl = ifaceTyThing thing in
688 TyData { tcdCons = DataCons cons } ->
689 rn_decl{ tcdCons = DataCons (filter conIsVisible cons) }
692 conIsVisible (ConDecl n _ _ _ _ _) = n `elem` thing_names
694 io (putStrLn (showSDocForUser unqual (
695 vcat (map (ppr . thingDecl) things')))
700 -----------------------------------------------------------------------------
701 -- Setting the module context
704 | all sensible mods = fn mods
705 | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
707 (fn, mods) = case str of
708 '+':stuff -> (addToContext, words stuff)
709 '-':stuff -> (removeFromContext, words stuff)
710 stuff -> (newContext, words stuff)
712 sensible ('*':m) = looksLikeModuleName m
713 sensible m = looksLikeModuleName m
717 dflags <- io getDynFlags
718 (as,bs) <- separate cms mods [] []
719 let bs' = if null as && prel `notElem` bs then prel:bs else bs
720 cms' <- io (cmSetContext cms dflags as bs')
723 separate cmstate [] as bs = return (as,bs)
724 separate cmstate (('*':m):ms) as bs = do
725 b <- io (cmModuleIsInterpreted cmstate m)
726 if b then separate cmstate ms (m:as) bs
727 else throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted"))
728 separate cmstate (m:ms) as bs = separate cmstate ms as (m:bs)
733 addToContext mods = do
735 dflags <- io getDynFlags
736 (as,bs) <- io (cmGetContext cms)
738 (as',bs') <- separate cms mods [] []
740 let as_to_add = as' \\ (as ++ bs)
741 bs_to_add = bs' \\ (as ++ bs)
743 cms' <- io (cmSetContext cms dflags
744 (as ++ as_to_add) (bs ++ bs_to_add))
748 removeFromContext mods = do
750 dflags <- io getDynFlags
751 (as,bs) <- io (cmGetContext cms)
753 (as_to_remove,bs_to_remove) <- separate cms mods [] []
755 let as' = as \\ (as_to_remove ++ bs_to_remove)
756 bs' = bs \\ (as_to_remove ++ bs_to_remove)
758 cms' <- io (cmSetContext cms dflags as' bs')
761 ----------------------------------------------------------------------------
764 -- set options in the interpreter. Syntax is exactly the same as the
765 -- ghc command line, except that certain options aren't available (-C,
768 -- This is pretty fragile: most options won't work as expected. ToDo:
769 -- figure out which ones & disallow them.
771 setCmd :: String -> GHCi ()
773 = do st <- getGHCiState
774 let opts = options st
775 io $ putStrLn (showSDoc (
776 text "options currently set: " <>
779 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
783 ("args":args) -> setArgs args
784 ("prog":prog) -> setProg prog
785 wds -> setOptions wds
789 setGHCiState st{ args = args }
793 setGHCiState st{ progname = prog }
795 io (hPutStrLn stderr "syntax: :set prog <progname>")
798 do -- first, deal with the GHCi opts (+s, +t, etc.)
799 let (plus_opts, minus_opts) = partition isPlus wds
800 mapM_ setOpt plus_opts
802 -- now, the GHC flags
803 pkgs_before <- io (readIORef v_Packages)
804 leftovers <- io (processArgs static_flags minus_opts [])
805 pkgs_after <- io (readIORef v_Packages)
807 -- update things if the users wants more packages
808 when (pkgs_before /= pkgs_after) $
809 newPackages (pkgs_after \\ pkgs_before)
811 -- then, dynamic flags
814 leftovers <- processArgs dynamic_flags leftovers []
817 if (not (null leftovers))
818 then throwDyn (CmdLineError ("unrecognised flags: " ++
823 unsetOptions :: String -> GHCi ()
825 = do -- first, deal with the GHCi opts (+s, +t, etc.)
827 (minus_opts, rest1) = partition isMinus opts
828 (plus_opts, rest2) = partition isPlus rest1
830 if (not (null rest2))
831 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
834 mapM_ unsetOpt plus_opts
836 -- can't do GHC flags for now
837 if (not (null minus_opts))
838 then throwDyn (CmdLineError "can't unset GHC command-line flags")
841 isMinus ('-':s) = True
844 isPlus ('+':s) = True
848 = case strToGHCiOpt str of
849 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
850 Just o -> setOption o
853 = case strToGHCiOpt str of
854 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
855 Just o -> unsetOption o
857 strToGHCiOpt :: String -> (Maybe GHCiOption)
858 strToGHCiOpt "s" = Just ShowTiming
859 strToGHCiOpt "t" = Just ShowType
860 strToGHCiOpt "r" = Just RevertCAFs
861 strToGHCiOpt _ = Nothing
863 optToStr :: GHCiOption -> String
864 optToStr ShowTiming = "s"
865 optToStr ShowType = "t"
866 optToStr RevertCAFs = "r"
868 newPackages new_pkgs = do
869 state <- getGHCiState
870 dflags <- io getDynFlags
871 cmstate1 <- io (cmUnload (cmstate state) dflags)
872 setGHCiState state{ cmstate = cmstate1, targets = [] }
875 pkgs <- getPackageInfo
876 flushPackageCache pkgs
878 new_pkg_info <- getPackageDetails new_pkgs
879 mapM_ (linkPackage dflags) (reverse new_pkg_info)
881 setContextAfterLoad []
883 -----------------------------------------------------------------------------
888 ["modules" ] -> showModules
889 ["bindings"] -> showBindings
890 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
894 let mg = cmGetModuleGraph cms
895 ls = cmGetLinkables cms
896 maybe_linkables = map (findModuleLinkable_maybe ls)
897 (map (moduleName.ms_mod) mg)
898 zipWithM showModule mg maybe_linkables
901 showModule :: ModSummary -> Maybe Linkable -> GHCi ()
902 showModule m (Just l) = do
903 io (putStrLn (showModMsg (isObjectLinkable l) (ms_mod m) (ms_location m)))
904 showModule _ Nothing = panic "missing linkable"
909 unqual = cmGetPrintUnqual cms
910 showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
912 io (mapM_ showBinding (cmGetBindings cms))
915 -----------------------------------------------------------------------------
918 data GHCiState = GHCiState
922 targets :: [FilePath],
924 options :: [GHCiOption]
928 = ShowTiming -- show time/allocs after evaluation
929 | ShowType -- show the type of expressions
930 | RevertCAFs -- revert CAFs after every evaluation
933 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
934 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
936 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
938 startGHCi :: GHCi a -> GHCiState -> IO a
939 startGHCi g state = do ref <- newIORef state; unGHCi g ref
941 instance Monad GHCi where
942 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
943 return a = GHCi $ \s -> return a
945 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
946 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
947 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
949 getGHCiState = GHCi $ \r -> readIORef r
950 setGHCiState s = GHCi $ \r -> writeIORef r s
952 -- for convenience...
953 getCmState = getGHCiState >>= return . cmstate
954 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
956 isOptionSet :: GHCiOption -> GHCi Bool
958 = do st <- getGHCiState
959 return (opt `elem` options st)
961 setOption :: GHCiOption -> GHCi ()
963 = do st <- getGHCiState
964 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
966 unsetOption :: GHCiOption -> GHCi ()
968 = do st <- getGHCiState
969 setGHCiState (st{ options = filter (/= opt) (options st) })
972 io m = GHCi { unGHCi = \s -> m >>= return }
974 -----------------------------------------------------------------------------
975 -- recursive exception handlers
977 -- Don't forget to unblock async exceptions in the handler, or if we're
978 -- in an exception loop (eg. let a = error a in a) the ^C exception
979 -- may never be delivered. Thanks to Marcin for pointing out the bug.
981 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
982 ghciHandle h (GHCi m) = GHCi $ \s ->
983 Exception.catch (m s)
984 (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
986 ghciUnblock :: GHCi a -> GHCi a
987 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
989 -----------------------------------------------------------------------------
992 -- Left: full path name of a .o file, including trailing .o
993 -- Right: "unadorned" name of a .DLL/.so
994 -- e.g. On unix "qt" denotes "libqt.so"
995 -- On WinDoze "burble" denotes "burble.DLL"
996 -- addDLL is platform-specific and adds the lib/.so/.DLL
997 -- suffixes platform-dependently; we don't do that here.
999 -- For dynamic objects only, try to find the object file in all the
1000 -- directories specified in v_Library_Paths before giving up.
1002 data LibrarySpec = Object FilePath | DLL String
1003 #ifdef darwin_TARGET_OS
1007 -- Packages that don't need loading, because the compiler shares them with
1008 -- the interpreted program.
1009 dont_load_these = [ "rts" ]
1011 -- Packages that are already linked into GHCi. For mingw32, we only
1012 -- skip gmp and rts, since std and after need to load the msvcrt.dll
1013 -- library which std depends on.
1015 # ifndef mingw32_TARGET_OS
1016 = [ "std", "concurrent", "posix", "text", "util" ]
1021 showLS (Object nm) = "(static) " ++ nm
1022 showLS (DLL nm) = "(dynamic) " ++ nm
1023 #ifdef darwin_TARGET_OS
1024 showLS (Framework nm) = "(framework) " ++ nm
1027 linkPackages :: DynFlags -> [LibrarySpec] -> [PackageConfig] -> IO ()
1028 linkPackages dflags cmdline_lib_specs pkgs
1029 = do mapM_ (linkPackage dflags) (reverse pkgs)
1030 lib_paths <- readIORef v_Library_paths
1031 mapM_ (preloadLib dflags lib_paths) cmdline_lib_specs
1032 if (null cmdline_lib_specs)
1034 else do maybePutStr dflags "final link ... "
1037 if ok then maybePutStrLn dflags "done."
1038 else throwDyn (InstallationError
1039 "linking extra libraries/objects failed")
1041 preloadLib :: DynFlags -> [String] -> LibrarySpec -> IO ()
1042 preloadLib dflags lib_paths lib_spec
1043 = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
1046 -> do b <- preload_static lib_paths static_ish
1047 maybePutStrLn dflags (if b then "done."
1050 -> -- We add "" to the set of paths to try, so that
1051 -- if none of the real paths match, we force addDLL
1052 -- to look in the default dynamic-link search paths.
1053 do maybe_errstr <- loadDynamic (lib_paths++[""])
1055 case maybe_errstr of
1056 Nothing -> return ()
1057 Just mm -> preloadFailed mm lib_paths lib_spec
1058 maybePutStrLn dflags "done"
1060 preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
1061 preloadFailed sys_errmsg paths spec
1062 = do maybePutStr dflags
1063 ("failed.\nDynamic linker error message was:\n "
1064 ++ sys_errmsg ++ "\nWhilst trying to load: "
1065 ++ showLS spec ++ "\nDirectories to search are:\n"
1066 ++ unlines (map (" "++) paths) )
1069 -- not interested in the paths in the static case.
1070 preload_static paths name
1071 = do b <- doesFileExist name
1072 if not b then return False
1073 else loadObj name >> return True
1076 = (throwDyn . CmdLineError)
1077 "user specified .o/.so/.DLL could not be loaded."
1079 linkPackage :: DynFlags -> PackageConfig -> IO ()
1080 linkPackage dflags pkg
1081 | name pkg `elem` dont_load_these = return ()
1084 let dirs = library_dirs pkg
1085 let libs = hs_libraries pkg ++ extra_libraries pkg
1086 classifieds <- mapM (locateOneObj dirs) libs
1087 #ifdef darwin_TARGET_OS
1088 let fwDirs = framework_dirs pkg
1089 let frameworks= extra_frameworks pkg
1092 -- Complication: all the .so's must be loaded before any of the .o's.
1093 let dlls = [ dll | DLL dll <- classifieds ]
1094 objs = [ obj | Object obj <- classifieds ]
1096 maybePutStr dflags ("Loading package " ++ name pkg ++ " ... ")
1098 -- If this package is already part of the GHCi binary, we'll already
1099 -- have the right DLLs for this package loaded, so don't try to
1101 when (name pkg `notElem` loaded_in_ghci) $ do
1102 #ifdef darwin_TARGET_OS
1103 loadFrameworks fwDirs frameworks
1105 loadDynamics dirs dlls
1107 -- After loading all the DLLs, we can load the static objects.
1110 maybePutStr dflags "linking ... "
1112 if ok then maybePutStrLn dflags "done."
1113 else panic ("can't load package `" ++ name pkg ++ "'")
1115 loadDynamics dirs [] = return ()
1116 loadDynamics dirs (dll:dlls) = do
1117 r <- loadDynamic dirs dll
1119 Nothing -> loadDynamics dirs dlls
1120 Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: "
1121 ++ dll ++ " (" ++ err ++ ")" ))
1122 #ifdef darwin_TARGET_OS
1123 loadFrameworks dirs [] = return ()
1124 loadFrameworks dirs (fw:fws) = do
1125 r <- loadFramework dirs fw
1127 Nothing -> loadFrameworks dirs fws
1128 Just err -> throwDyn (CmdLineError ("can't load framework: "
1129 ++ fw ++ " (" ++ err ++ ")" ))
1132 -- Try to find an object file for a given library in the given paths.
1133 -- If it isn't present, we assume it's a dynamic library.
1134 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
1136 = return (DLL lib) -- we assume
1137 locateOneObj (d:ds) lib
1138 = do let path = d ++ '/':lib ++ ".o"
1139 b <- doesFileExist path
1140 if b then return (Object path) else locateOneObj ds lib
1142 -- ----------------------------------------------------------------------------
1143 -- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
1145 #if defined(mingw32_TARGET_OS) || defined(cygwin32_TARGET_OS)
1146 loadDynamic paths rootname = addDLL rootname
1147 -- ignore paths on windows (why? --SDM)
1151 -- return Nothing == success, else Just error message from dlopen
1152 loadDynamic (path:paths) rootname = do
1153 let dll = path ++ '/':mkSOName rootname
1154 b <- doesFileExist dll
1156 then loadDynamic paths rootname
1158 loadDynamic [] rootname = do
1159 -- tried all our known library paths, let dlopen() search its
1160 -- own builtin paths now.
1161 addDLL (mkSOName rootname)
1163 #ifdef darwin_TARGET_OS
1164 mkSOName root = "lib" ++ root ++ ".dylib"
1166 mkSOName root = "lib" ++ root ++ ".so"
1171 -- Darwin / MacOS X only: load a framework
1172 -- a framework is a dynamic library packaged inside a directory of the same
1173 -- name. They are searched for in different paths than normal libraries.
1174 #ifdef darwin_TARGET_OS
1175 loadFramework extraPaths rootname
1176 = loadFramework' (extraPaths ++ defaultFrameworkPaths) where
1177 defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]
1179 loadFramework' (path:paths) = do
1180 let dll = path ++ '/' : rootname ++ ".framework/" ++ rootname
1181 b <- doesFileExist dll
1183 then loadFramework' paths
1185 loadFramework' [] = do
1186 -- tried all our known library paths, but dlopen()
1187 -- has no built-in paths for frameworks: give up
1188 return $ Just $ "not found"
1191 addDLL :: String -> IO (Maybe String)
1193 maybe_errmsg <- withCString str $ \dll -> c_addDLL dll
1194 if maybe_errmsg == nullPtr
1196 else do str <- peekCString maybe_errmsg
1199 foreign import ccall "addDLL" unsafe
1200 c_addDLL :: CString -> IO CString
1202 -----------------------------------------------------------------------------
1203 -- timing & statistics
1205 timeIt :: GHCi a -> GHCi a
1207 = do b <- isOptionSet ShowTiming
1210 else do allocs1 <- io $ getAllocations
1211 time1 <- io $ getCPUTime
1213 allocs2 <- io $ getAllocations
1214 time2 <- io $ getCPUTime
1215 io $ printTimes (allocs2 - allocs1) (time2 - time1)
1218 foreign import "getAllocations" getAllocations :: IO Int
1220 printTimes :: Int -> Integer -> IO ()
1221 printTimes allocs psecs
1222 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1223 secs_str = showFFloat (Just 2) secs
1224 putStrLn (showSDoc (
1225 parens (text (secs_str "") <+> text "secs" <> comma <+>
1226 int allocs <+> text "bytes")))
1228 -----------------------------------------------------------------------------
1231 looksLikeModuleName [] = False
1232 looksLikeModuleName (c:cs) = isUpper c && all isAlphaNumEx cs
1234 isAlphaNumEx c = isAlphaNum c || c == '_' || c == '.'
1236 maybePutStr dflags s | verbosity dflags > 0 = putStr s
1237 | otherwise = return ()
1239 maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
1240 | otherwise = return ()
1242 -----------------------------------------------------------------------------
1245 foreign import revertCAFs :: IO () -- make it "safe", just in case