1 -----------------------------------------------------------------------------
2 -- $Id: InteractiveUI.hs,v 1.34 2001/02/07 10:45:43 simonmar Exp $
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2000
8 -----------------------------------------------------------------------------
10 module InteractiveUI (interactiveUI) where
12 #include "HsVersions.h"
26 import PprType {- instance Outputable Type; do not delete -}
27 import Panic ( GhcException(..) )
45 -----------------------------------------------------------------------------
48 \ _____ __ __ ____ _________________________________________________\n\
49 \(| || || (| |) GHC Interactive, version 5.00 \n\
50 \|| __ ||___|| || () For Haskell 98. \n\
51 \|| |) ||---|| || || http://www.haskell.org/ghc \n\
52 \|| || || || || (| Bug reports to: glasgow-haskell-bugs@haskell.org \n\
53 \(|___|| || || (|__|) \\\\______________________________________________________\n"
55 commands :: [(String, String -> GHCi Bool)]
57 ("add", keepGoing addModule),
58 ("cd", keepGoing changeDirectory),
59 ("help", keepGoing help),
60 ("?", keepGoing help),
61 ("load", keepGoing loadModule),
62 ("module", keepGoing setContext),
63 ("reload", keepGoing reloadModule),
64 ("set", keepGoing setOptions),
65 ("type", keepGoing typeOfExpr),
66 ("unset", keepGoing unsetOptions),
70 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
71 keepGoing a str = a str >> return False
73 shortHelpText = "use :? for help.\n"
76 \ Commands available from the prompt:\n\
78 \ <expr> evaluate <expr>\n\
79 \ :add <filename> add a module to the current set\n\
80 \ :cd <dir> change directory to <dir>\n\
81 \ :help, :? display this list of commands\n\
82 \ :load <filename> load a module (and it dependents)\n\
83 \ :module <mod> set the context for expression evaluation to <mod>\n\
84 \ :reload reload the current module set\n\
85 \ :set <option> ... set options\n\
86 \ :unset <option> ... unset options\n\
87 \ :type <expr> show the type of <expr>\n\
89 \ :!<command> run the shell command <command>\n\
91 \ Options for `:set' and `:unset':\n\
93 \ +s print timing/memory stats after each evaluation\n\
94 \ +t print type after evaluation\n\
95 \ +r revert top-level expressions after each evaluation\n\
96 \ -<flags> most GHC command line flags can also be set here\n\
97 \ (eg. -v2, -fglasgow-exts, etc.)\n\
100 interactiveUI :: CmState -> Maybe FilePath -> IO ()
101 interactiveUI cmstate mod = do
102 hPutStrLn stdout ghciWelcomeMsg
104 hSetBuffering stdout NoBuffering
106 -- link in the available packages
107 pkgs <- getPackageInfo
108 linkPackages (reverse pkgs)
110 (cmstate, ok, mods) <-
112 Nothing -> return (cmstate, True, [])
113 Just m -> cmLoadModule cmstate m
119 prel <- moduleNameToModule defaultCurrentModuleName
120 writeIORef defaultCurrentModule prel
122 dflags <- getDynFlags
124 (cmstate, maybe_stuff) <- cmGetExpr cmstate dflags False prel
125 "PrelHandle.hFlush PrelHandle.stdout"
128 Just (hv,_,_) -> writeIORef flush_stdout hv
130 (cmstate, maybe_stuff) <- cmGetExpr cmstate dflags False prel
131 "PrelHandle.hFlush PrelHandle.stdout"
134 Just (hv,_,_) -> writeIORef flush_stderr hv
136 let this_mod = case mods of
140 (unGHCi runGHCi) GHCiState{ modules = mods,
141 current_module = this_mod,
144 options = [ShowTiming],
152 dot_ghci <- io (IO.try (openFile "./.ghci" ReadMode))
155 Right hdl -> fileLoop hdl False
158 home <- io (IO.try (getEnv "HOME"))
162 dot_ghci <- io (IO.try (openFile (dir ++ "/.ghci") ReadMode))
165 Right hdl -> fileLoop hdl False
167 -- read commands from stdin
175 io $ do putStrLn "Leaving GHCi."
178 fileLoop :: Handle -> Bool -> GHCi ()
179 fileLoop hdl prompt = do
181 when prompt (io (hPutStr hdl (moduleUserString (current_module st) ++ "> ")))
182 l <- io (IO.try (hGetLine hdl))
184 Left e | isEOFError e -> return ()
185 | otherwise -> throw e
187 case remove_spaces l of
188 "" -> fileLoop hdl prompt
189 l -> do quit <- runCommand l
190 if quit then return () else fileLoop hdl prompt
193 readlineLoop :: GHCi ()
196 l <- io (readline (moduleUserString (current_module st) ++ "> "))
200 case remove_spaces l of
205 if quit then return () else readlineLoop
208 -- Top level exception handler, just prints out the exception
210 runCommand :: String -> GHCi Bool
214 -> io (putStrLn (show other_exception)) >> return False
218 PhaseFailed phase code ->
219 io ( putStrLn ("Phase " ++ phase ++ " failed (code "
220 ++ show code ++ ")"))
221 Interrupted -> io (putStrLn "Interrupted.")
222 _ -> io (putStrLn (show (dyn :: GhcException)))
227 doCommand (':' : command) = specialCommand command
228 doCommand ('-':'-':_) = return False -- comments, useful in scripts
230 = do expr_expanded <- expandExpr expr
231 -- io (putStrLn ( "Before: " ++ expr ++ "\nAfter: " ++ expr_expanded))
232 expr_ok <- timeIt (do stuff <- evalExpr expr_expanded
233 finishEvalExpr stuff)
234 when expr_ok (rememberExpr expr_expanded)
237 -- possibly print the type and revert CAFs after evaluating an expression
238 finishEvalExpr Nothing = return False
239 finishEvalExpr (Just (unqual,ty))
240 = do b <- isOptionSet ShowType
241 io (when b (printForUser stdout unqual (text "::" <+> ppr ty)))
242 b <- isOptionSet RevertCAFs
243 io (when b revertCAFs)
246 -- Returned Bool indicates whether or not the expr was successfully
247 -- parsed, renamed and typechecked.
248 evalExpr :: String -> GHCi (Maybe (PrintUnqualified,Type))
250 | null (filter (not.isSpace) expr)
253 = do st <- getGHCiState
254 dflags <- io (getDynFlags)
255 (new_cmstate, maybe_stuff) <-
256 io (cmGetExpr (cmstate st) dflags True (current_module st) expr)
257 setGHCiState st{cmstate = new_cmstate}
259 Nothing -> return Nothing
260 Just (hv, unqual, ty) -> do io (cmRunExpr hv)
262 return (Just (unqual,ty))
264 flushEverything :: GHCi ()
266 = io $ do flush_so <- readIORef flush_stdout
268 flush_se <- readIORef flush_stdout
271 specialCommand :: String -> GHCi Bool
272 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
273 specialCommand str = do
274 let (cmd,rest) = break isSpace str
275 case [ (s,f) | (s,f) <- commands, prefixMatch cmd s ] of
276 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
277 ++ shortHelpText) >> return False)
278 [(_,f)] -> f (dropWhile isSpace rest)
279 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
280 " matches multiple commands (" ++
281 foldr1 (\a b -> a ++ ',':b) (map fst cs)
282 ++ ")") >> return False)
284 noArgs c = io (hPutStrLn stdout ("command `:" ++ c ++ "' takes no arguments"))
286 -----------------------------------------------------------------------------
289 help :: String -> GHCi ()
290 help _ = io (putStr helpText)
292 addModule :: String -> GHCi ()
293 addModule _ = throwDyn (OtherError ":add not implemented")
295 setContext :: String -> GHCi ()
297 = throwDyn (OtherError "syntax: `:m <module>'")
298 setContext m | not (isUpper (head m)) || not (all isAlphaNum (tail m))
299 = throwDyn (OtherError ("strange looking module name: `" ++ m ++ "'"))
301 = do m <- io (moduleNameToModule (mkModuleName mn))
303 if (isHomeModule m && m `notElem` modules st)
304 then throwDyn (OtherError (showSDoc (quotes (ppr (moduleName m))
305 <+> text "is not currently loaded, use :load")))
306 else setGHCiState st{current_module = m}
308 moduleNameToModule :: ModuleName -> IO Module
309 moduleNameToModule mn
310 = do maybe_stuff <- findModule mn
312 Nothing -> throwDyn (OtherError ("can't find module `"
313 ++ moduleNameUserString mn ++ "'"))
314 Just (m,_) -> return m
316 changeDirectory :: String -> GHCi ()
317 changeDirectory d = io (setCurrentDirectory d)
319 loadModule :: String -> GHCi ()
320 loadModule path = timeIt (loadModule' path)
322 loadModule' path = do
323 state <- getGHCiState
324 cmstate1 <- io (cmUnload (cmstate state))
325 io (revertCAFs) -- always revert CAFs on load.
326 (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path)
328 def_mod <- io (readIORef defaultCurrentModule)
330 let new_state = state{
333 current_module = case mods of
338 setGHCiState new_state
341 | null mods = text "none."
343 punctuate comma (map (text.moduleUserString) mods)) <> text "."
346 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
348 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
350 reloadModule :: String -> GHCi ()
352 state <- getGHCiState
354 Nothing -> io (putStr "no current target\n")
356 -> do io (revertCAFs) -- always revert CAFs on reload.
357 (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path)
358 def_mod <- io (readIORef defaultCurrentModule)
360 state{cmstate=new_cmstate,
362 current_module = case mods of
367 reloadModule _ = noArgs ":reload"
369 typeOfExpr :: String -> GHCi ()
371 = do st <- getGHCiState
372 dflags <- io (getDynFlags)
373 (new_cmstate, maybe_ty) <- io (cmGetExpr (cmstate st) dflags False
374 (current_module st) str)
375 setGHCiState st{cmstate = new_cmstate}
378 Just (_, unqual, ty) -> io (printForUser stdout unqual (ppr ty))
380 quit :: String -> GHCi Bool
383 shellEscape :: String -> GHCi Bool
384 shellEscape str = io (system str >> return False)
386 ----------------------------------------------------------------------------
389 -- set options in the interpreter. Syntax is exactly the same as the
390 -- ghc command line, except that certain options aren't available (-C,
393 -- This is pretty fragile: most options won't work as expected. ToDo:
394 -- figure out which ones & disallow them.
396 setOptions :: String -> GHCi ()
398 = do st <- getGHCiState
399 let opts = options st
400 io $ putStrLn (showSDoc (
401 text "options currently set: " <>
404 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
407 = do -- first, deal with the GHCi opts (+s, +t, etc.)
409 (minus_opts, rest1) = partition isMinus opts
410 (plus_opts, rest2) = partition isPlus rest1
412 if (not (null rest2))
413 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
416 mapM setOpt plus_opts
418 -- now, the GHC flags
419 io (do -- first, static flags
420 leftovers <- processArgs static_flags minus_opts []
422 -- then, dynamic flags
423 dyn_flags <- readIORef v_InitDynFlags
424 writeIORef v_DynFlags dyn_flags
425 leftovers <- processArgs dynamic_flags leftovers []
426 dyn_flags <- readIORef v_DynFlags
427 writeIORef v_InitDynFlags dyn_flags
429 if (not (null leftovers))
430 then throwDyn (OtherError ("unrecognised flags: " ++
435 unsetOptions :: String -> GHCi ()
437 = do -- first, deal with the GHCi opts (+s, +t, etc.)
439 (minus_opts, rest1) = partition isMinus opts
440 (plus_opts, rest2) = partition isPlus rest1
442 if (not (null rest2))
443 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
446 mapM unsetOpt plus_opts
448 -- can't do GHC flags for now
449 if (not (null minus_opts))
450 then throwDyn (OtherError "can't unset GHC command-line flags")
453 isMinus ('-':s) = True
456 isPlus ('+':s) = True
460 = case strToGHCiOpt str of
461 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
462 Just o -> setOption o
465 = case strToGHCiOpt str of
466 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
467 Just o -> unsetOption o
469 strToGHCiOpt :: String -> (Maybe GHCiOption)
470 strToGHCiOpt "s" = Just ShowTiming
471 strToGHCiOpt "t" = Just ShowType
472 strToGHCiOpt "r" = Just RevertCAFs
473 strToGHCiOpt _ = Nothing
475 optToStr :: GHCiOption -> String
476 optToStr ShowTiming = "s"
477 optToStr ShowType = "t"
478 optToStr RevertCAFs = "r"
480 -----------------------------------------------------------------------------
481 -- Code to do last-expression-entered stuff. (a.k.a the $$ facility)
483 -- Take a string and replace $$s in it with the last expr, if any.
484 expandExpr :: String -> GHCi String
486 = do mle <- getLastExpr
487 return (outside mle str)
489 outside mle ('$':'$':cs)
491 Just le -> " (" ++ le ++ ") " ++ outside mle cs
492 Nothing -> outside mle cs
495 outside mle ('"':str) = '"' : inside2 mle str -- "
496 outside mle ('\'':str) = '\'' : inside1 mle str -- '
497 outside mle (c:cs) = c : outside mle cs
499 inside2 mle ('"':cs) = '"' : outside mle cs -- "
500 inside2 mle (c:cs) = c : inside2 mle cs
503 inside1 mle ('\'':cs) = '\'': outside mle cs
504 inside1 mle (c:cs) = c : inside1 mle cs
508 rememberExpr :: String -> GHCi ()
510 = do let cleaned = (clean . reverse . clean . reverse) str
511 let forget_me_not | null cleaned = Nothing
512 | otherwise = Just cleaned
513 setLastExpr forget_me_not
515 clean = dropWhile isSpace
518 -----------------------------------------------------------------------------
521 data GHCiState = GHCiState
524 current_module :: Module,
525 target :: Maybe FilePath,
527 options :: [GHCiOption],
528 last_expr :: Maybe String
532 = ShowTiming -- show time/allocs after evaluation
533 | ShowType -- show the type of expressions
534 | RevertCAFs -- revert CAFs after every evaluation
537 defaultCurrentModuleName = mkModuleName "Prelude"
538 GLOBAL_VAR(defaultCurrentModule, error "no defaultCurrentModule", Module)
540 GLOBAL_VAR(flush_stdout, error "no flush_stdout", HValue)
541 GLOBAL_VAR(flush_stderr, error "no flush_stdout", HValue)
543 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
545 instance Monad GHCi where
546 (GHCi m) >>= k = GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
547 return a = GHCi $ \s -> return (s,a)
549 getGHCiState = GHCi $ \s -> return (s,s)
550 setGHCiState s = GHCi $ \_ -> return (s,())
552 isOptionSet :: GHCiOption -> GHCi Bool
554 = do st <- getGHCiState
555 return (opt `elem` options st)
557 setOption :: GHCiOption -> GHCi ()
559 = do st <- getGHCiState
560 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
562 unsetOption :: GHCiOption -> GHCi ()
564 = do st <- getGHCiState
565 setGHCiState (st{ options = filter (/= opt) (options st) })
567 getLastExpr :: GHCi (Maybe String)
569 = do st <- getGHCiState ; return (last_expr st)
571 setLastExpr :: Maybe String -> GHCi ()
572 setLastExpr last_expr
573 = do st <- getGHCiState ; setGHCiState (st{last_expr = last_expr})
575 io m = GHCi $ \s -> m >>= \a -> return (s,a)
577 ghciHandle h (GHCi m) = GHCi $ \s ->
578 Exception.catch (m s) (\e -> unGHCi (h e) s)
579 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
580 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
582 -----------------------------------------------------------------------------
585 linkPackages :: [Package] -> IO ()
586 linkPackages pkgs = mapM_ linkPackage pkgs
588 linkPackage :: Package -> IO ()
589 -- ignore rts and gmp for now (ToDo; better?)
590 linkPackage pkg | name pkg `elem` ["rts", "gmp"] = return ()
592 putStr ("Loading package " ++ name pkg ++ " ... ")
593 let dirs = library_dirs pkg
594 let objs = map (++".o") (hs_libraries pkg ++ extra_libraries pkg)
595 mapM (linkOneObj dirs) objs
596 putStr "resolving ... "
600 linkOneObj dirs obj = do
601 filename <- findFile dirs obj
604 findFile [] obj = throwDyn (OtherError ("can't find " ++ obj))
605 findFile (d:ds) obj = do
606 let path = d ++ '/':obj
607 b <- doesFileExist path
608 if b then return path else findFile ds obj
610 -----------------------------------------------------------------------------
611 -- timing & statistics
613 timeIt :: GHCi a -> GHCi a
615 = do b <- isOptionSet ShowTiming
618 else do allocs1 <- io $ getAllocations
619 time1 <- io $ getCPUTime
621 allocs2 <- io $ getAllocations
622 time2 <- io $ getCPUTime
623 io $ printTimes (allocs2 - allocs1) (time2 - time1)
626 foreign import "getAllocations" getAllocations :: IO Int
628 printTimes :: Int -> Integer -> IO ()
629 printTimes allocs psecs
630 = do let secs = (fromIntegral psecs / (10^12)) :: Float
631 secs_str = showFFloat (Just 2) secs
633 parens (text (secs_str "") <+> text "secs" <> comma <+>
634 int allocs <+> text "bytes")))
636 -----------------------------------------------------------------------------
639 foreign import revertCAFs :: IO () -- make it "safe", just in case