1 -----------------------------------------------------------------------------
2 -- $Id: InteractiveUI.hs,v 1.70 2001/05/28 12:56:35 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(..) )
31 #ifndef mingw32_TARGET_OS
37 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
51 import PrelGHC ( unsafeCoerce# )
52 import Foreign ( nullPtr )
53 import CString ( peekCString )
55 -----------------------------------------------------------------------------
59 \ / _ \\ /\\ /\\/ __(_)\n\
60 \ / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n\
61 \/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n\
62 \\\____/\\/ /_/\\____/|_| Type :? for help.\n"
64 GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
66 builtin_commands :: [(String, String -> GHCi Bool)]
68 ("add", keepGoing addModule),
69 ("cd", keepGoing changeDirectory),
70 ("def", keepGoing defineMacro),
71 ("help", keepGoing help),
72 ("?", keepGoing help),
73 ("load", keepGoing loadModule),
74 ("module", keepGoing setContext),
75 ("reload", keepGoing reloadModule),
76 ("set", keepGoing setOptions),
77 ("type", keepGoing typeOfExpr),
78 ("unset", keepGoing unsetOptions),
79 ("undef", keepGoing undefineMacro),
83 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
84 keepGoing a str = a str >> return False
86 shortHelpText = "use :? for help.\n"
89 \ Commands available from the prompt:\n\
91 \ <stmt> evaluate/run <stmt>\n\
92 \ :cd <dir> change directory to <dir>\n\
93 \ :def <cmd> <expr> define a command :<cmd>\n\
94 \ :help, :? display this list of commands\n\
95 \ :load <filename> load a module (and its dependents)\n\
96 \ :module <mod> set the context for expression evaluation to <mod>\n\
97 \ :reload reload the current module set\n\
98 \ :set <option> ... set options\n\
99 \ :undef <cmd> undefine user-defined command :<cmd>\n\
100 \ :type <expr> show the type of <expr>\n\
101 \ :unset <option> ... unset options\n\
103 \ :!<command> run the shell command <command>\n\
105 \ Options for `:set' and `:unset':\n\
107 \ +r revert top-level expressions after each evaluation\n\
108 \ +s print timing/memory stats after each evaluation\n\
109 \ +t print type after evaluation\n\
110 \ -<flags> most GHC command line flags can also be set here\n\
111 \ (eg. -v2, -fglasgow-exts, etc.)\n\
113 --ToDo :add <filename> add a module to the current set\n\
115 interactiveUI :: CmState -> Maybe FilePath -> [LibrarySpec] -> IO ()
116 interactiveUI cmstate mod cmdline_libs = do
118 hSetBuffering stdout NoBuffering
120 -- link in the available packages
121 pkgs <- getPackageInfo
123 linkPackages cmdline_libs pkgs
125 (cmstate, ok, mods) <-
127 Nothing -> return (cmstate, True, [])
128 Just m -> cmLoadModule cmstate m
130 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
134 dflags <- getDynFlags
136 (cmstate, maybe_hval)
137 <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stderr"
139 Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ())
140 _ -> panic "interactiveUI:stderr"
142 (cmstate, maybe_hval)
143 <- cmCompileExpr cmstate dflags "IO.hFlush PrelHandle.stdout"
145 Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ())
146 _ -> panic "interactiveUI:stdout"
148 startGHCi runGHCi GHCiState{ target = mod,
158 exists <- io (doesFileExist file)
160 dir_ok <- io (checkPerms ".")
161 file_ok <- io (checkPerms file)
162 when (dir_ok && file_ok) $ do
163 either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
166 Right hdl -> fileLoop hdl False
168 -- Read in $HOME/.ghci
169 either_dir <- io (IO.try (getEnv "HOME"))
173 cwd <- io (getCurrentDirectory)
174 when (dir /= cwd) $ do
175 let file = dir ++ "/.ghci"
176 ok <- io (checkPerms file)
177 either_hdl <- io (IO.try (openFile file ReadMode))
180 Right hdl -> fileLoop hdl False
182 -- read commands from stdin
183 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
190 io $ do putStrLn "Leaving GHCi."
193 -- NOTE: We only read .ghci files if they are owned by the current user,
194 -- and aren't world writable. Otherwise, we could be accidentally
195 -- running code planted by a malicious third party.
197 -- Furthermore, We only read ./.ghci if both . and ./.ghci are
198 -- owned by the current user and aren't writable by anyone else. I
199 -- think this is sufficient: we don't need to check .. and
200 -- ../.. etc. because "." always refers to the same directory while a
201 -- process is running.
203 checkPerms :: String -> IO Bool
205 handle (\_ -> return False) $ do
206 #ifdef mingw32_TARGET_OS
209 st <- getFileStatus name
211 if fileOwner st /= me then do
212 putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
215 let mode = fileMode st
216 if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
217 || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
219 putStrLn $ "*** WARNING: " ++ name ++
220 " is writable by someone else, IGNORING!"
225 fileLoop :: Handle -> Bool -> GHCi ()
226 fileLoop hdl prompt = do
228 mod <- io (cmGetContext (cmstate st))
229 when prompt (io (putStr (mod ++ "> ")))
230 l <- io (IO.try (hGetLine hdl))
232 Left e | isEOFError e -> return ()
233 | otherwise -> throw e
235 case remove_spaces l of
236 "" -> fileLoop hdl prompt
237 l -> do quit <- runCommand l
238 if quit then return () else fileLoop hdl prompt
240 stringLoop :: [String] -> GHCi ()
241 stringLoop [] = return ()
242 stringLoop (s:ss) = do
244 case remove_spaces s of
246 l -> do quit <- runCommand l
247 if quit then return () else stringLoop ss
249 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
250 readlineLoop :: GHCi ()
253 mod <- io (cmGetContext (cmstate st))
254 l <- io (readline (mod ++ "> "))
258 case remove_spaces l of
263 if quit then return () else readlineLoop
266 -- Top level exception handler, just prints out the exception
268 runCommand :: String -> GHCi Bool
270 ghciHandle ( \exception ->
273 case fromDynamic dyn of
274 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
277 PhaseFailed phase code ->
278 io ( putStrLn ("Phase " ++ phase ++ " failed (code "
279 ++ show code ++ ")"))
280 Interrupted -> io (putStrLn "Interrupted.")
281 -- omit the location for CmdLineError
282 CmdLineError s -> io (putStrLn s)
283 other -> io (putStrLn (show (ghc_ex :: GhcException)))
285 other -> io (putStrLn ("*** Exception: " ++ show exception))
292 doCommand (':' : command) = specialCommand command
294 = do timeIt (do stuff <- runStmt stmt; finishEvalExpr stuff)
297 -- Returns True if the expr was successfully parsed, renamed and
299 runStmt :: String -> GHCi (Maybe [Name])
301 | null (filter (not.isSpace) stmt)
304 = do st <- getGHCiState
305 dflags <- io (getDynFlags)
306 let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
307 (new_cmstate, names) <- io (cmRunStmt (cmstate st) dflags' stmt)
308 setGHCiState st{cmstate = new_cmstate}
311 -- possibly print the type and revert CAFs after evaluating an expression
312 finishEvalExpr Nothing = return False
313 finishEvalExpr (Just names)
314 = do b <- isOptionSet ShowType
316 when b (mapM_ (showTypeOfName (cmstate st)) names)
318 b <- isOptionSet RevertCAFs
319 io (when b revertCAFs)
323 showTypeOfName :: CmState -> Name -> GHCi ()
324 showTypeOfName cmstate n
325 = do maybe_str <- io (cmTypeOfName cmstate n)
328 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
330 flushEverything :: GHCi ()
332 = io $ do flush_so <- readIORef flush_stdout
334 flush_se <- readIORef flush_stdout
338 specialCommand :: String -> GHCi Bool
339 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
340 specialCommand str = do
341 let (cmd,rest) = break isSpace str
342 cmds <- io (readIORef commands)
343 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
344 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
345 ++ shortHelpText) >> return False)
346 [(_,f)] -> f (dropWhile isSpace rest)
347 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
348 " matches multiple commands (" ++
349 foldr1 (\a b -> a ++ ',':b) (map fst cs)
350 ++ ")") >> return False)
352 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
354 -----------------------------------------------------------------------------
357 help :: String -> GHCi ()
358 help _ = io (putStr helpText)
360 addModule :: String -> GHCi ()
361 addModule _ = throwDyn (InstallationError ":add not implemented")
363 setContext :: String -> GHCi ()
365 = throwDyn (CmdLineError "syntax: `:m <module>'")
366 setContext m | not (isUpper (head m)) || not (all isAlphaNum (tail m))
367 = throwDyn (CmdLineError ("strange looking module name: `" ++ m ++ "'"))
369 = do st <- getGHCiState
370 new_cmstate <- io (cmSetContext (cmstate st) str)
371 setGHCiState st{cmstate=new_cmstate}
373 changeDirectory :: String -> GHCi ()
374 changeDirectory ('~':d) = do
375 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
376 io (setCurrentDirectory (tilde ++ '/':d))
377 changeDirectory d = io (setCurrentDirectory d)
379 defineMacro :: String -> GHCi ()
381 let (macro_name, definition) = break isSpace s
382 cmds <- io (readIORef commands)
384 then throwDyn (CmdLineError "invalid macro name")
386 if (macro_name `elem` map fst cmds)
387 then throwDyn (CmdLineError
388 ("command `" ++ macro_name ++ "' is already defined"))
391 -- give the expression a type signature, so we can be sure we're getting
392 -- something of the right type.
393 let new_expr = '(' : definition ++ ") :: String -> IO String"
395 -- compile the expression
397 dflags <- io (getDynFlags)
398 (new_cmstate, maybe_hv) <- io (cmCompileExpr (cmstate st) dflags new_expr)
399 setGHCiState st{cmstate = new_cmstate}
402 Just hv -> io (writeIORef commands --
403 ((macro_name, keepGoing (runMacro hv)) : cmds))
405 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
407 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
408 stringLoop (lines str)
410 undefineMacro :: String -> GHCi ()
411 undefineMacro macro_name = do
412 cmds <- io (readIORef commands)
413 if (macro_name `elem` map fst builtin_commands)
414 then throwDyn (CmdLineError
415 ("command `" ++ macro_name ++ "' cannot be undefined"))
417 if (macro_name `notElem` map fst cmds)
418 then throwDyn (CmdLineError
419 ("command `" ++ macro_name ++ "' not defined"))
421 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
423 loadModule :: String -> GHCi ()
424 loadModule path = timeIt (loadModule' path)
426 loadModule' path = do
427 state <- getGHCiState
428 dflags <- io (getDynFlags)
429 cmstate1 <- io (cmUnload (cmstate state) dflags)
430 setGHCiState state{ cmstate = cmstate1, target = Nothing }
431 io (revertCAFs) -- always revert CAFs on load.
432 (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path)
433 setGHCiState state{ cmstate = cmstate2, target = Just path }
434 modulesLoadedMsg ok mods
436 reloadModule :: String -> GHCi ()
438 state <- getGHCiState
440 Nothing -> io (putStr "no current target\n")
442 -> do io (revertCAFs) -- always revert CAFs on reload.
443 (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path)
444 setGHCiState state{ cmstate=new_cmstate }
445 modulesLoadedMsg ok mods
447 reloadModule _ = noArgs ":reload"
450 modulesLoadedMsg ok mods = do
452 | null mods = text "none."
454 punctuate comma (map text mods)) <> text "."
457 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
459 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
462 typeOfExpr :: String -> GHCi ()
464 = do st <- getGHCiState
465 dflags <- io (getDynFlags)
466 (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr (cmstate st) dflags str)
467 setGHCiState st{cmstate = new_cmstate}
470 Just tystr -> io (putStrLn tystr)
472 quit :: String -> GHCi Bool
475 shellEscape :: String -> GHCi Bool
476 shellEscape str = io (system str >> return False)
478 ----------------------------------------------------------------------------
481 -- set options in the interpreter. Syntax is exactly the same as the
482 -- ghc command line, except that certain options aren't available (-C,
485 -- This is pretty fragile: most options won't work as expected. ToDo:
486 -- figure out which ones & disallow them.
488 setOptions :: String -> GHCi ()
490 = do st <- getGHCiState
491 let opts = options st
492 io $ putStrLn (showSDoc (
493 text "options currently set: " <>
496 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
499 = do -- first, deal with the GHCi opts (+s, +t, etc.)
500 let (plus_opts, minus_opts) = partition isPlus (words str)
501 mapM setOpt plus_opts
503 -- now, the GHC flags
504 pkgs_before <- io (readIORef v_Packages)
505 leftovers <- io (processArgs static_flags minus_opts [])
506 pkgs_after <- io (readIORef v_Packages)
508 -- update things if the users wants more packages
509 when (pkgs_before /= pkgs_after) $
510 newPackages (pkgs_after \\ pkgs_before)
512 -- then, dynamic flags
514 dyn_flags <- readIORef v_InitDynFlags
515 writeIORef v_DynFlags dyn_flags
516 leftovers <- processArgs dynamic_flags leftovers []
517 dyn_flags <- readIORef v_DynFlags
518 writeIORef v_InitDynFlags dyn_flags
520 if (not (null leftovers))
521 then throwDyn (CmdLineError ("unrecognised flags: " ++
526 unsetOptions :: String -> GHCi ()
528 = do -- first, deal with the GHCi opts (+s, +t, etc.)
530 (minus_opts, rest1) = partition isMinus opts
531 (plus_opts, rest2) = partition isPlus rest1
533 if (not (null rest2))
534 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
537 mapM unsetOpt plus_opts
539 -- can't do GHC flags for now
540 if (not (null minus_opts))
541 then throwDyn (CmdLineError "can't unset GHC command-line flags")
544 isMinus ('-':s) = True
547 isPlus ('+':s) = True
551 = case strToGHCiOpt str of
552 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
553 Just o -> setOption o
556 = case strToGHCiOpt str of
557 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
558 Just o -> unsetOption o
560 strToGHCiOpt :: String -> (Maybe GHCiOption)
561 strToGHCiOpt "s" = Just ShowTiming
562 strToGHCiOpt "t" = Just ShowType
563 strToGHCiOpt "r" = Just RevertCAFs
564 strToGHCiOpt _ = Nothing
566 optToStr :: GHCiOption -> String
567 optToStr ShowTiming = "s"
568 optToStr ShowType = "t"
569 optToStr RevertCAFs = "r"
571 newPackages new_pkgs = do
572 state <- getGHCiState
573 dflags <- io (getDynFlags)
574 cmstate1 <- io (cmUnload (cmstate state) dflags)
575 setGHCiState state{ cmstate = cmstate1, target = Nothing }
578 pkgs <- getPackageInfo
579 flushPackageCache pkgs
581 new_pkg_info <- getPackageDetails new_pkgs
582 mapM_ (linkPackage False) (reverse new_pkg_info)
584 -----------------------------------------------------------------------------
587 data GHCiState = GHCiState
589 target :: Maybe FilePath,
591 options :: [GHCiOption]
595 = ShowTiming -- show time/allocs after evaluation
596 | ShowType -- show the type of expressions
597 | RevertCAFs -- revert CAFs after every evaluation
600 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
601 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
603 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
605 startGHCi :: GHCi a -> GHCiState -> IO a
606 startGHCi g state = do ref <- newIORef state; unGHCi g ref
608 instance Monad GHCi where
609 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
610 return a = GHCi $ \s -> return a
612 getGHCiState = GHCi $ \r -> readIORef r
613 setGHCiState s = GHCi $ \r -> writeIORef r s
615 isOptionSet :: GHCiOption -> GHCi Bool
617 = do st <- getGHCiState
618 return (opt `elem` options st)
620 setOption :: GHCiOption -> GHCi ()
622 = do st <- getGHCiState
623 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
625 unsetOption :: GHCiOption -> GHCi ()
627 = do st <- getGHCiState
628 setGHCiState (st{ options = filter (/= opt) (options st) })
630 io m = GHCi $ \s -> m >>= \a -> return a
632 -----------------------------------------------------------------------------
633 -- recursive exception handlers
635 -- Don't forget to unblock async exceptions in the handler, or if we're
636 -- in an exception loop (eg. let a = error a in a) the ^C exception
637 -- may never be delivered. Thanks to Marcin for pointing out the bug.
639 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
640 ghciHandle h (GHCi m) = GHCi $ \s ->
641 Exception.catch (m s)
642 (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
644 ghciUnblock :: GHCi a -> GHCi a
645 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
647 -----------------------------------------------------------------------------
650 -- Left: full path name of a .o file, including trailing .o
651 -- Right: "unadorned" name of a .DLL/.so
652 -- e.g. On unix "qt" denotes "libqt.so"
653 -- On WinDoze "burble" denotes "burble.DLL"
654 -- addDLL is platform-specific and adds the lib/.so/.DLL
655 -- prefixes plaform-dependently; we don't do that here.
657 = Either FilePath String
659 showLS (Left nm) = "(static) " ++ nm
660 showLS (Right nm) = "(dynamic) " ++ nm
662 linkPackages :: [LibrarySpec] -> [PackageConfig] -> IO ()
663 linkPackages cmdline_lib_specs pkgs
664 = do sequence_ [ linkPackage (name p `elem` loaded) p | p <- reverse pkgs ]
665 mapM_ preloadLib cmdline_lib_specs
667 -- packages that are already linked into GHCi
668 loaded = [ "concurrent", "posix", "text", "util" ]
671 = do putStr ("Loading object " ++ showLS lib_spec ++ " ... ")
674 -> do b <- doesFileExist static_ish
676 then do putStr "not found.\n"
678 else do loadObj static_ish
681 -> do maybe_errmsg <- addDLL dll_unadorned
682 if maybe_errmsg == nullPtr
683 then putStr "done.\n"
684 else do str <- peekCString maybe_errmsg
685 putStr ("failed (" ++ str ++ ")\n")
688 croak = throwDyn (CmdLineError "user specified .o/.so/.DLL could not be loaded.")
691 linkPackage :: Bool -> PackageConfig -> IO ()
692 -- ignore rts and gmp for now (ToDo; better?)
693 linkPackage loaded_in_ghci pkg
694 | name pkg `elem` ["rts", "gmp"]
697 = do putStr ("Loading package " ++ name pkg ++ " ... ")
698 -- For each obj, try obj.o and if that fails, obj.so.
699 -- Complication: all the .so's must be loaded before any of the .o's.
700 let dirs = library_dirs pkg
701 let objs = hs_libraries pkg ++ extra_libraries pkg
702 classifieds <- mapM (locateOneObj dirs) objs
704 -- Don't load the .so libs if this is a package GHCi is already
705 -- linked against, because we'll already have the .so linked in.
706 let (so_libs, obj_libs) = partition isRight classifieds
707 let sos_first | loaded_in_ghci = obj_libs
708 | otherwise = so_libs ++ obj_libs
710 mapM loadClassified sos_first
711 putStr "linking ... "
715 isRight (Right _) = True
716 isRight (Left _) = False
718 loadClassified :: LibrarySpec -> IO ()
719 loadClassified (Left obj_absolute_filename)
720 = do loadObj obj_absolute_filename
721 loadClassified (Right dll_unadorned)
722 = do maybe_errmsg <- addDLL dll_unadorned
723 if maybe_errmsg == nullPtr
725 else do str <- peekCString maybe_errmsg
726 throwDyn (CmdLineError ("can't find .o or .so/.DLL for: "
727 ++ dll_unadorned ++ " (" ++ str ++ ")" ))
729 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
731 = return (Right obj) -- we assume
732 locateOneObj (d:ds) obj
733 = do let path = d ++ '/':obj ++ ".o"
734 b <- doesFileExist path
735 if b then return (Left path) else locateOneObj ds obj
737 -----------------------------------------------------------------------------
738 -- timing & statistics
740 timeIt :: GHCi a -> GHCi a
742 = do b <- isOptionSet ShowTiming
745 else do allocs1 <- io $ getAllocations
746 time1 <- io $ getCPUTime
748 allocs2 <- io $ getAllocations
749 time2 <- io $ getCPUTime
750 io $ printTimes (allocs2 - allocs1) (time2 - time1)
753 foreign import "getAllocations" getAllocations :: IO Int
755 printTimes :: Int -> Integer -> IO ()
756 printTimes allocs psecs
757 = do let secs = (fromIntegral psecs / (10^12)) :: Float
758 secs_str = showFFloat (Just 2) secs
760 parens (text (secs_str "") <+> text "secs" <> comma <+>
761 int allocs <+> text "bytes")))
763 -----------------------------------------------------------------------------
766 foreign import revertCAFs :: IO () -- make it "safe", just in case