1 -----------------------------------------------------------------------------
2 -- $Id: InteractiveUI.hs,v 1.18 2000/11/27 12:52:36 sewardj Exp $
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2000
8 -----------------------------------------------------------------------------
10 module InteractiveUI (interactiveUI) where
12 #include "HsVersions.h"
36 -----------------------------------------------------------------------------
39 \ _____ __ __ ____ _________________________________________________\n\
40 \(| || || (| |) GHC Interactive, version 5.00 \n\
41 \|| __ ||___|| || () For Haskell 98. \n\
42 \|| |) ||---|| || || http://www.haskell.org/ghc \n\
43 \|| || || || || (| Bug reports to: glasgow-haskell-bugs@haskell.org \n\
44 \(|___|| || || (|__|) \\\\______________________________________________________\n"
46 commands :: [(String, String -> GHCi ())]
49 ("cd", changeDirectory),
53 ("module", setContext),
54 ("reload", reloadModule),
57 ("unset", unsetOptions),
61 shortHelpText = "use :? for help.\n"
64 \ Commands available from the prompt:\n\
66 \ <expr> evaluate <expr>\n\
67 \ :add <filename> add a module to the current set\n\
68 \ :cd <dir> change directory to <dir>\n\
69 \ :help, :? display this list of commands\n\
70 \ :load <filename> load a module (and it dependents)\n\
71 \ :module <mod> set the context for expression evaluation to <mod>\n\
72 \ :reload reload the current module set\n\
73 \ :set <option> ... set options\n\
74 \ :unset <option> ... unset options\n\
75 \ :type <expr> show the type of <expr>\n\
77 \ :!<command> run the shell command <command>\n\
79 \ Options for `:set' and `:unset':\n\
81 \ +s print timing/memory stats after each evaluation\n\
82 \ +t print type after evaluation\n\
83 \ -<flags> most GHC command line flags can also be set here\n\
84 \ (eg. -v2, -fglasgow-exts, etc.)\n\
87 interactiveUI :: CmState -> Maybe FilePath -> IO ()
88 interactiveUI cmstate mod = do
89 hPutStrLn stdout ghciWelcomeMsg
91 hSetBuffering stdout NoBuffering
93 -- link in the available packages
94 pkgs <- getPackageInfo
95 linkPackages (reverse pkgs)
97 (cmstate', ok, mods) <-
99 Nothing -> return (cmstate, True, [])
100 Just m -> cmLoadModule cmstate m
105 let this_mod = case mods of
106 [] -> defaultCurrentModule
109 (unGHCi uiLoop) GHCiState{ modules = mods,
110 current_module = this_mod,
113 options = [ShowTiming]}
120 l <- io (readline (moduleNameUserString (current_module st) ++ "> "))
122 l <- io (hGetLine stdin)
134 exitGHCi = io $ do putStrLn "Leaving GHCi."; exitWith ExitSuccess
136 -- Top level exception handler, just prints out the exception
139 ghciHandle ( \other_exception ->io (putStrLn (show other_exception) )) $
142 PhaseFailed phase code ->
143 io ( putStrLn ("Phase " ++ phase ++ " failed (code "
144 ++ show code ++ ")"))
145 Interrupted -> io (putStrLn "Interrupted.")
146 _ -> io (putStrLn (show (dyn :: BarfKind)))
150 doCommand (':' : command) = specialCommand command
151 doCommand expr = timeIt (evalExpr expr)
154 = do st <- getGHCiState
155 dflags <- io (getDynFlags)
156 (new_cmstate, maybe_stuff) <-
157 io (cmGetExpr (cmstate st) dflags (current_module st) expr)
158 setGHCiState st{cmstate = new_cmstate}
161 Just (hv, unqual, ty)
162 -> do io (cmRunExpr hv)
163 b <- isOptionSet ShowType
164 if b then io (printForUser stdout unqual (text "::" <+> ppr ty))
168 let (mod,'.':str) = break (=='.') expr
169 case cmLookupSymbol (mkOrig varName (mkModuleName mod) (_PK_ str)) (cmstate st) of
170 Nothing -> io (putStrLn "nothing.")
175 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
176 specialCommand str = do
177 let (cmd,rest) = break isSpace str
178 case [ (s,f) | (s,f) <- commands, prefixMatch cmd s ] of
179 [] -> io $ hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
181 [(_,f)] -> f (dropWhile isSpace rest)
182 cs -> io $ hPutStrLn stdout ("prefix " ++ cmd ++
183 " matches multiple commands (" ++
184 foldr1 (\a b -> a ++ ',':b) (map fst cs)
187 noArgs c = io (hPutStrLn stdout ("command `:" ++ c ++ "' takes no arguments"))
189 -----------------------------------------------------------------------------
192 help :: String -> GHCi ()
193 help _ = io (putStr helpText)
195 addModule :: String -> GHCi ()
196 addModule _ = throwDyn (OtherError ":add not implemented")
198 setContext :: String -> GHCi ()
200 = throwDyn (OtherError "syntax: `:m <module>'")
201 setContext m | not (isUpper (head m)) || not (all isAlphaNum (tail m))
202 = throwDyn (OtherError ("strange looking module name: `" ++ m ++ "'"))
204 = do st <- getGHCiState
205 setGHCiState st{current_module = mkModuleName m}
207 changeDirectory :: String -> GHCi ()
208 changeDirectory = io . setCurrentDirectory
210 loadModule :: String -> GHCi ()
211 loadModule path = timeIt (loadModule' path)
213 loadModule' path = do
214 state <- getGHCiState
215 cmstate1 <- io (cmUnload (cmstate state))
216 (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path)
218 let new_state = state{
221 current_module = case mods of
222 [] -> defaultCurrentModule
226 setGHCiState new_state
229 | null mods = text "none."
231 punctuate comma (map (text.moduleNameUserString) mods)) <> text "."
234 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
236 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
238 reloadModule :: String -> GHCi ()
240 state <- getGHCiState
242 Nothing -> io (putStr "no current target\n")
244 -> do (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path)
246 state{cmstate=new_cmstate,
248 current_module = case mods of
249 [] -> defaultCurrentModule
254 reloadModule _ = noArgs ":reload"
256 typeOfExpr :: String -> GHCi ()
258 = do st <- getGHCiState
259 dflags <- io (getDynFlags)
260 (st, maybe_ty) <- io (cmGetExpr (cmstate st) dflags
261 (current_module st) str)
264 Just (_, unqual, ty) -> io (printForUser stdout unqual (ppr ty))
266 quit :: String -> GHCi ()
269 shellEscape :: String -> GHCi ()
270 shellEscape str = io (system str >> return ())
272 ----------------------------------------------------------------------------
275 -- set options in the interpreter. Syntax is exactly the same as the
276 -- ghc command line, except that certain options aren't available (-C,
279 -- This is pretty fragile: most options won't work as expected. ToDo:
280 -- figure out which ones & disallow them.
282 setOptions :: String -> GHCi ()
284 = do st <- getGHCiState
285 let opts = options st
286 io $ putStrLn (showSDoc (
287 text "options currently set: " <>
290 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
293 = do -- first, deal with the GHCi opts (+s, +t, etc.)
295 (minus_opts, rest1) = partition isMinus opts
296 (plus_opts, rest2) = partition isPlus rest1
298 if (not (null rest2))
299 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
302 mapM setOpt plus_opts
304 -- now, the GHC flags
305 io (do leftovers <- processArgs static_flags minus_opts []
306 dyn_flags <- readIORef v_InitDynFlags
307 writeIORef v_DynFlags dyn_flags
308 leftovers <- processArgs dynamic_flags leftovers []
309 dyn_flags <- readIORef v_DynFlags
310 writeIORef v_InitDynFlags dyn_flags
311 if (not (null leftovers))
312 then throwDyn (OtherError ("unrecognised flags: " ++
317 unsetOptions :: String -> GHCi ()
319 = do -- first, deal with the GHCi opts (+s, +t, etc.)
321 (minus_opts, rest1) = partition isMinus opts
322 (plus_opts, rest2) = partition isPlus rest1
324 if (not (null rest2))
325 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
328 mapM unsetOpt plus_opts
330 -- can't do GHC flags for now
331 if (not (null minus_opts))
332 then throwDyn (OtherError "can't unset GHC command-line flags")
335 isMinus ('-':s) = True
338 isPlus ('+':s) = True
342 = case strToGHCiOpt str of
343 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
344 Just o -> setOption o
347 = case strToGHCiOpt str of
348 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
349 Just o -> unsetOption o
351 strToGHCiOpt :: String -> (Maybe GHCiOption)
352 strToGHCiOpt "s" = Just ShowTiming
353 strToGHCiOpt "t" = Just ShowType
354 strToGHCiOpt _ = Nothing
356 optToStr :: GHCiOption -> String
357 optToStr ShowTiming = "s"
358 optToStr ShowType = "t"
360 -----------------------------------------------------------------------------
363 data GHCiState = GHCiState
365 modules :: [ModuleName],
366 current_module :: ModuleName,
367 target :: Maybe FilePath,
369 options :: [GHCiOption]
372 data GHCiOption = ShowTiming | ShowType deriving Eq
374 defaultCurrentModule = mkModuleName "Prelude"
376 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
378 instance Monad GHCi where
379 (GHCi m) >>= k = GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
380 return a = GHCi $ \s -> return (s,a)
382 getGHCiState = GHCi $ \s -> return (s,s)
383 setGHCiState s = GHCi $ \_ -> return (s,())
385 isOptionSet :: GHCiOption -> GHCi Bool
387 = do st <- getGHCiState
388 return (opt `elem` options st)
390 setOption :: GHCiOption -> GHCi ()
392 = do st <- getGHCiState
393 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
395 unsetOption :: GHCiOption -> GHCi ()
397 = do st <- getGHCiState
398 setGHCiState (st{ options = filter (/= opt) (options st) })
400 io m = GHCi $ \s -> m >>= \a -> return (s,a)
402 ghciHandle h (GHCi m) = GHCi $ \s ->
403 Exception.catch (m s) (\e -> unGHCi (h e) s)
404 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
405 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
407 -----------------------------------------------------------------------------
410 linkPackages :: [Package] -> IO ()
411 linkPackages pkgs = mapM_ linkPackage pkgs
413 linkPackage :: Package -> IO ()
414 -- ignore rts and gmp for now (ToDo; better?)
415 linkPackage pkg | name pkg `elem` ["rts", "gmp"] = return ()
417 putStr ("Loading package " ++ name pkg ++ " ... ")
418 let dirs = library_dirs pkg
419 let objs = map (++".o") (hs_libraries pkg ++ extra_libraries pkg)
420 mapM (linkOneObj dirs) objs
421 putStr "resolving ... "
425 linkOneObj dirs obj = do
426 filename <- findFile dirs obj
429 findFile [] obj = throwDyn (OtherError ("can't find " ++ obj))
430 findFile (d:ds) obj = do
431 let path = d ++ '/':obj
432 b <- doesFileExist path
433 if b then return path else findFile ds obj
435 -----------------------------------------------------------------------------
436 -- timing & statistics
438 timeIt :: GHCi a -> GHCi a
440 = do b <- isOptionSet ShowTiming
443 else do allocs1 <- io $ getAllocations
444 time1 <- io $ getCPUTime
446 allocs2 <- io $ getAllocations
447 time2 <- io $ getCPUTime
448 io $ printTimes (allocs2 - allocs1) (time2 - time1)
451 foreign import "getAllocations" getAllocations :: IO Int
453 printTimes :: Int -> Integer -> IO ()
454 printTimes allocs psecs
455 = do let secs = (fromIntegral psecs / (10^12)) :: Float
456 secs_str = showFFloat (Just 2) secs
458 parens (text (secs_str "") <+> text "secs" <> comma <+>
459 int allocs <+> text "bytes")))