1 -----------------------------------------------------------------------------
2 -- $Id: InteractiveUI.hs,v 1.26 2001/01/16 17:09:43 sewardj Exp $
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2000
8 -----------------------------------------------------------------------------
10 module InteractiveUI (interactiveUI) where
12 #include "HsVersions.h"
22 import PprType {- instance Outputable Type; do not delete -}
23 import Panic ( GhcException(..) )
41 -----------------------------------------------------------------------------
44 \ _____ __ __ ____ _________________________________________________\n\
45 \(| || || (| |) GHC Interactive, version 5.00 \n\
46 \|| __ ||___|| || () For Haskell 98. \n\
47 \|| |) ||---|| || || http://www.haskell.org/ghc \n\
48 \|| || || || || (| Bug reports to: glasgow-haskell-bugs@haskell.org \n\
49 \(|___|| || || (|__|) \\\\______________________________________________________\n"
51 commands :: [(String, String -> GHCi Bool)]
53 ("add", keepGoing addModule),
54 ("cd", keepGoing changeDirectory),
55 ("help", keepGoing help),
56 ("?", keepGoing help),
57 ("load", keepGoing loadModule),
58 ("module", keepGoing setContext),
59 ("reload", keepGoing reloadModule),
60 ("set", keepGoing setOptions),
61 ("type", keepGoing typeOfExpr),
62 ("unset", keepGoing unsetOptions),
66 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
67 keepGoing a str = a str >> return False
69 shortHelpText = "use :? for help.\n"
72 \ Commands available from the prompt:\n\
74 \ <expr> evaluate <expr>\n\
75 \ :add <filename> add a module to the current set\n\
76 \ :cd <dir> change directory to <dir>\n\
77 \ :help, :? display this list of commands\n\
78 \ :load <filename> load a module (and it dependents)\n\
79 \ :module <mod> set the context for expression evaluation to <mod>\n\
80 \ :reload reload the current module set\n\
81 \ :set <option> ... set options\n\
82 \ :unset <option> ... unset options\n\
83 \ :type <expr> show the type of <expr>\n\
85 \ :!<command> run the shell command <command>\n\
87 \ Options for `:set' and `:unset':\n\
89 \ +s print timing/memory stats after each evaluation\n\
90 \ +t print type after evaluation\n\
91 \ -<flags> most GHC command line flags can also be set here\n\
92 \ (eg. -v2, -fglasgow-exts, etc.)\n\
95 interactiveUI :: CmState -> Maybe FilePath -> IO ()
96 interactiveUI cmstate mod = do
97 hPutStrLn stdout ghciWelcomeMsg
99 hSetBuffering stdout NoBuffering
101 -- link in the available packages
102 pkgs <- getPackageInfo
103 linkPackages (reverse pkgs)
105 (cmstate', ok, mods) <-
107 Nothing -> return (cmstate, True, [])
108 Just m -> cmLoadModule cmstate m
113 let this_mod = case mods of
114 [] -> defaultCurrentModule
117 (unGHCi uiLoop) GHCiState{ modules = mods,
118 current_module = this_mod,
121 options = [ShowTiming],
129 l <- io (readline (moduleNameUserString (current_module st) ++ "> "))
131 l_ok <- io (hGetLine stdin)
142 if quit then exitGHCi else uiLoop
144 exitGHCi = io $ do putStrLn "Leaving GHCi."
146 -- Top level exception handler, just prints out the exception
148 runCommand :: String -> GHCi Bool
152 -> io (putStrLn (show other_exception)) >> return False
156 PhaseFailed phase code ->
157 io ( putStrLn ("Phase " ++ phase ++ " failed (code "
158 ++ show code ++ ")"))
159 Interrupted -> io (putStrLn "Interrupted.")
160 _ -> io (putStrLn (show (dyn :: GhcException)))
165 doCommand (':' : command) = specialCommand command
167 = do expr_expanded <- expandExpr expr
168 -- io (putStrLn ( "Before: " ++ expr ++ "\nAfter: " ++ expr_expanded))
169 expr_ok <- timeIt (do ok <- evalExpr expr_expanded
170 when ok (evalExpr "PrelIO.putChar \'\\n\'" >> return ())
172 when expr_ok (rememberExpr expr_expanded)
175 -- Returned Bool indicates whether or not the expr was successfully
176 -- parsed, renamed and typechecked.
177 evalExpr :: String -> GHCi Bool
179 | null (filter (not.isSpace) expr)
182 = do st <- getGHCiState
183 dflags <- io (getDynFlags)
184 (new_cmstate, maybe_stuff) <-
185 io (cmGetExpr (cmstate st) dflags (current_module st) expr True)
186 setGHCiState st{cmstate = new_cmstate}
188 Nothing -> return False
189 Just (hv, unqual, ty)
190 -> do io (cmRunExpr hv)
191 b <- isOptionSet ShowType
192 io (when b (printForUser stdout unqual (text "::" <+> ppr ty)))
196 let (mod,'.':str) = break (=='.') expr
197 case cmLookupSymbol (mkOrig varName (mkModuleName mod) (_PK_ str)) (cmstate st) of
198 Nothing -> io (putStrLn "nothing.")
203 specialCommand :: String -> GHCi Bool
204 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
205 specialCommand str = do
206 let (cmd,rest) = break isSpace str
207 case [ (s,f) | (s,f) <- commands, prefixMatch cmd s ] of
208 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
209 ++ shortHelpText) >> return False)
210 [(_,f)] -> f (dropWhile isSpace rest)
211 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
212 " matches multiple commands (" ++
213 foldr1 (\a b -> a ++ ',':b) (map fst cs)
214 ++ ")") >> return False)
216 noArgs c = io (hPutStrLn stdout ("command `:" ++ c ++ "' takes no arguments"))
218 -----------------------------------------------------------------------------
221 help :: String -> GHCi ()
222 help _ = io (putStr helpText)
224 addModule :: String -> GHCi ()
225 addModule _ = throwDyn (OtherError ":add not implemented")
227 setContext :: String -> GHCi ()
229 = throwDyn (OtherError "syntax: `:m <module>'")
230 setContext m | not (isUpper (head m)) || not (all isAlphaNum (tail m))
231 = throwDyn (OtherError ("strange looking module name: `" ++ m ++ "'"))
233 = do st <- getGHCiState
234 setGHCiState st{current_module = mkModuleName m}
236 changeDirectory :: String -> GHCi ()
237 changeDirectory d = io (setCurrentDirectory d)
239 loadModule :: String -> GHCi ()
240 loadModule path = timeIt (loadModule' path)
242 loadModule' path = do
243 state <- getGHCiState
244 cmstate1 <- io (cmUnload (cmstate state))
245 (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path)
247 let new_state = state{
250 current_module = case mods of
251 [] -> defaultCurrentModule
255 setGHCiState new_state
258 | null mods = text "none."
260 punctuate comma (map (text.moduleNameUserString) mods)) <> text "."
263 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
265 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
267 reloadModule :: String -> GHCi ()
269 state <- getGHCiState
271 Nothing -> io (putStr "no current target\n")
273 -> do (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path)
275 state{cmstate=new_cmstate,
277 current_module = case mods of
278 [] -> defaultCurrentModule
283 reloadModule _ = noArgs ":reload"
285 typeOfExpr :: String -> GHCi ()
287 = do st <- getGHCiState
288 dflags <- io (getDynFlags)
289 (st, maybe_ty) <- io (cmGetExpr (cmstate st) dflags
290 (current_module st) str False)
293 Just (_, unqual, ty) -> io (printForUser stdout unqual (ppr ty))
295 quit :: String -> GHCi Bool
298 shellEscape :: String -> GHCi Bool
299 shellEscape str = io (system str >> return False)
301 ----------------------------------------------------------------------------
304 -- set options in the interpreter. Syntax is exactly the same as the
305 -- ghc command line, except that certain options aren't available (-C,
308 -- This is pretty fragile: most options won't work as expected. ToDo:
309 -- figure out which ones & disallow them.
311 setOptions :: String -> GHCi ()
313 = do st <- getGHCiState
314 let opts = options st
315 io $ putStrLn (showSDoc (
316 text "options currently set: " <>
319 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
322 = do -- first, deal with the GHCi opts (+s, +t, etc.)
324 (minus_opts, rest1) = partition isMinus opts
325 (plus_opts, rest2) = partition isPlus rest1
327 if (not (null rest2))
328 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
331 mapM setOpt plus_opts
333 -- now, the GHC flags
334 io (do leftovers <- processArgs static_flags minus_opts []
335 dyn_flags <- readIORef v_InitDynFlags
336 writeIORef v_DynFlags dyn_flags
337 leftovers <- processArgs dynamic_flags leftovers []
338 dyn_flags <- readIORef v_DynFlags
339 writeIORef v_InitDynFlags dyn_flags
340 if (not (null leftovers))
341 then throwDyn (OtherError ("unrecognised flags: " ++
346 unsetOptions :: String -> GHCi ()
348 = do -- first, deal with the GHCi opts (+s, +t, etc.)
350 (minus_opts, rest1) = partition isMinus opts
351 (plus_opts, rest2) = partition isPlus rest1
353 if (not (null rest2))
354 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
357 mapM unsetOpt plus_opts
359 -- can't do GHC flags for now
360 if (not (null minus_opts))
361 then throwDyn (OtherError "can't unset GHC command-line flags")
364 isMinus ('-':s) = True
367 isPlus ('+':s) = True
371 = case strToGHCiOpt str of
372 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
373 Just o -> setOption o
376 = case strToGHCiOpt str of
377 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
378 Just o -> unsetOption o
380 strToGHCiOpt :: String -> (Maybe GHCiOption)
381 strToGHCiOpt "s" = Just ShowTiming
382 strToGHCiOpt "t" = Just ShowType
383 strToGHCiOpt _ = Nothing
385 optToStr :: GHCiOption -> String
386 optToStr ShowTiming = "s"
387 optToStr ShowType = "t"
390 -----------------------------------------------------------------------------
391 -- Code to do last-expression-entered stuff. (a.k.a the $$ facility)
393 -- Take a string and replace $$s in it with the last expr, if any.
394 expandExpr :: String -> GHCi String
396 = do mle <- getLastExpr
397 return (outside mle str)
399 outside mle ('$':'$':cs)
401 Just le -> " (" ++ le ++ ") " ++ outside mle cs
402 Nothing -> outside mle cs
405 outside mle ('"':str) = '"' : inside2 mle str -- "
406 outside mle ('\'':str) = '\'' : inside1 mle str -- '
407 outside mle (c:cs) = c : outside mle cs
409 inside2 mle ('"':cs) = '"' : outside mle cs -- "
410 inside2 mle (c:cs) = c : inside2 mle cs
413 inside1 mle ('\'':cs) = '\'': outside mle cs
414 inside1 mle (c:cs) = c : inside1 mle cs
418 rememberExpr :: String -> GHCi ()
420 = do let cleaned = (clean . reverse . clean . reverse) str
421 let forget_me_not | null cleaned = Nothing
422 | otherwise = Just cleaned
423 setLastExpr forget_me_not
425 clean = dropWhile isSpace
428 -----------------------------------------------------------------------------
431 data GHCiState = GHCiState
433 modules :: [ModuleName],
434 current_module :: ModuleName,
435 target :: Maybe FilePath,
437 options :: [GHCiOption],
438 last_expr :: Maybe String
441 data GHCiOption = ShowTiming | ShowType deriving Eq
443 defaultCurrentModule = mkModuleName "Prelude"
445 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
447 instance Monad GHCi where
448 (GHCi m) >>= k = GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
449 return a = GHCi $ \s -> return (s,a)
451 getGHCiState = GHCi $ \s -> return (s,s)
452 setGHCiState s = GHCi $ \_ -> return (s,())
454 isOptionSet :: GHCiOption -> GHCi Bool
456 = do st <- getGHCiState
457 return (opt `elem` options st)
459 setOption :: GHCiOption -> GHCi ()
461 = do st <- getGHCiState
462 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
464 unsetOption :: GHCiOption -> GHCi ()
466 = do st <- getGHCiState
467 setGHCiState (st{ options = filter (/= opt) (options st) })
469 getLastExpr :: GHCi (Maybe String)
471 = do st <- getGHCiState ; return (last_expr st)
473 setLastExpr :: Maybe String -> GHCi ()
474 setLastExpr last_expr
475 = do st <- getGHCiState ; setGHCiState (st{last_expr = last_expr})
477 io m = GHCi $ \s -> m >>= \a -> return (s,a)
479 ghciHandle h (GHCi m) = GHCi $ \s ->
480 Exception.catch (m s) (\e -> unGHCi (h e) s)
481 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
482 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
484 -----------------------------------------------------------------------------
487 linkPackages :: [Package] -> IO ()
488 linkPackages pkgs = mapM_ linkPackage pkgs
490 linkPackage :: Package -> IO ()
491 -- ignore rts and gmp for now (ToDo; better?)
492 linkPackage pkg | name pkg `elem` ["rts", "gmp"] = return ()
494 putStr ("Loading package " ++ name pkg ++ " ... ")
495 let dirs = library_dirs pkg
496 let objs = map (++".o") (hs_libraries pkg ++ extra_libraries pkg)
497 mapM (linkOneObj dirs) objs
498 putStr "resolving ... "
502 linkOneObj dirs obj = do
503 filename <- findFile dirs obj
506 findFile [] obj = throwDyn (OtherError ("can't find " ++ obj))
507 findFile (d:ds) obj = do
508 let path = d ++ '/':obj
509 b <- doesFileExist path
510 if b then return path else findFile ds obj
512 -----------------------------------------------------------------------------
513 -- timing & statistics
515 timeIt :: GHCi a -> GHCi a
517 = do b <- isOptionSet ShowTiming
520 else do allocs1 <- io $ getAllocations
521 time1 <- io $ getCPUTime
523 allocs2 <- io $ getAllocations
524 time2 <- io $ getCPUTime
525 io $ printTimes (allocs2 - allocs1) (time2 - time1)
528 foreign import "getAllocations" getAllocations :: IO Int
530 printTimes :: Int -> Integer -> IO ()
531 printTimes allocs psecs
532 = do let secs = (fromIntegral psecs / (10^12)) :: Float
533 secs_str = showFFloat (Just 2) secs
535 parens (text (secs_str "") <+> text "secs" <> comma <+>
536 int allocs <+> text "bytes")))