1 -----------------------------------------------------------------------------
2 -- $Id: InteractiveUI.hs,v 1.17 2000/11/27 12:10:01 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, mod) <- io (cmLoadModule (cmstate state) path)
245 setGHCiState state{cmstate=new_cmstate}
246 reloadModule _ = noArgs ":reload"
248 typeOfExpr :: String -> GHCi ()
250 = do st <- getGHCiState
251 dflags <- io (getDynFlags)
252 (st, maybe_ty) <- io (cmGetExpr (cmstate st) dflags
253 (current_module st) str)
256 Just (_, unqual, ty) -> io (printForUser stdout unqual (ppr ty))
258 quit :: String -> GHCi ()
261 shellEscape :: String -> GHCi ()
262 shellEscape str = io (system str >> return ())
264 ----------------------------------------------------------------------------
267 -- set options in the interpreter. Syntax is exactly the same as the
268 -- ghc command line, except that certain options aren't available (-C,
271 -- This is pretty fragile: most options won't work as expected. ToDo:
272 -- figure out which ones & disallow them.
274 setOptions :: String -> GHCi ()
276 = do st <- getGHCiState
277 let opts = options st
278 io $ putStrLn (showSDoc (
279 text "options currently set: " <>
282 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
285 = do -- first, deal with the GHCi opts (+s, +t, etc.)
287 (minus_opts, rest1) = partition isMinus opts
288 (plus_opts, rest2) = partition isPlus rest1
290 if (not (null rest2))
291 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
294 mapM setOpt plus_opts
296 -- now, the GHC flags
297 io (do leftovers <- processArgs static_flags minus_opts []
298 dyn_flags <- readIORef v_InitDynFlags
299 writeIORef v_DynFlags dyn_flags
300 leftovers <- processArgs dynamic_flags leftovers []
301 dyn_flags <- readIORef v_DynFlags
302 writeIORef v_InitDynFlags dyn_flags
303 if (not (null leftovers))
304 then throwDyn (OtherError ("unrecognised flags: " ++
309 unsetOptions :: String -> GHCi ()
311 = do -- first, deal with the GHCi opts (+s, +t, etc.)
313 (minus_opts, rest1) = partition isMinus opts
314 (plus_opts, rest2) = partition isPlus rest1
316 if (not (null rest2))
317 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
320 mapM unsetOpt plus_opts
322 -- can't do GHC flags for now
323 if (not (null minus_opts))
324 then throwDyn (OtherError "can't unset GHC command-line flags")
327 isMinus ('-':s) = True
330 isPlus ('+':s) = True
334 = case strToGHCiOpt str of
335 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
336 Just o -> setOption o
339 = case strToGHCiOpt str of
340 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
341 Just o -> unsetOption o
343 strToGHCiOpt :: String -> (Maybe GHCiOption)
344 strToGHCiOpt "s" = Just ShowTiming
345 strToGHCiOpt "t" = Just ShowType
346 strToGHCiOpt _ = Nothing
348 optToStr :: GHCiOption -> String
349 optToStr ShowTiming = "s"
350 optToStr ShowType = "t"
352 -----------------------------------------------------------------------------
355 data GHCiState = GHCiState
357 modules :: [ModuleName],
358 current_module :: ModuleName,
359 target :: Maybe FilePath,
361 options :: [GHCiOption]
364 data GHCiOption = ShowTiming | ShowType deriving Eq
366 defaultCurrentModule = mkModuleName "Prelude"
368 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
370 instance Monad GHCi where
371 (GHCi m) >>= k = GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
372 return a = GHCi $ \s -> return (s,a)
374 getGHCiState = GHCi $ \s -> return (s,s)
375 setGHCiState s = GHCi $ \_ -> return (s,())
377 isOptionSet :: GHCiOption -> GHCi Bool
379 = do st <- getGHCiState
380 return (opt `elem` options st)
382 setOption :: GHCiOption -> GHCi ()
384 = do st <- getGHCiState
385 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
387 unsetOption :: GHCiOption -> GHCi ()
389 = do st <- getGHCiState
390 setGHCiState (st{ options = filter (/= opt) (options st) })
392 io m = GHCi $ \s -> m >>= \a -> return (s,a)
394 ghciHandle h (GHCi m) = GHCi $ \s ->
395 Exception.catch (m s) (\e -> unGHCi (h e) s)
396 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
397 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
399 -----------------------------------------------------------------------------
402 linkPackages :: [Package] -> IO ()
403 linkPackages pkgs = mapM_ linkPackage pkgs
405 linkPackage :: Package -> IO ()
406 -- ignore rts and gmp for now (ToDo; better?)
407 linkPackage pkg | name pkg `elem` ["rts", "gmp"] = return ()
409 putStr ("Loading package " ++ name pkg ++ " ... ")
410 let dirs = library_dirs pkg
411 let objs = map (++".o") (hs_libraries pkg ++ extra_libraries pkg)
412 mapM (linkOneObj dirs) objs
413 putStr "resolving ... "
417 linkOneObj dirs obj = do
418 filename <- findFile dirs obj
421 findFile [] obj = throwDyn (OtherError ("can't find " ++ obj))
422 findFile (d:ds) obj = do
423 let path = d ++ '/':obj
424 b <- doesFileExist path
425 if b then return path else findFile ds obj
427 -----------------------------------------------------------------------------
428 -- timing & statistics
430 timeIt :: GHCi a -> GHCi a
432 = do b <- isOptionSet ShowTiming
435 else do allocs1 <- io $ getAllocations
436 time1 <- io $ getCPUTime
438 allocs2 <- io $ getAllocations
439 time2 <- io $ getCPUTime
440 io $ printTimes (allocs2 - allocs1) (time2 - time1)
443 foreign import "getAllocations" getAllocations :: IO Int
445 printTimes :: Int -> Integer -> IO ()
446 printTimes allocs psecs
447 = do let secs = (fromIntegral psecs / (10^12)) :: Float
448 secs_str = showFFloat (Just 2) secs
450 parens (text (secs_str "") <+> text "secs" <> comma <+>
451 int allocs <+> text "bytes")))