1 -----------------------------------------------------------------------------
2 -- $Id: InteractiveUI.hs,v 1.24 2000/12/18 12:43:04 sewardj Exp $
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2000
8 -----------------------------------------------------------------------------
10 module InteractiveUI (interactiveUI) where
12 #include "HsVersions.h"
23 import PprType {- instance Outputable Type; do not delete -}
24 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]}
128 l <- io (readline (moduleNameUserString (current_module st) ++ "> "))
130 l_ok <- io (hGetLine stdin)
141 if quit then exitGHCi else uiLoop
143 exitGHCi = io $ do putStrLn "Leaving GHCi."
145 -- Top level exception handler, just prints out the exception
147 runCommand :: String -> GHCi Bool
151 -> io (putStrLn (show other_exception)) >> return False
155 PhaseFailed phase code ->
156 io ( putStrLn ("Phase " ++ phase ++ " failed (code "
157 ++ show code ++ ")"))
158 Interrupted -> io (putStrLn "Interrupted.")
159 _ -> io (putStrLn (show (dyn :: GhcException)))
164 doCommand (':' : command) = specialCommand command
165 doCommand expr = timeIt (evalExpr expr) >> return False
168 = do st <- getGHCiState
169 dflags <- io (getDynFlags)
170 (new_cmstate, maybe_stuff) <-
171 io (cmGetExpr (cmstate st) dflags (current_module st) expr)
172 setGHCiState st{cmstate = new_cmstate}
175 Just (hv, unqual, ty)
176 -> do io (cmRunExpr hv)
177 b <- isOptionSet ShowType
178 if b then io (printForUser stdout unqual (text "::" <+> ppr ty))
182 let (mod,'.':str) = break (=='.') expr
183 case cmLookupSymbol (mkOrig varName (mkModuleName mod) (_PK_ str)) (cmstate st) of
184 Nothing -> io (putStrLn "nothing.")
189 specialCommand :: String -> GHCi Bool
190 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
191 specialCommand str = do
192 let (cmd,rest) = break isSpace str
193 case [ (s,f) | (s,f) <- commands, prefixMatch cmd s ] of
194 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
195 ++ shortHelpText) >> return False)
196 [(_,f)] -> f (dropWhile isSpace rest)
197 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
198 " matches multiple commands (" ++
199 foldr1 (\a b -> a ++ ',':b) (map fst cs)
200 ++ ")") >> return False)
202 noArgs c = io (hPutStrLn stdout ("command `:" ++ c ++ "' takes no arguments"))
204 -----------------------------------------------------------------------------
207 help :: String -> GHCi ()
208 help _ = io (putStr helpText)
210 addModule :: String -> GHCi ()
211 addModule _ = throwDyn (OtherError ":add not implemented")
213 setContext :: String -> GHCi ()
215 = throwDyn (OtherError "syntax: `:m <module>'")
216 setContext m | not (isUpper (head m)) || not (all isAlphaNum (tail m))
217 = throwDyn (OtherError ("strange looking module name: `" ++ m ++ "'"))
219 = do st <- getGHCiState
220 setGHCiState st{current_module = mkModuleName m}
222 changeDirectory :: String -> GHCi ()
223 changeDirectory d = io (setCurrentDirectory d)
225 loadModule :: String -> GHCi ()
226 loadModule path = timeIt (loadModule' path)
228 loadModule' path = do
229 state <- getGHCiState
230 cmstate1 <- io (cmUnload (cmstate state))
231 (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path)
233 let new_state = state{
236 current_module = case mods of
237 [] -> defaultCurrentModule
241 setGHCiState new_state
244 | null mods = text "none."
246 punctuate comma (map (text.moduleNameUserString) mods)) <> text "."
249 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
251 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
253 reloadModule :: String -> GHCi ()
255 state <- getGHCiState
257 Nothing -> io (putStr "no current target\n")
259 -> do (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path)
261 state{cmstate=new_cmstate,
263 current_module = case mods of
264 [] -> defaultCurrentModule
269 reloadModule _ = noArgs ":reload"
271 typeOfExpr :: String -> GHCi ()
273 = do st <- getGHCiState
274 dflags <- io (getDynFlags)
275 (st, maybe_ty) <- io (cmGetExpr (cmstate st) dflags
276 (current_module st) str)
279 Just (_, unqual, ty) -> io (printForUser stdout unqual (ppr ty))
281 quit :: String -> GHCi Bool
284 shellEscape :: String -> GHCi Bool
285 shellEscape str = io (system str >> return False)
287 ----------------------------------------------------------------------------
290 -- set options in the interpreter. Syntax is exactly the same as the
291 -- ghc command line, except that certain options aren't available (-C,
294 -- This is pretty fragile: most options won't work as expected. ToDo:
295 -- figure out which ones & disallow them.
297 setOptions :: String -> GHCi ()
299 = do st <- getGHCiState
300 let opts = options st
301 io $ putStrLn (showSDoc (
302 text "options currently set: " <>
305 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
308 = do -- first, deal with the GHCi opts (+s, +t, etc.)
310 (minus_opts, rest1) = partition isMinus opts
311 (plus_opts, rest2) = partition isPlus rest1
313 if (not (null rest2))
314 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
317 mapM setOpt plus_opts
319 -- now, the GHC flags
320 io (do leftovers <- processArgs static_flags minus_opts []
321 dyn_flags <- readIORef v_InitDynFlags
322 writeIORef v_DynFlags dyn_flags
323 leftovers <- processArgs dynamic_flags leftovers []
324 dyn_flags <- readIORef v_DynFlags
325 writeIORef v_InitDynFlags dyn_flags
326 if (not (null leftovers))
327 then throwDyn (OtherError ("unrecognised flags: " ++
332 unsetOptions :: String -> GHCi ()
334 = do -- first, deal with the GHCi opts (+s, +t, etc.)
336 (minus_opts, rest1) = partition isMinus opts
337 (plus_opts, rest2) = partition isPlus rest1
339 if (not (null rest2))
340 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
343 mapM unsetOpt plus_opts
345 -- can't do GHC flags for now
346 if (not (null minus_opts))
347 then throwDyn (OtherError "can't unset GHC command-line flags")
350 isMinus ('-':s) = True
353 isPlus ('+':s) = True
357 = case strToGHCiOpt str of
358 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
359 Just o -> setOption o
362 = case strToGHCiOpt str of
363 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
364 Just o -> unsetOption o
366 strToGHCiOpt :: String -> (Maybe GHCiOption)
367 strToGHCiOpt "s" = Just ShowTiming
368 strToGHCiOpt "t" = Just ShowType
369 strToGHCiOpt _ = Nothing
371 optToStr :: GHCiOption -> String
372 optToStr ShowTiming = "s"
373 optToStr ShowType = "t"
375 -----------------------------------------------------------------------------
378 data GHCiState = GHCiState
380 modules :: [ModuleName],
381 current_module :: ModuleName,
382 target :: Maybe FilePath,
384 options :: [GHCiOption]
387 data GHCiOption = ShowTiming | ShowType deriving Eq
389 defaultCurrentModule = mkModuleName "Prelude"
391 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
393 instance Monad GHCi where
394 (GHCi m) >>= k = GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
395 return a = GHCi $ \s -> return (s,a)
397 getGHCiState = GHCi $ \s -> return (s,s)
398 setGHCiState s = GHCi $ \_ -> return (s,())
400 isOptionSet :: GHCiOption -> GHCi Bool
402 = do st <- getGHCiState
403 return (opt `elem` options st)
405 setOption :: GHCiOption -> GHCi ()
407 = do st <- getGHCiState
408 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
410 unsetOption :: GHCiOption -> GHCi ()
412 = do st <- getGHCiState
413 setGHCiState (st{ options = filter (/= opt) (options st) })
415 io m = GHCi $ \s -> m >>= \a -> return (s,a)
417 ghciHandle h (GHCi m) = GHCi $ \s ->
418 Exception.catch (m s) (\e -> unGHCi (h e) s)
419 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
420 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
422 -----------------------------------------------------------------------------
425 linkPackages :: [Package] -> IO ()
426 linkPackages pkgs = mapM_ linkPackage pkgs
428 linkPackage :: Package -> IO ()
429 -- ignore rts and gmp for now (ToDo; better?)
430 linkPackage pkg | name pkg `elem` ["rts", "gmp"] = return ()
432 putStr ("Loading package " ++ name pkg ++ " ... ")
433 let dirs = library_dirs pkg
434 let objs = map (++".o") (hs_libraries pkg ++ extra_libraries pkg)
435 mapM (linkOneObj dirs) objs
436 putStr "resolving ... "
440 linkOneObj dirs obj = do
441 filename <- findFile dirs obj
444 findFile [] obj = throwDyn (OtherError ("can't find " ++ obj))
445 findFile (d:ds) obj = do
446 let path = d ++ '/':obj
447 b <- doesFileExist path
448 if b then return path else findFile ds obj
450 -----------------------------------------------------------------------------
451 -- timing & statistics
453 timeIt :: GHCi a -> GHCi a
455 = do b <- isOptionSet ShowTiming
458 else do allocs1 <- io $ getAllocations
459 time1 <- io $ getCPUTime
461 allocs2 <- io $ getAllocations
462 time2 <- io $ getCPUTime
463 io $ printTimes (allocs2 - allocs1) (time2 - time1)
466 foreign import "getAllocations" getAllocations :: IO Int
468 printTimes :: Int -> Integer -> IO ()
469 printTimes allocs psecs
470 = do let secs = (fromIntegral psecs / (10^12)) :: Float
471 secs_str = showFFloat (Just 2) secs
473 parens (text (secs_str "") <+> text "secs" <> comma <+>
474 int allocs <+> text "bytes")))