1 {-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.126 2002/06/12 22:04:25 wolfgang 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
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 -----------------------------------------------------------------------------
886 ["modules" ] -> showModules
887 ["bindings"] -> showBindings
888 _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
892 let mg = cmGetModuleGraph cms
893 ls = cmGetLinkables cms
894 maybe_linkables = map (findModuleLinkable_maybe ls)
895 (map (moduleName.ms_mod) mg)
896 zipWithM showModule mg maybe_linkables
899 showModule :: ModSummary -> Maybe Linkable -> GHCi ()
900 showModule m (Just l) = do
901 io (putStrLn (showModMsg (isObjectLinkable l) (ms_mod m) (ms_location m)))
902 showModule _ Nothing = panic "missing linkable"
907 unqual = cmGetPrintUnqual cms
908 showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b)))
910 io (mapM_ showBinding (cmGetBindings cms))
913 -----------------------------------------------------------------------------
916 data GHCiState = GHCiState
920 targets :: [FilePath],
922 options :: [GHCiOption]
926 = ShowTiming -- show time/allocs after evaluation
927 | ShowType -- show the type of expressions
928 | RevertCAFs -- revert CAFs after every evaluation
931 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
932 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
934 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
936 startGHCi :: GHCi a -> GHCiState -> IO a
937 startGHCi g state = do ref <- newIORef state; unGHCi g ref
939 instance Monad GHCi where
940 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
941 return a = GHCi $ \s -> return a
943 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
944 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
945 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
947 getGHCiState = GHCi $ \r -> readIORef r
948 setGHCiState s = GHCi $ \r -> writeIORef r s
950 -- for convenience...
951 getCmState = getGHCiState >>= return . cmstate
952 setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms}
954 isOptionSet :: GHCiOption -> GHCi Bool
956 = do st <- getGHCiState
957 return (opt `elem` options st)
959 setOption :: GHCiOption -> GHCi ()
961 = do st <- getGHCiState
962 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
964 unsetOption :: GHCiOption -> GHCi ()
966 = do st <- getGHCiState
967 setGHCiState (st{ options = filter (/= opt) (options st) })
970 io m = GHCi { unGHCi = \s -> m >>= return }
972 -----------------------------------------------------------------------------
973 -- recursive exception handlers
975 -- Don't forget to unblock async exceptions in the handler, or if we're
976 -- in an exception loop (eg. let a = error a in a) the ^C exception
977 -- may never be delivered. Thanks to Marcin for pointing out the bug.
979 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
980 ghciHandle h (GHCi m) = GHCi $ \s ->
981 Exception.catch (m s)
982 (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
984 ghciUnblock :: GHCi a -> GHCi a
985 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
987 -----------------------------------------------------------------------------
990 -- Left: full path name of a .o file, including trailing .o
991 -- Right: "unadorned" name of a .DLL/.so
992 -- e.g. On unix "qt" denotes "libqt.so"
993 -- On WinDoze "burble" denotes "burble.DLL"
994 -- addDLL is platform-specific and adds the lib/.so/.DLL
995 -- suffixes platform-dependently; we don't do that here.
997 -- For dynamic objects only, try to find the object file in all the
998 -- directories specified in v_Library_Paths before giving up.
1000 data LibrarySpec = Object FilePath | DLL String
1001 #ifdef darwin_TARGET_OS
1005 -- Packages that don't need loading, because the compiler shares them with
1006 -- the interpreted program.
1007 dont_load_these = [ "rts" ]
1009 -- Packages that are already linked into GHCi. For mingw32, we only
1010 -- skip gmp and rts, since std and after need to load the msvcrt.dll
1011 -- library which std depends on.
1013 # ifndef mingw32_TARGET_OS
1014 = [ "std", "concurrent", "posix", "text", "util" ]
1019 showLS (Object nm) = "(static) " ++ nm
1020 showLS (DLL nm) = "(dynamic) " ++ nm
1021 #ifdef darwin_TARGET_OS
1022 showLS (Framework nm) = "(framework) " ++ nm
1025 linkPackages :: DynFlags -> [LibrarySpec] -> [PackageConfig] -> IO ()
1026 linkPackages dflags cmdline_lib_specs pkgs
1027 = do mapM_ (linkPackage dflags) (reverse pkgs)
1028 lib_paths <- readIORef v_Library_paths
1029 mapM_ (preloadLib dflags lib_paths) cmdline_lib_specs
1030 if (null cmdline_lib_specs)
1032 else do maybePutStr dflags "final link ... "
1035 if ok then maybePutStrLn dflags "done."
1036 else throwDyn (InstallationError
1037 "linking extra libraries/objects failed")
1039 preloadLib :: DynFlags -> [String] -> LibrarySpec -> IO ()
1040 preloadLib dflags lib_paths lib_spec
1041 = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
1044 -> do b <- preload_static lib_paths static_ish
1045 maybePutStrLn dflags (if b then "done."
1048 -> -- We add "" to the set of paths to try, so that
1049 -- if none of the real paths match, we force addDLL
1050 -- to look in the default dynamic-link search paths.
1051 do maybe_errstr <- loadDynamic (lib_paths++[""])
1053 case maybe_errstr of
1054 Nothing -> return ()
1055 Just mm -> preloadFailed mm lib_paths lib_spec
1056 maybePutStrLn dflags "done"
1058 preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
1059 preloadFailed sys_errmsg paths spec
1060 = do maybePutStr dflags
1061 ("failed.\nDynamic linker error message was:\n "
1062 ++ sys_errmsg ++ "\nWhilst trying to load: "
1063 ++ showLS spec ++ "\nDirectories to search are:\n"
1064 ++ unlines (map (" "++) paths) )
1067 -- not interested in the paths in the static case.
1068 preload_static paths name
1069 = do b <- doesFileExist name
1070 if not b then return False
1071 else loadObj name >> return True
1074 = (throwDyn . CmdLineError)
1075 "user specified .o/.so/.DLL could not be loaded."
1077 linkPackage :: DynFlags -> PackageConfig -> IO ()
1078 linkPackage dflags pkg
1079 | name pkg `elem` dont_load_these = return ()
1082 let dirs = library_dirs pkg
1083 let libs = hs_libraries pkg ++ extra_libraries pkg
1084 classifieds <- mapM (locateOneObj dirs) libs
1086 -- Complication: all the .so's must be loaded before any of the .o's.
1087 let dlls = [ dll | DLL dll <- classifieds ]
1088 objs = [ obj | Object obj <- classifieds ]
1090 maybePutStr dflags ("Loading package " ++ name pkg ++ " ... ")
1092 -- If this package is already part of the GHCi binary, we'll already
1093 -- have the right DLLs for this package loaded, so don't try to
1095 when (name pkg `notElem` loaded_in_ghci) $
1096 loadDynamics dirs dlls
1098 -- After loading all the DLLs, we can load the static objects.
1101 maybePutStr dflags "linking ... "
1103 if ok then maybePutStrLn dflags "done."
1104 else panic ("can't load package `" ++ name pkg ++ "'")
1106 loadDynamics dirs [] = return ()
1107 loadDynamics dirs (dll:dlls) = do
1108 r <- loadDynamic dirs dll
1110 Nothing -> loadDynamics dirs dlls
1111 Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: "
1112 ++ dll ++ " (" ++ err ++ ")" ))
1114 -- Try to find an object file for a given library in the given paths.
1115 -- If it isn't present, we assume it's a dynamic library.
1116 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
1118 = return (DLL lib) -- we assume
1119 locateOneObj (d:ds) lib
1120 = do let path = d ++ '/':lib ++ ".o"
1121 b <- doesFileExist path
1122 if b then return (Object path) else locateOneObj ds lib
1124 -- ----------------------------------------------------------------------------
1125 -- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
1127 #if defined(mingw32_TARGET_OS) || defined(cygwin32_TARGET_OS)
1128 loadDynamic paths rootname = addDLL rootname
1129 -- ignore paths on windows (why? --SDM)
1133 -- return Nothing == success, else Just error message from dlopen
1134 loadDynamic (path:paths) rootname = do
1135 let dll = path ++ '/':mkSOName rootname
1136 b <- doesFileExist dll
1138 then loadDynamic paths rootname
1140 loadDynamic [] rootname = do
1141 -- tried all our known library paths, let dlopen() search its
1142 -- own builtin paths now.
1143 addDLL (mkSOName rootname)
1145 mkSOName root = "lib" ++ root ++ ".so"
1149 addDLL :: String -> IO (Maybe String)
1151 maybe_errmsg <- withCString str $ \dll -> c_addDLL dll
1152 if maybe_errmsg == nullPtr
1154 else do str <- peekCString maybe_errmsg
1157 foreign import ccall "addDLL" unsafe
1158 c_addDLL :: CString -> IO CString
1160 -----------------------------------------------------------------------------
1161 -- timing & statistics
1163 timeIt :: GHCi a -> GHCi a
1165 = do b <- isOptionSet ShowTiming
1168 else do allocs1 <- io $ getAllocations
1169 time1 <- io $ getCPUTime
1171 allocs2 <- io $ getAllocations
1172 time2 <- io $ getCPUTime
1173 io $ printTimes (allocs2 - allocs1) (time2 - time1)
1176 foreign import "getAllocations" getAllocations :: IO Int
1178 printTimes :: Int -> Integer -> IO ()
1179 printTimes allocs psecs
1180 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1181 secs_str = showFFloat (Just 2) secs
1182 putStrLn (showSDoc (
1183 parens (text (secs_str "") <+> text "secs" <> comma <+>
1184 int allocs <+> text "bytes")))
1186 -----------------------------------------------------------------------------
1189 looksLikeModuleName [] = False
1190 looksLikeModuleName (c:cs) = isUpper c && all isAlphaNumEx cs
1192 isAlphaNumEx c = isAlphaNum c || c == '_' || c == '.'
1194 maybePutStr dflags s | verbosity dflags > 0 = putStr s
1195 | otherwise = return ()
1197 maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
1198 | otherwise = return ()
1200 -----------------------------------------------------------------------------
1203 foreign import revertCAFs :: IO () -- make it "safe", just in case