1 -----------------------------------------------------------------------------
2 -- $Id: InteractiveUI.hs,v 1.65 2001/05/04 14:56:53 simonmar Exp $
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2000
8 -----------------------------------------------------------------------------
10 {-# OPTIONS -#include "Linker.h" #-}
11 module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
13 #include "../includes/config.h"
14 #include "HsVersions.h"
23 import Finder ( flushPackageCache )
27 import CmdLineOpts ( DynFlag(..), dopt_unset )
28 import Panic ( GhcException(..) )
34 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
48 import PrelGHC ( unsafeCoerce# )
49 import Foreign ( nullPtr )
50 import CString ( peekCString )
52 -----------------------------------------------------------------------------
56 \ / _ \\ /\\ /\\/ __(_)\n\
57 \ / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", For Haskell 98.\n\
58 \/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n\
59 \\\____/\\/ /_/\\____/|_| Type :? for help.\n"
61 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
63 builtin_commands :: [(String, String -> GHCi Bool)]
65 ("add", keepGoing addModule),
66 ("cd", keepGoing changeDirectory),
67 ("def", keepGoing defineMacro),
68 ("help", keepGoing help),
69 ("?", keepGoing help),
70 ("load", keepGoing loadModule),
71 ("module", keepGoing setContext),
72 ("reload", keepGoing reloadModule),
73 ("set", keepGoing setOptions),
74 ("type", keepGoing typeOfExpr),
75 ("unset", keepGoing unsetOptions),
76 ("undef", keepGoing undefineMacro),
80 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
81 keepGoing a str = a str >> return False
83 shortHelpText = "use :? for help.\n"
86 \ Commands available from the prompt:\n\
88 \ <stmt> evaluate/run <stmt>\n\
89 \ :cd <dir> change directory to <dir>\n\
90 \ :def <cmd> <expr> define a command :<cmd>\n\
91 \ :help, :? display this list of commands\n\
92 \ :load <filename> load a module (and it dependents)\n\
93 \ :module <mod> set the context for expression evaluation to <mod>\n\
94 \ :reload reload the current module set\n\
95 \ :set <option> ... set options\n\
96 \ :undef <name> undefine user-defined command :<name>\n\
97 \ :type <expr> show the type of <expr>\n\
98 \ :unset <option> ... unset options\n\
100 \ :!<command> run the shell command <command>\n\
102 \ Options for `:set' and `:unset':\n\
104 \ +r revert top-level expressions after each evaluation\n\
105 \ +s print timing/memory stats after each evaluation\n\
106 \ +t print type after evaluation\n\
107 \ -<flags> most GHC command line flags can also be set here\n\
108 \ (eg. -v2, -fglasgow-exts, etc.)\n\
110 --ToDo :add <filename> add a module to the current set\n\
112 interactiveUI :: CmState -> Maybe FilePath -> [LibrarySpec] -> IO ()
113 interactiveUI cmstate mod cmdline_libs = do
115 hSetBuffering stdout NoBuffering
117 -- link in the available packages
118 pkgs <- getPackageInfo
120 linkPackages cmdline_libs pkgs
122 (cmstate, ok, mods) <-
124 Nothing -> return (cmstate, True, [])
125 Just m -> cmLoadModule cmstate m
127 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
131 dflags <- getDynFlags
133 (cmstate, maybe_hval)
134 <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stderr"
136 Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ())
137 _ -> panic "interactiveUI:stderr"
139 (cmstate, maybe_hval)
140 <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stdout"
142 Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ())
143 _ -> panic "interactiveUI:stdout"
145 (unGHCi runGHCi) GHCiState{ target = mod,
155 exists <- io (doesFileExist file)
157 dir_ok <- io (checkPerms ".")
158 file_ok <- io (checkPerms file)
159 when (dir_ok && file_ok) $ do
160 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
163 Right hdl -> fileLoop hdl False
165 -- Read in $HOME/.ghci
166 either_dir <- io (IO.try (getEnv "HOME"))
170 cwd <- io (getCurrentDirectory)
171 when (dir /= cwd) $ do
172 let file = dir ++ "/.ghci"
173 ok <- io (checkPerms file)
174 either_hdl <- io (IO.try (openFile file ReadMode))
177 Right hdl -> fileLoop hdl False
179 -- read commands from stdin
180 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
187 io $ do putStrLn "Leaving GHCi."
190 -- NOTE: We only read .ghci files if they are owned by the current user,
191 -- and aren't world writable. Otherwise, we could be accidentally
192 -- running code planted by a malicious third party.
194 checkPerms :: String -> IO Bool
196 handle (\_ -> return False) $ do
197 st <- getFileStatus name
199 if fileOwner st /= me then do
200 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
203 let mode = fileMode st
204 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
205 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
207 putStrLn $ "*** WARNING: " ++ name ++
208 " is writable by someone else, IGNORING!"
212 fileLoop :: Handle -> Bool -> GHCi ()
213 fileLoop hdl prompt = do
215 mod <- io (cmGetContext (cmstate st))
216 when prompt (io (putStr (mod ++ "> ")))
217 l <- io (IO.try (hGetLine hdl))
219 Left e | isEOFError e -> return ()
220 | otherwise -> throw e
222 case remove_spaces l of
223 "" -> fileLoop hdl prompt
224 l -> do quit <- runCommand l
225 if quit then return () else fileLoop hdl prompt
227 stringLoop :: [String] -> GHCi ()
228 stringLoop [] = return ()
229 stringLoop (s:ss) = do
231 case remove_spaces s of
233 l -> do quit <- runCommand l
234 if quit then return () else stringLoop ss
236 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
237 readlineLoop :: GHCi ()
240 mod <- io (cmGetContext (cmstate st))
241 l <- io (readline (mod ++ "> "))
245 case remove_spaces l of
250 if quit then return () else readlineLoop
253 -- Top level exception handler, just prints out the exception
255 runCommand :: String -> GHCi Bool
257 ghciHandle ( \exception ->
260 case fromDynamic dyn of
261 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
264 PhaseFailed phase code ->
265 io ( putStrLn ("Phase " ++ phase ++ " failed (code "
266 ++ show code ++ ")"))
267 Interrupted -> io (putStrLn "Interrupted.")
268 -- omit the location for CmdLineError
269 CmdLineError s -> io (putStrLn s)
270 other -> io (putStrLn (show (ghc_ex :: GhcException)))
272 other -> io (putStrLn ("*** Exception: " ++ show exception))
279 doCommand (':' : command) = specialCommand command
281 = do timeIt (do stuff <- runStmt stmt; finishEvalExpr stuff)
284 -- Returns True if the expr was successfully parsed, renamed and
286 runStmt :: String -> GHCi (Maybe [Name])
288 | null (filter (not.isSpace) stmt)
291 = do st <- getGHCiState
292 dflags <- io (getDynFlags)
293 let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
294 (new_cmstate, names) <- io (cmRunStmt (cmstate st) dflags' stmt)
295 setGHCiState st{cmstate = new_cmstate}
298 -- possibly print the type and revert CAFs after evaluating an expression
299 finishEvalExpr Nothing = return False
300 finishEvalExpr (Just names)
301 = do b <- isOptionSet ShowType
303 when b (mapM_ (showTypeOfName (cmstate st)) names)
305 b <- isOptionSet RevertCAFs
306 io (when b revertCAFs)
310 showTypeOfName :: CmState -> Name -> GHCi ()
311 showTypeOfName cmstate n
312 = do maybe_str <- io (cmTypeOfName cmstate n)
315 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
317 flushEverything :: GHCi ()
319 = io $ do flush_so <- readIORef flush_stdout
321 flush_se <- readIORef flush_stdout
325 specialCommand :: String -> GHCi Bool
326 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
327 specialCommand str = do
328 let (cmd,rest) = break isSpace str
329 cmds <- io (readIORef commands)
330 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
331 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
332 ++ shortHelpText) >> return False)
333 [(_,f)] -> f (dropWhile isSpace rest)
334 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
335 " matches multiple commands (" ++
336 foldr1 (\a b -> a ++ ',':b) (map fst cs)
337 ++ ")") >> return False)
339 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
341 -----------------------------------------------------------------------------
344 help :: String -> GHCi ()
345 help _ = io (putStr helpText)
347 addModule :: String -> GHCi ()
348 addModule _ = throwDyn (InstallationError ":add not implemented")
350 setContext :: String -> GHCi ()
352 = throwDyn (CmdLineError "syntax: `:m <module>'")
353 setContext m | not (isUpper (head m)) || not (all isAlphaNum (tail m))
354 = throwDyn (CmdLineError ("strange looking module name: `" ++ m ++ "'"))
356 = do st <- getGHCiState
357 new_cmstate <- io (cmSetContext (cmstate st) str)
358 setGHCiState st{cmstate=new_cmstate}
360 changeDirectory :: String -> GHCi ()
361 changeDirectory ('~':d) = do
362 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
363 io (setCurrentDirectory (tilde ++ '/':d))
364 changeDirectory d = io (setCurrentDirectory d)
366 defineMacro :: String -> GHCi ()
368 let (macro_name, definition) = break isSpace s
369 cmds <- io (readIORef commands)
371 then throwDyn (CmdLineError "invalid macro name")
373 if (macro_name `elem` map fst cmds)
374 then throwDyn (CmdLineError
375 ("command `" ++ macro_name ++ "' is already defined"))
378 -- give the expression a type signature, so we can be sure we're getting
379 -- something of the right type.
380 let new_expr = '(' : definition ++ ") :: String -> IO String"
382 -- compile the expression
384 dflags <- io (getDynFlags)
385 (new_cmstate, maybe_hv) <- io (cmCompileExpr (cmstate st) dflags new_expr)
386 setGHCiState st{cmstate = new_cmstate}
389 Just hv -> io (writeIORef commands --
390 ((macro_name, keepGoing (runMacro hv)) : cmds))
392 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
394 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
395 stringLoop (lines str)
397 undefineMacro :: String -> GHCi ()
398 undefineMacro macro_name = do
399 cmds <- io (readIORef commands)
400 if (macro_name `elem` map fst builtin_commands)
401 then throwDyn (CmdLineError
402 ("command `" ++ macro_name ++ "' cannot be undefined"))
404 if (macro_name `notElem` map fst cmds)
405 then throwDyn (CmdLineError
406 ("command `" ++ macro_name ++ "' not defined"))
408 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
410 loadModule :: String -> GHCi ()
411 loadModule path = timeIt (loadModule' path)
413 loadModule' path = do
414 state <- getGHCiState
415 dflags <- io (getDynFlags)
416 cmstate1 <- io (cmUnload (cmstate state) dflags)
417 io (revertCAFs) -- always revert CAFs on load.
418 (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path)
419 let new_state = state{ cmstate = cmstate2,
422 setGHCiState new_state
423 modulesLoadedMsg ok mods
425 reloadModule :: String -> GHCi ()
427 state <- getGHCiState
429 Nothing -> io (putStr "no current target\n")
431 -> do io (revertCAFs) -- always revert CAFs on reload.
432 (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path)
433 setGHCiState state{ cmstate=new_cmstate }
434 modulesLoadedMsg ok mods
436 reloadModule _ = noArgs ":reload"
439 modulesLoadedMsg ok mods = do
441 | null mods = text "none."
443 punctuate comma (map text mods)) <> text "."
446 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
448 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
451 typeOfExpr :: String -> GHCi ()
453 = do st <- getGHCiState
454 dflags <- io (getDynFlags)
455 (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr (cmstate st) dflags str)
456 setGHCiState st{cmstate = new_cmstate}
459 Just tystr -> io (putStrLn tystr)
461 quit :: String -> GHCi Bool
464 shellEscape :: String -> GHCi Bool
465 shellEscape str = io (system str >> return False)
467 ----------------------------------------------------------------------------
470 -- set options in the interpreter. Syntax is exactly the same as the
471 -- ghc command line, except that certain options aren't available (-C,
474 -- This is pretty fragile: most options won't work as expected. ToDo:
475 -- figure out which ones & disallow them.
477 setOptions :: String -> GHCi ()
479 = do st <- getGHCiState
480 let opts = options st
481 io $ putStrLn (showSDoc (
482 text "options currently set: " <>
485 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
488 = do -- first, deal with the GHCi opts (+s, +t, etc.)
489 let (plus_opts, minus_opts) = partition isPlus (words str)
490 mapM setOpt plus_opts
492 -- now, the GHC flags
493 pkgs_before <- io (readIORef v_Packages)
494 leftovers <- io (processArgs static_flags minus_opts [])
495 pkgs_after <- io (readIORef v_Packages)
497 -- update things if the users wants more packages
498 when (pkgs_before /= pkgs_after) $
499 newPackages (pkgs_after \\ pkgs_before)
501 -- then, dynamic flags
503 dyn_flags <- readIORef v_InitDynFlags
504 writeIORef v_DynFlags dyn_flags
505 leftovers <- processArgs dynamic_flags leftovers []
506 dyn_flags <- readIORef v_DynFlags
507 writeIORef v_InitDynFlags dyn_flags
509 if (not (null leftovers))
510 then throwDyn (CmdLineError ("unrecognised flags: " ++
515 unsetOptions :: String -> GHCi ()
517 = do -- first, deal with the GHCi opts (+s, +t, etc.)
519 (minus_opts, rest1) = partition isMinus opts
520 (plus_opts, rest2) = partition isPlus rest1
522 if (not (null rest2))
523 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
526 mapM unsetOpt plus_opts
528 -- can't do GHC flags for now
529 if (not (null minus_opts))
530 then throwDyn (CmdLineError "can't unset GHC command-line flags")
533 isMinus ('-':s) = True
536 isPlus ('+':s) = True
540 = case strToGHCiOpt str of
541 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
542 Just o -> setOption o
545 = case strToGHCiOpt str of
546 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
547 Just o -> unsetOption o
549 strToGHCiOpt :: String -> (Maybe GHCiOption)
550 strToGHCiOpt "s" = Just ShowTiming
551 strToGHCiOpt "t" = Just ShowType
552 strToGHCiOpt "r" = Just RevertCAFs
553 strToGHCiOpt _ = Nothing
555 optToStr :: GHCiOption -> String
556 optToStr ShowTiming = "s"
557 optToStr ShowType = "t"
558 optToStr RevertCAFs = "r"
560 newPackages new_pkgs = do
561 state <- getGHCiState
562 dflags <- io (getDynFlags)
563 cmstate1 <- io (cmUnload (cmstate state) dflags)
564 setGHCiState state{ cmstate = cmstate1, target = Nothing }
567 pkgs <- getPackageInfo
568 flushPackageCache pkgs
570 new_pkg_info <- getPackageDetails new_pkgs
571 mapM_ (linkPackage False) (reverse new_pkg_info)
573 -----------------------------------------------------------------------------
576 data GHCiState = GHCiState
578 target :: Maybe FilePath,
580 options :: [GHCiOption]
584 = ShowTiming -- show time/allocs after evaluation
585 | ShowType -- show the type of expressions
586 | RevertCAFs -- revert CAFs after every evaluation
589 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
590 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
592 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
594 instance Monad GHCi where
595 (GHCi m) >>= k = GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
596 return a = GHCi $ \s -> return (s,a)
598 getGHCiState = GHCi $ \s -> return (s,s)
599 setGHCiState s = GHCi $ \_ -> return (s,())
601 isOptionSet :: GHCiOption -> GHCi Bool
603 = do st <- getGHCiState
604 return (opt `elem` options st)
606 setOption :: GHCiOption -> GHCi ()
608 = do st <- getGHCiState
609 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
611 unsetOption :: GHCiOption -> GHCi ()
613 = do st <- getGHCiState
614 setGHCiState (st{ options = filter (/= opt) (options st) })
616 io m = GHCi $ \s -> m >>= \a -> return (s,a)
618 -----------------------------------------------------------------------------
619 -- recursive exception handlers
621 -- Don't forget to unblock async exceptions in the handler, or if we're
622 -- in an exception loop (eg. let a = error a in a) the ^C exception
623 -- may never be delivered. Thanks to Marcin for pointing out the bug.
625 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
626 ghciHandle h (GHCi m) = GHCi $ \s ->
627 Exception.catch (m s)
628 (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
630 ghciUnblock :: GHCi a -> GHCi a
631 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
633 -----------------------------------------------------------------------------
636 -- Left: full path name of a .o file, including trailing .o
637 -- Right: "unadorned" name of a .DLL/.so
638 -- e.g. On unix "qt" denotes "libqt.so"
639 -- On WinDoze "burble" denotes "burble.DLL"
640 -- addDLL is platform-specific and adds the lib/.so/.DLL
641 -- prefixes plaform-dependently; we don't do that here.
643 = Either FilePath String
645 showLS (Left nm) = "(static) " ++ nm
646 showLS (Right nm) = "(dynamic) " ++ nm
648 linkPackages :: [LibrarySpec] -> [PackageConfig] -> IO ()
649 linkPackages cmdline_lib_specs pkgs
650 = do sequence_ [ linkPackage (name p `elem` loaded) p | p <- reverse pkgs ]
651 mapM_ preloadLib cmdline_lib_specs
653 -- packages that are already linked into GHCi
654 loaded = [ "concurrent", "posix", "text", "util" ]
657 = do putStr ("Loading object " ++ showLS lib_spec ++ " ... ")
660 -> do b <- doesFileExist static_ish
662 then do putStr "not found.\n"
664 else do loadObj static_ish
667 -> do maybe_errmsg <- addDLL dll_unadorned
668 if maybe_errmsg == nullPtr
669 then putStr "done.\n"
670 else do str <- peekCString maybe_errmsg
671 putStr ("failed (" ++ str ++ ")\n")
674 croak = throwDyn (CmdLineError "user specified .o/.so/.DLL could not be loaded.")
677 linkPackage :: Bool -> PackageConfig -> IO ()
678 -- ignore rts and gmp for now (ToDo; better?)
679 linkPackage loaded_in_ghci pkg
680 | name pkg `elem` ["rts", "gmp"]
683 = do putStr ("Loading package " ++ name pkg ++ " ... ")
684 -- For each obj, try obj.o and if that fails, obj.so.
685 -- Complication: all the .so's must be loaded before any of the .o's.
686 let dirs = library_dirs pkg
687 let objs = hs_libraries pkg ++ extra_libraries pkg
688 classifieds <- mapM (locateOneObj dirs) objs
690 -- Don't load the .so libs if this is a package GHCi is already
691 -- linked against, because we'll already have the .so linked in.
692 let (so_libs, obj_libs) = partition isRight classifieds
693 let sos_first | loaded_in_ghci = obj_libs
694 | otherwise = so_libs ++ obj_libs
696 mapM loadClassified sos_first
697 putStr "linking ... "
701 isRight (Right _) = True
702 isRight (Left _) = False
704 loadClassified :: LibrarySpec -> IO ()
705 loadClassified (Left obj_absolute_filename)
706 = do loadObj obj_absolute_filename
707 loadClassified (Right dll_unadorned)
708 = do maybe_errmsg <- addDLL dll_unadorned
709 if maybe_errmsg == nullPtr
711 else do str <- peekCString maybe_errmsg
712 throwDyn (CmdLineError ("can't find .o or .so/.DLL for: "
713 ++ dll_unadorned ++ " (" ++ str ++ ")" ))
715 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
717 = return (Right obj) -- we assume
718 locateOneObj (d:ds) obj
719 = do let path = d ++ '/':obj ++ ".o"
720 b <- doesFileExist path
721 if b then return (Left path) else locateOneObj ds obj
723 -----------------------------------------------------------------------------
724 -- timing & statistics
726 timeIt :: GHCi a -> GHCi a
728 = do b <- isOptionSet ShowTiming
731 else do allocs1 <- io $ getAllocations
732 time1 <- io $ getCPUTime
734 allocs2 <- io $ getAllocations
735 time2 <- io $ getCPUTime
736 io $ printTimes (allocs2 - allocs1) (time2 - time1)
739 foreign import "getAllocations" getAllocations :: IO Int
741 printTimes :: Int -> Integer -> IO ()
742 printTimes allocs psecs
743 = do let secs = (fromIntegral psecs / (10^12)) :: Float
744 secs_str = showFFloat (Just 2) secs
746 parens (text (secs_str "") <+> text "secs" <> comma <+>
747 int allocs <+> text "bytes")))
749 -----------------------------------------------------------------------------
752 foreign import revertCAFs :: IO () -- make it "safe", just in case