1 -----------------------------------------------------------------------------
2 -- $Id: InteractiveUI.hs,v 1.62 2001/04/24 13:05:51 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 "HsVersions.h"
15 #if HAVE_READLINE_4_2 == 1 || HAVE_READLINE_4 == 1
31 import CmdLineOpts ( DynFlag(..), dopt_unset )
32 import Panic ( GhcException(..) )
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 it 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 <name> undefine user-defined command :<name>\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 (reverse pkgs)
125 (cmstate, ok, mods) <-
127 Nothing -> return (cmstate, True, [])
128 Just m -> cmLoadModule cmstate m
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 (unGHCi runGHCi) GHCiState{ target = mod,
157 dot_ghci <- io (IO.try (openFile "./.ghci" ReadMode))
160 Right hdl -> fileLoop hdl False
163 home <- io (IO.try (getEnv "HOME"))
167 cwd <- io (getCurrentDirectory)
168 when (dir /= cwd) $ do
169 dot_ghci <- io (IO.try (openFile (dir ++ "/.ghci") ReadMode))
172 Right hdl -> fileLoop hdl False
174 -- read commands from stdin
182 io $ do putStrLn "Leaving GHCi."
185 fileLoop :: Handle -> Bool -> GHCi ()
186 fileLoop hdl prompt = do
188 mod <- io (cmGetContext (cmstate st))
189 when prompt (io (hPutStr hdl (mod ++ "> ")))
190 l <- io (IO.try (hGetLine hdl))
192 Left e | isEOFError e -> return ()
193 | otherwise -> throw e
195 case remove_spaces l of
196 "" -> fileLoop hdl prompt
197 l -> do quit <- runCommand l
198 if quit then return () else fileLoop hdl prompt
200 stringLoop :: [String] -> GHCi ()
201 stringLoop [] = return ()
202 stringLoop (s:ss) = do
204 case remove_spaces s of
206 l -> do quit <- runCommand l
207 if quit then return () else stringLoop ss
210 readlineLoop :: GHCi ()
213 mod <- io (cmGetContext (cmstate st))
214 l <- io (readline (mod ++ "> "))
218 case remove_spaces l of
223 if quit then return () else readlineLoop
226 -- Top level exception handler, just prints out the exception
228 runCommand :: String -> GHCi Bool
230 ghciHandle ( \exception ->
233 case fromDynamic dyn of
234 Nothing -> io (putStrLn ("*** Exception: (unknown)"))
237 PhaseFailed phase code ->
238 io ( putStrLn ("Phase " ++ phase ++ " failed (code "
239 ++ show code ++ ")"))
240 Interrupted -> io (putStrLn "Interrupted.")
241 -- omit the location for CmdLineError
242 CmdLineError s -> io (putStrLn s)
243 other -> io (putStrLn (show (ghc_ex :: GhcException)))
245 other -> io (putStrLn ("*** Exception: " ++ show exception))
252 doCommand (':' : command) = specialCommand command
254 = do timeIt (do stuff <- runStmt stmt; finishEvalExpr stuff)
257 -- Returns True if the expr was successfully parsed, renamed and
259 runStmt :: String -> GHCi (Maybe [Name])
261 | null (filter (not.isSpace) stmt)
264 = do st <- getGHCiState
265 dflags <- io (getDynFlags)
266 let dflags' = dopt_unset dflags Opt_WarnUnusedBinds
267 (new_cmstate, names) <- io (cmRunStmt (cmstate st) dflags' stmt)
268 setGHCiState st{cmstate = new_cmstate}
271 -- possibly print the type and revert CAFs after evaluating an expression
272 finishEvalExpr Nothing = return False
273 finishEvalExpr (Just names)
274 = do b <- isOptionSet ShowType
276 when b (mapM_ (showTypeOfName (cmstate st)) names)
278 b <- isOptionSet RevertCAFs
279 io (when b revertCAFs)
283 showTypeOfName :: CmState -> Name -> GHCi ()
284 showTypeOfName cmstate n
285 = do maybe_str <- io (cmTypeOfName cmstate n)
288 Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str))
290 flushEverything :: GHCi ()
292 = io $ do flush_so <- readIORef flush_stdout
294 flush_se <- readIORef flush_stdout
298 specialCommand :: String -> GHCi Bool
299 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
300 specialCommand str = do
301 let (cmd,rest) = break isSpace str
302 cmds <- io (readIORef commands)
303 case [ (s,f) | (s,f) <- cmds, prefixMatch cmd s ] of
304 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
305 ++ shortHelpText) >> return False)
306 [(_,f)] -> f (dropWhile isSpace rest)
307 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
308 " matches multiple commands (" ++
309 foldr1 (\a b -> a ++ ',':b) (map fst cs)
310 ++ ")") >> return False)
312 noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
314 -----------------------------------------------------------------------------
317 help :: String -> GHCi ()
318 help _ = io (putStr helpText)
320 addModule :: String -> GHCi ()
321 addModule _ = throwDyn (InstallationError ":add not implemented")
323 setContext :: String -> GHCi ()
325 = throwDyn (CmdLineError "syntax: `:m <module>'")
326 setContext m | not (isUpper (head m)) || not (all isAlphaNum (tail m))
327 = throwDyn (CmdLineError ("strange looking module name: `" ++ m ++ "'"))
329 = do st <- getGHCiState
330 new_cmstate <- io (cmSetContext (cmstate st) str)
331 setGHCiState st{cmstate=new_cmstate}
333 changeDirectory :: String -> GHCi ()
334 changeDirectory ('~':d) = do
335 tilde <- io (getEnv "HOME") -- will fail if HOME not defined
336 io (setCurrentDirectory (tilde ++ '/':d))
337 changeDirectory d = io (setCurrentDirectory d)
339 defineMacro :: String -> GHCi ()
341 let (macro_name, definition) = break isSpace s
342 cmds <- io (readIORef commands)
344 then throwDyn (CmdLineError "invalid macro name")
346 if (macro_name `elem` map fst cmds)
347 then throwDyn (CmdLineError
348 ("command `" ++ macro_name ++ "' is already defined"))
351 -- give the expression a type signature, so we can be sure we're getting
352 -- something of the right type.
353 let new_expr = '(' : definition ++ ") :: String -> IO String"
355 -- compile the expression
357 dflags <- io (getDynFlags)
358 (new_cmstate, maybe_hv) <- io (cmCompileExpr (cmstate st) dflags new_expr)
359 setGHCiState st{cmstate = new_cmstate}
362 Just hv -> io (writeIORef commands --
363 ((macro_name, keepGoing (runMacro hv)) : cmds))
365 runMacro :: HValue{-String -> IO String-} -> String -> GHCi ()
367 str <- io ((unsafeCoerce# fun :: String -> IO String) s)
368 stringLoop (lines str)
370 undefineMacro :: String -> GHCi ()
371 undefineMacro macro_name = do
372 cmds <- io (readIORef commands)
373 if (macro_name `elem` map fst builtin_commands)
374 then throwDyn (CmdLineError
375 ("command `" ++ macro_name ++ "' cannot be undefined"))
377 if (macro_name `notElem` map fst cmds)
378 then throwDyn (CmdLineError
379 ("command `" ++ macro_name ++ "' not defined"))
381 io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
383 loadModule :: String -> GHCi ()
384 loadModule path = timeIt (loadModule' path)
386 loadModule' path = do
387 state <- getGHCiState
388 cmstate1 <- io (cmUnload (cmstate state))
389 io (revertCAFs) -- always revert CAFs on load.
390 (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path)
391 let new_state = state{ cmstate = cmstate2,
394 setGHCiState new_state
395 modulesLoadedMsg ok mods
397 reloadModule :: String -> GHCi ()
399 state <- getGHCiState
401 Nothing -> io (putStr "no current target\n")
403 -> do io (revertCAFs) -- always revert CAFs on reload.
404 (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path)
405 setGHCiState state{ cmstate=new_cmstate }
406 modulesLoadedMsg ok mods
408 reloadModule _ = noArgs ":reload"
411 modulesLoadedMsg ok mods = do
413 | null mods = text "none."
415 punctuate comma (map text mods)) <> text "."
418 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
420 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
423 typeOfExpr :: String -> GHCi ()
425 = do st <- getGHCiState
426 dflags <- io (getDynFlags)
427 (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr (cmstate st) dflags str)
428 setGHCiState st{cmstate = new_cmstate}
431 Just tystr -> io (putStrLn tystr)
433 quit :: String -> GHCi Bool
436 shellEscape :: String -> GHCi Bool
437 shellEscape str = io (system str >> return False)
439 ----------------------------------------------------------------------------
442 -- set options in the interpreter. Syntax is exactly the same as the
443 -- ghc command line, except that certain options aren't available (-C,
446 -- This is pretty fragile: most options won't work as expected. ToDo:
447 -- figure out which ones & disallow them.
449 setOptions :: String -> GHCi ()
451 = do st <- getGHCiState
452 let opts = options st
453 io $ putStrLn (showSDoc (
454 text "options currently set: " <>
457 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
460 = do -- first, deal with the GHCi opts (+s, +t, etc.)
462 (minus_opts, rest1) = partition isMinus opts
463 (plus_opts, rest2) = partition isPlus rest1
465 if (not (null rest2))
466 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
469 mapM setOpt plus_opts
471 -- now, the GHC flags
472 io (do -- first, static flags
473 leftovers <- processArgs static_flags minus_opts []
475 -- then, dynamic flags
476 dyn_flags <- readIORef v_InitDynFlags
477 writeIORef v_DynFlags dyn_flags
478 leftovers <- processArgs dynamic_flags leftovers []
479 dyn_flags <- readIORef v_DynFlags
480 writeIORef v_InitDynFlags dyn_flags
482 if (not (null leftovers))
483 then throwDyn (CmdLineError ("unrecognised flags: " ++
488 unsetOptions :: String -> GHCi ()
490 = do -- first, deal with the GHCi opts (+s, +t, etc.)
492 (minus_opts, rest1) = partition isMinus opts
493 (plus_opts, rest2) = partition isPlus rest1
495 if (not (null rest2))
496 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
499 mapM unsetOpt plus_opts
501 -- can't do GHC flags for now
502 if (not (null minus_opts))
503 then throwDyn (CmdLineError "can't unset GHC command-line flags")
506 isMinus ('-':s) = True
509 isPlus ('+':s) = True
513 = case strToGHCiOpt str of
514 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
515 Just o -> setOption o
518 = case strToGHCiOpt str of
519 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
520 Just o -> unsetOption o
522 strToGHCiOpt :: String -> (Maybe GHCiOption)
523 strToGHCiOpt "s" = Just ShowTiming
524 strToGHCiOpt "t" = Just ShowType
525 strToGHCiOpt "r" = Just RevertCAFs
526 strToGHCiOpt _ = Nothing
528 optToStr :: GHCiOption -> String
529 optToStr ShowTiming = "s"
530 optToStr ShowType = "t"
531 optToStr RevertCAFs = "r"
533 -----------------------------------------------------------------------------
536 data GHCiState = GHCiState
538 target :: Maybe FilePath,
540 options :: [GHCiOption]
544 = ShowTiming -- show time/allocs after evaluation
545 | ShowType -- show the type of expressions
546 | RevertCAFs -- revert CAFs after every evaluation
549 GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ())
550 GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ())
552 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
554 instance Monad GHCi where
555 (GHCi m) >>= k = GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
556 return a = GHCi $ \s -> return (s,a)
558 getGHCiState = GHCi $ \s -> return (s,s)
559 setGHCiState s = GHCi $ \_ -> return (s,())
561 isOptionSet :: GHCiOption -> GHCi Bool
563 = do st <- getGHCiState
564 return (opt `elem` options st)
566 setOption :: GHCiOption -> GHCi ()
568 = do st <- getGHCiState
569 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
571 unsetOption :: GHCiOption -> GHCi ()
573 = do st <- getGHCiState
574 setGHCiState (st{ options = filter (/= opt) (options st) })
576 io m = GHCi $ \s -> m >>= \a -> return (s,a)
578 -----------------------------------------------------------------------------
579 -- recursive exception handlers
581 -- Don't forget to unblock async exceptions in the handler, or if we're
582 -- in an exception loop (eg. let a = error a in a) the ^C exception
583 -- may never be delivered. Thanks to Marcin for pointing out the bug.
585 ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
586 ghciHandle h (GHCi m) = GHCi $ \s ->
587 Exception.catch (m s)
588 (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
590 ghciUnblock :: GHCi a -> GHCi a
591 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
593 -----------------------------------------------------------------------------
596 -- Left: full path name of a .o file, including trailing .o
597 -- Right: "unadorned" name of a .DLL/.so
598 -- e.g. On unix "qt" denotes "libqt.so"
599 -- On WinDoze "burble" denotes "burble.DLL"
600 -- addDLL is platform-specific and adds the lib/.so/.DLL
601 -- prefixes plaform-dependently; we don't do that here.
603 = Either FilePath String
605 showLS (Left nm) = "(static) " ++ nm
606 showLS (Right nm) = "(dynamic) " ++ nm
608 linkPackages :: [LibrarySpec] -> [PackageConfig] -> IO ()
609 linkPackages cmdline_lib_specs pkgs
610 = do mapM_ linkPackage pkgs
611 mapM_ preloadLib cmdline_lib_specs
614 = do putStr ("Loading object " ++ showLS lib_spec ++ " ... ")
617 -> do b <- doesFileExist static_ish
619 then do putStr "not found.\n"
621 else do loadObj static_ish
624 -> do maybe_errmsg <- addDLL dll_unadorned
625 if maybe_errmsg == nullPtr
626 then putStr "done.\n"
627 else do str <- peekCString maybe_errmsg
628 putStr ("failed (" ++ str ++ ")\n")
631 croak = throwDyn (CmdLineError "user specified .o/.so/.DLL could not be loaded.")
634 linkPackage :: PackageConfig -> IO ()
635 -- ignore rts and gmp for now (ToDo; better?)
637 | name pkg `elem` ["rts", "gmp"]
640 = do putStr ("Loading package " ++ name pkg ++ " ... ")
641 -- For each obj, try obj.o and if that fails, obj.so.
642 -- Complication: all the .so's must be loaded before any of the .o's.
643 let dirs = library_dirs pkg
644 let objs = hs_libraries pkg ++ extra_libraries pkg
645 classifieds <- mapM (locateOneObj dirs) objs
646 let sos_first = filter isRight classifieds
647 ++ filter (not.isRight) classifieds
648 mapM loadClassified sos_first
649 putStr "linking ... "
653 isRight (Right _) = True
654 isRight (Left _) = False
656 loadClassified :: LibrarySpec -> IO ()
657 loadClassified (Left obj_absolute_filename)
658 = do loadObj obj_absolute_filename
659 loadClassified (Right dll_unadorned)
660 = do maybe_errmsg <- addDLL dll_unadorned
661 if maybe_errmsg == nullPtr
663 else do str <- peekCString maybe_errmsg
664 throwDyn (CmdLineError ("can't find .o or .so/.DLL for: "
665 ++ dll_unadorned ++ " (" ++ str ++ ")" ))
667 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
669 = return (Right obj) -- we assume
670 locateOneObj (d:ds) obj
671 = do let path = d ++ '/':obj ++ ".o"
672 b <- doesFileExist path
673 if b then return (Left path) else locateOneObj ds obj
675 -----------------------------------------------------------------------------
676 -- timing & statistics
678 timeIt :: GHCi a -> GHCi a
680 = do b <- isOptionSet ShowTiming
683 else do allocs1 <- io $ getAllocations
684 time1 <- io $ getCPUTime
686 allocs2 <- io $ getAllocations
687 time2 <- io $ getCPUTime
688 io $ printTimes (allocs2 - allocs1) (time2 - time1)
691 foreign import "getAllocations" getAllocations :: IO Int
693 printTimes :: Int -> Integer -> IO ()
694 printTimes allocs psecs
695 = do let secs = (fromIntegral psecs / (10^12)) :: Float
696 secs_str = showFFloat (Just 2) secs
698 parens (text (secs_str "") <+> text "secs" <> comma <+>
699 int allocs <+> text "bytes")))
701 -----------------------------------------------------------------------------
704 foreign import revertCAFs :: IO () -- make it "safe", just in case