1 {-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
2 -----------------------------------------------------------------------------
3 -- $Id: InteractiveUI.hs,v 1.123 2002/05/01 15:48:48 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
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
1002 -- Packages that don't need loading, because the compiler shares them with
1003 -- the interpreted program.
1004 dont_load_these = [ "rts" ]
1006 -- Packages that are already linked into GHCi. For mingw32, we only
1007 -- skip gmp and rts, since std and after need to load the msvcrt.dll
1008 -- library which std depends on.
1010 # ifndef mingw32_TARGET_OS
1011 = [ "std", "concurrent", "posix", "text", "util" ]
1016 showLS (Object nm) = "(static) " ++ nm
1017 showLS (DLL nm) = "(dynamic) " ++ nm
1019 linkPackages :: DynFlags -> [LibrarySpec] -> [PackageConfig] -> IO ()
1020 linkPackages dflags cmdline_lib_specs pkgs
1021 = do mapM_ (linkPackage dflags) (reverse pkgs)
1022 lib_paths <- readIORef v_Library_paths
1023 mapM_ (preloadLib dflags lib_paths) cmdline_lib_specs
1024 if (null cmdline_lib_specs)
1026 else do maybePutStr dflags "final link ... "
1029 if ok then maybePutStrLn dflags "done."
1030 else throwDyn (InstallationError
1031 "linking extra libraries/objects failed")
1033 preloadLib :: DynFlags -> [String] -> LibrarySpec -> IO ()
1034 preloadLib dflags lib_paths lib_spec
1035 = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
1038 -> do b <- preload_static lib_paths static_ish
1039 maybePutStrLn dflags (if b then "done."
1042 -> -- We add "" to the set of paths to try, so that
1043 -- if none of the real paths match, we force addDLL
1044 -- to look in the default dynamic-link search paths.
1045 do maybe_errstr <- loadDynamic (lib_paths++[""])
1047 case maybe_errstr of
1048 Nothing -> return ()
1049 Just mm -> preloadFailed mm lib_paths lib_spec
1050 maybePutStrLn dflags "done"
1052 preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
1053 preloadFailed sys_errmsg paths spec
1054 = do maybePutStr dflags
1055 ("failed.\nDynamic linker error message was:\n "
1056 ++ sys_errmsg ++ "\nWhilst trying to load: "
1057 ++ showLS spec ++ "\nDirectories to search are:\n"
1058 ++ unlines (map (" "++) paths) )
1061 -- not interested in the paths in the static case.
1062 preload_static paths name
1063 = do b <- doesFileExist name
1064 if not b then return False
1065 else loadObj name >> return True
1068 = (throwDyn . CmdLineError)
1069 "user specified .o/.so/.DLL could not be loaded."
1071 linkPackage :: DynFlags -> PackageConfig -> IO ()
1072 linkPackage dflags pkg
1073 | name pkg `elem` dont_load_these = return ()
1076 let dirs = library_dirs pkg
1077 let libs = hs_libraries pkg ++ extra_libraries pkg
1078 classifieds <- mapM (locateOneObj dirs) libs
1080 -- Complication: all the .so's must be loaded before any of the .o's.
1081 let dlls = [ dll | DLL dll <- classifieds ]
1082 objs = [ obj | Object obj <- classifieds ]
1084 maybePutStr dflags ("Loading package " ++ name pkg ++ " ... ")
1086 -- If this package is already part of the GHCi binary, we'll already
1087 -- have the right DLLs for this package loaded, so don't try to
1089 when (name pkg `notElem` loaded_in_ghci) $
1090 loadDynamics dirs dlls
1092 -- After loading all the DLLs, we can load the static objects.
1095 maybePutStr dflags "linking ... "
1097 if ok then maybePutStrLn dflags "done."
1098 else panic ("can't load package `" ++ name pkg ++ "'")
1100 loadDynamics dirs [] = return ()
1101 loadDynamics dirs (dll:dlls) = do
1102 r <- loadDynamic dirs dll
1104 Nothing -> loadDynamics dirs dlls
1105 Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: "
1106 ++ dll ++ " (" ++ err ++ ")" ))
1108 -- Try to find an object file for a given library in the given paths.
1109 -- If it isn't present, we assume it's a dynamic library.
1110 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
1112 = return (DLL lib) -- we assume
1113 locateOneObj (d:ds) lib
1114 = do let path = d ++ '/':lib ++ ".o"
1115 b <- doesFileExist path
1116 if b then return (Object path) else locateOneObj ds lib
1118 -- ----------------------------------------------------------------------------
1119 -- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
1121 #ifdef mingw32_TARGET_OS
1122 loadDynamic paths rootname = addDLL rootname
1123 -- ignore paths on windows (why? --SDM)
1127 -- return Nothing == success, else Just error message from dlopen
1128 loadDynamic (path:paths) rootname = do
1129 let dll = path ++ '/':mkSOName rootname
1130 b <- doesFileExist dll
1132 then loadDynamic paths rootname
1134 loadDynamic [] rootname = do
1135 -- tried all our known library paths, let dlopen() search its
1136 -- own builtin paths now.
1137 addDLL (mkSOName rootname)
1139 mkSOName root = "lib" ++ root ++ ".so"
1143 addDLL :: String -> IO (Maybe String)
1145 maybe_errmsg <- withCString str $ \dll -> c_addDLL dll
1146 if maybe_errmsg == nullPtr
1148 else do str <- peekCString maybe_errmsg
1151 foreign import ccall "addDLL" unsafe
1152 c_addDLL :: CString -> IO CString
1154 -----------------------------------------------------------------------------
1155 -- timing & statistics
1157 timeIt :: GHCi a -> GHCi a
1159 = do b <- isOptionSet ShowTiming
1162 else do allocs1 <- io $ getAllocations
1163 time1 <- io $ getCPUTime
1165 allocs2 <- io $ getAllocations
1166 time2 <- io $ getCPUTime
1167 io $ printTimes (allocs2 - allocs1) (time2 - time1)
1170 foreign import "getAllocations" getAllocations :: IO Int
1172 printTimes :: Int -> Integer -> IO ()
1173 printTimes allocs psecs
1174 = do let secs = (fromIntegral psecs / (10^12)) :: Float
1175 secs_str = showFFloat (Just 2) secs
1176 putStrLn (showSDoc (
1177 parens (text (secs_str "") <+> text "secs" <> comma <+>
1178 int allocs <+> text "bytes")))
1180 -----------------------------------------------------------------------------
1183 looksLikeModuleName [] = False
1184 looksLikeModuleName (c:cs) = isUpper c && all isAlphaNumEx cs
1186 isAlphaNumEx c = isAlphaNum c || c == '_' || c == '.'
1188 maybePutStr dflags s | verbosity dflags > 0 = putStr s
1189 | otherwise = return ()
1191 maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
1192 | otherwise = return ()
1194 -----------------------------------------------------------------------------
1197 foreign import revertCAFs :: IO () -- make it "safe", just in case