1 -----------------------------------------------------------------------------
2 -- $Id: InteractiveUI.hs,v 1.20 2000/11/28 14:41:54 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 Bool)]
48 ("add", keepGoing addModule),
49 ("cd", keepGoing changeDirectory),
50 ("help", keepGoing help),
51 ("?", keepGoing help),
52 ("load", keepGoing loadModule),
53 ("module", keepGoing setContext),
54 ("reload", keepGoing reloadModule),
55 ("set", keepGoing setOptions),
56 ("type", keepGoing typeOfExpr),
57 ("unset", keepGoing unsetOptions),
61 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
62 keepGoing a str = a str >> return False
64 shortHelpText = "use :? for help.\n"
67 \ Commands available from the prompt:\n\
69 \ <expr> evaluate <expr>\n\
70 \ :add <filename> add a module to the current set\n\
71 \ :cd <dir> change directory to <dir>\n\
72 \ :help, :? display this list of commands\n\
73 \ :load <filename> load a module (and it dependents)\n\
74 \ :module <mod> set the context for expression evaluation to <mod>\n\
75 \ :reload reload the current module set\n\
76 \ :set <option> ... set options\n\
77 \ :unset <option> ... unset options\n\
78 \ :type <expr> show the type of <expr>\n\
80 \ :!<command> run the shell command <command>\n\
82 \ Options for `:set' and `:unset':\n\
84 \ +s print timing/memory stats after each evaluation\n\
85 \ +t print type after evaluation\n\
86 \ -<flags> most GHC command line flags can also be set here\n\
87 \ (eg. -v2, -fglasgow-exts, etc.)\n\
90 interactiveUI :: CmState -> Maybe FilePath -> IO ()
91 interactiveUI cmstate mod = do
92 hPutStrLn stdout ghciWelcomeMsg
94 hSetBuffering stdout NoBuffering
96 -- link in the available packages
97 pkgs <- getPackageInfo
98 linkPackages (reverse pkgs)
100 (cmstate', ok, mods) <-
102 Nothing -> return (cmstate, True, [])
103 Just m -> cmLoadModule cmstate m
108 let this_mod = case mods of
109 [] -> defaultCurrentModule
112 (unGHCi uiLoop) GHCiState{ modules = mods,
113 current_module = this_mod,
116 options = [ShowTiming]}
123 l <- io (readline (moduleNameUserString (current_module st) ++ "> "))
125 l <- io (hGetLine stdin)
135 if quit then exitGHCi else uiLoop
137 exitGHCi = io $ do putStrLn "Leaving GHCi."
139 -- Top level exception handler, just prints out the exception
141 runCommand :: String -> GHCi Bool
145 -> io (putStrLn (show other_exception)) >> return False
149 PhaseFailed phase code ->
150 io ( putStrLn ("Phase " ++ phase ++ " failed (code "
151 ++ show code ++ ")"))
152 Interrupted -> io (putStrLn "Interrupted.")
153 _ -> io (putStrLn (show (dyn :: BarfKind)))
158 doCommand (':' : command) = specialCommand command
159 doCommand expr = timeIt (evalExpr expr) >> return False
162 = do st <- getGHCiState
163 dflags <- io (getDynFlags)
164 (new_cmstate, maybe_stuff) <-
165 io (cmGetExpr (cmstate st) dflags (current_module st) expr)
166 setGHCiState st{cmstate = new_cmstate}
169 Just (hv, unqual, ty)
170 -> do io (cmRunExpr hv)
171 b <- isOptionSet ShowType
172 if b then io (printForUser stdout unqual (text "::" <+> ppr ty))
176 let (mod,'.':str) = break (=='.') expr
177 case cmLookupSymbol (mkOrig varName (mkModuleName mod) (_PK_ str)) (cmstate st) of
178 Nothing -> io (putStrLn "nothing.")
183 specialCommand :: String -> GHCi Bool
184 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
185 specialCommand str = do
186 let (cmd,rest) = break isSpace str
187 case [ (s,f) | (s,f) <- commands, prefixMatch cmd s ] of
188 [] -> io (hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
189 ++ shortHelpText) >> return False)
190 [(_,f)] -> f (dropWhile isSpace rest)
191 cs -> io (hPutStrLn stdout ("prefix " ++ cmd ++
192 " matches multiple commands (" ++
193 foldr1 (\a b -> a ++ ',':b) (map fst cs)
194 ++ ")") >> return False)
196 noArgs c = io (hPutStrLn stdout ("command `:" ++ c ++ "' takes no arguments"))
198 -----------------------------------------------------------------------------
201 help :: String -> GHCi ()
202 help _ = io (putStr helpText)
204 addModule :: String -> GHCi ()
205 addModule _ = throwDyn (OtherError ":add not implemented")
207 setContext :: String -> GHCi ()
209 = throwDyn (OtherError "syntax: `:m <module>'")
210 setContext m | not (isUpper (head m)) || not (all isAlphaNum (tail m))
211 = throwDyn (OtherError ("strange looking module name: `" ++ m ++ "'"))
213 = do st <- getGHCiState
214 setGHCiState st{current_module = mkModuleName m}
216 changeDirectory :: String -> GHCi ()
217 changeDirectory d = io (setCurrentDirectory d)
219 loadModule :: String -> GHCi ()
220 loadModule path = timeIt (loadModule' path)
222 loadModule' path = do
223 state <- getGHCiState
224 cmstate1 <- io (cmUnload (cmstate state))
225 (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path)
227 let new_state = state{
230 current_module = case mods of
231 [] -> defaultCurrentModule
235 setGHCiState new_state
238 | null mods = text "none."
240 punctuate comma (map (text.moduleNameUserString) mods)) <> text "."
243 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
245 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
247 reloadModule :: String -> GHCi ()
249 state <- getGHCiState
251 Nothing -> io (putStr "no current target\n")
253 -> do (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path)
255 state{cmstate=new_cmstate,
257 current_module = case mods of
258 [] -> defaultCurrentModule
263 reloadModule _ = noArgs ":reload"
265 typeOfExpr :: String -> GHCi ()
267 = do st <- getGHCiState
268 dflags <- io (getDynFlags)
269 (st, maybe_ty) <- io (cmGetExpr (cmstate st) dflags
270 (current_module st) str)
273 Just (_, unqual, ty) -> io (printForUser stdout unqual (ppr ty))
275 quit :: String -> GHCi Bool
278 shellEscape :: String -> GHCi Bool
279 shellEscape str = io (system str >> return False)
281 ----------------------------------------------------------------------------
284 -- set options in the interpreter. Syntax is exactly the same as the
285 -- ghc command line, except that certain options aren't available (-C,
288 -- This is pretty fragile: most options won't work as expected. ToDo:
289 -- figure out which ones & disallow them.
291 setOptions :: String -> GHCi ()
293 = do st <- getGHCiState
294 let opts = options st
295 io $ putStrLn (showSDoc (
296 text "options currently set: " <>
299 else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
302 = do -- first, deal with the GHCi opts (+s, +t, etc.)
304 (minus_opts, rest1) = partition isMinus opts
305 (plus_opts, rest2) = partition isPlus rest1
307 if (not (null rest2))
308 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
311 mapM setOpt plus_opts
313 -- now, the GHC flags
314 io (do leftovers <- processArgs static_flags minus_opts []
315 dyn_flags <- readIORef v_InitDynFlags
316 writeIORef v_DynFlags dyn_flags
317 leftovers <- processArgs dynamic_flags leftovers []
318 dyn_flags <- readIORef v_DynFlags
319 writeIORef v_InitDynFlags dyn_flags
320 if (not (null leftovers))
321 then throwDyn (OtherError ("unrecognised flags: " ++
326 unsetOptions :: String -> GHCi ()
328 = do -- first, deal with the GHCi opts (+s, +t, etc.)
330 (minus_opts, rest1) = partition isMinus opts
331 (plus_opts, rest2) = partition isPlus rest1
333 if (not (null rest2))
334 then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
337 mapM unsetOpt plus_opts
339 -- can't do GHC flags for now
340 if (not (null minus_opts))
341 then throwDyn (OtherError "can't unset GHC command-line flags")
344 isMinus ('-':s) = True
347 isPlus ('+':s) = True
351 = case strToGHCiOpt str of
352 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
353 Just o -> setOption o
356 = case strToGHCiOpt str of
357 Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
358 Just o -> unsetOption o
360 strToGHCiOpt :: String -> (Maybe GHCiOption)
361 strToGHCiOpt "s" = Just ShowTiming
362 strToGHCiOpt "t" = Just ShowType
363 strToGHCiOpt _ = Nothing
365 optToStr :: GHCiOption -> String
366 optToStr ShowTiming = "s"
367 optToStr ShowType = "t"
369 -----------------------------------------------------------------------------
372 data GHCiState = GHCiState
374 modules :: [ModuleName],
375 current_module :: ModuleName,
376 target :: Maybe FilePath,
378 options :: [GHCiOption]
381 data GHCiOption = ShowTiming | ShowType deriving Eq
383 defaultCurrentModule = mkModuleName "Prelude"
385 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
387 instance Monad GHCi where
388 (GHCi m) >>= k = GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
389 return a = GHCi $ \s -> return (s,a)
391 getGHCiState = GHCi $ \s -> return (s,s)
392 setGHCiState s = GHCi $ \_ -> return (s,())
394 isOptionSet :: GHCiOption -> GHCi Bool
396 = do st <- getGHCiState
397 return (opt `elem` options st)
399 setOption :: GHCiOption -> GHCi ()
401 = do st <- getGHCiState
402 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
404 unsetOption :: GHCiOption -> GHCi ()
406 = do st <- getGHCiState
407 setGHCiState (st{ options = filter (/= opt) (options st) })
409 io m = GHCi $ \s -> m >>= \a -> return (s,a)
411 ghciHandle h (GHCi m) = GHCi $ \s ->
412 Exception.catch (m s) (\e -> unGHCi (h e) s)
413 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
414 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
416 -----------------------------------------------------------------------------
419 linkPackages :: [Package] -> IO ()
420 linkPackages pkgs = mapM_ linkPackage pkgs
422 linkPackage :: Package -> IO ()
423 -- ignore rts and gmp for now (ToDo; better?)
424 linkPackage pkg | name pkg `elem` ["rts", "gmp"] = return ()
426 putStr ("Loading package " ++ name pkg ++ " ... ")
427 let dirs = library_dirs pkg
428 let objs = map (++".o") (hs_libraries pkg ++ extra_libraries pkg)
429 mapM (linkOneObj dirs) objs
430 putStr "resolving ... "
434 linkOneObj dirs obj = do
435 filename <- findFile dirs obj
438 findFile [] obj = throwDyn (OtherError ("can't find " ++ obj))
439 findFile (d:ds) obj = do
440 let path = d ++ '/':obj
441 b <- doesFileExist path
442 if b then return path else findFile ds obj
444 -----------------------------------------------------------------------------
445 -- timing & statistics
447 timeIt :: GHCi a -> GHCi a
449 = do b <- isOptionSet ShowTiming
452 else do allocs1 <- io $ getAllocations
453 time1 <- io $ getCPUTime
455 allocs2 <- io $ getAllocations
456 time2 <- io $ getCPUTime
457 io $ printTimes (allocs2 - allocs1) (time2 - time1)
460 foreign import "getAllocations" getAllocations :: IO Int
462 printTimes :: Int -> Integer -> IO ()
463 printTimes allocs psecs
464 = do let secs = (fromIntegral psecs / (10^12)) :: Float
465 secs_str = showFFloat (Just 2) secs
467 parens (text (secs_str "") <+> text "secs" <> comma <+>
468 int allocs <+> text "bytes")))