1 -----------------------------------------------------------------------------
2 -- $Id: InteractiveUI.hs,v 1.14 2000/11/22 17:51:16 simonmar Exp $
4 -- GHC Interactive User Interface
6 -- (c) The GHC Team 2000
8 -----------------------------------------------------------------------------
10 module InteractiveUI (interactiveUI) where
12 #include "HsVersions.h"
33 -----------------------------------------------------------------------------
36 \ _____ __ __ ____ _________________________________________________\n\
37 \(| || || (| |) GHC Interactive, version 5.00 \n\
38 \|| __ ||___|| || () For Haskell 98. \n\
39 \|| |) ||---|| || || http://www.haskell.org/ghc \n\
40 \|| || || || || (| Bug reports to: glasgow-haskell-bugs@haskell.org \n\
41 \(|___|| || || (|__|) \\\\______________________________________________________\n"
43 commands :: [(String, String -> GHCi ())]
46 ("cd", changeDirectory),
50 ("module", setContext),
51 ("reload", reloadModule),
57 shortHelpText = "use :? for help.\n"
60 \ <expr> evaluate <expr>\n\
61 \ :add <filename> add a module to the current set\n\
62 \ :cd <dir> change directory to <dir>\n\
63 \ :help, :? display this list of commands\n\
64 \ :load <filename> load a module (and it dependents)\n\
65 \ :module <mod> set the context for expression evaluation to <mod>\n\
66 \ :reload reload the current module set\n\
67 \ :set <option> ... set options\n\
68 \ :type <expr> show the type of <expr>\n\
70 \ :!<command> run the shell command <command>\n\
73 interactiveUI :: CmState -> [ModuleName] -> IO ()
74 interactiveUI st mods = do
75 hPutStrLn stdout ghciWelcomeMsg
77 hSetBuffering stdout NoBuffering
79 -- link in the available packages
80 pkgs <- getPackageInfo
81 linkPackages (reverse pkgs)
86 let this_mod = case mods of
87 [] -> defaultCurrentModule
90 (unGHCi uiLoop) GHCiState{ modules = mods,
91 current_module = this_mod,
100 l <- io (readline (moduleNameUserString (current_module st) ++ "> "))
102 l <- io (hGetLine stdin)
114 exitGHCi = io $ do putStrLn "Leaving GHCi."; exitWith ExitSuccess
116 -- Top level exception handler, just prints out the exception
119 ghciHandle ( \other_exception ->io (putStrLn (show other_exception) )) $
122 PhaseFailed phase code ->
123 io ( putStrLn ("Phase " ++ phase ++ " failed (code "
124 ++ show code ++ ")"))
125 Interrupted -> io (putStrLn "Interrupted.")
126 _ -> io (putStrLn (show (dyn :: BarfKind)))
130 doCommand (':' : command) = specialCommand command
132 = do st <- getGHCiState
133 dflags <- io (getDynFlags)
134 (new_cmstate, maybe_hvalue) <-
135 io (cmGetExpr (cmstate st) dflags (current_module st) expr)
136 setGHCiState st{cmstate = new_cmstate}
139 Just hv -> io (cmRunExpr hv)
141 let (mod,'.':str) = break (=='.') expr
142 case cmLookupSymbol (mkOrig varName (mkModuleName mod) (_PK_ str)) (cmstate st) of
143 Nothing -> io (putStrLn "nothing.")
148 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
149 specialCommand str = do
150 let (cmd,rest) = break isSpace str
151 case [ (s,f) | (s,f) <- commands, prefixMatch cmd s ] of
152 [] -> io $ hPutStr stdout ("unknown command `:" ++ cmd ++ "'\n"
154 [(_,f)] -> f (dropWhile isSpace rest)
155 cs -> io $ hPutStrLn stdout ("prefix " ++ cmd ++
156 " matches multiple commands (" ++
157 foldr1 (\a b -> a ++ ',':b) (map fst cs)
160 noArgs c = io (hPutStrLn stdout ("command `:" ++ c ++ "' takes no arguments"))
162 -----------------------------------------------------------------------------
165 help :: String -> GHCi ()
166 help _ = io (putStr helpText)
168 addModule :: String -> GHCi ()
169 addModule _ = throwDyn (OtherError ":add not implemented")
171 setContext :: String -> GHCi ()
173 = throwDyn (OtherError "syntax: `:m <module>'")
174 setContext m | not (isUpper (head m)) || not (all isAlphaNum (tail m))
175 = throwDyn (OtherError ("strange looking module name: `" ++ m ++ "'"))
177 = do st <- getGHCiState
178 setGHCiState st{current_module = mkModuleName m}
180 changeDirectory :: String -> GHCi ()
181 changeDirectory = io . setCurrentDirectory
183 loadModule :: String -> GHCi ()
185 state <- getGHCiState
186 cmstate1 <- io (cmUnload (cmstate state))
187 (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path)
189 let new_state = GHCiState {
192 current_module = case mods of
193 [] -> defaultCurrentModule
197 setGHCiState new_state
200 | null mods = text "none."
202 punctuate comma (map (text.moduleNameUserString) mods)) <> text "."
205 io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
207 io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
209 reloadModule :: String -> GHCi ()
211 state <- getGHCiState
213 Nothing -> io (putStr "no current target\n")
215 -> do (new_cmstate, ok, mod) <- io (cmLoadModule (cmstate state) path)
216 setGHCiState state{cmstate=new_cmstate}
217 reloadModule _ = noArgs ":reload"
219 -- set options in the interpreter. Syntax is exactly the same as the
220 -- ghc command line, except that certain options aren't available (-C,
223 -- This is pretty fragile: most options won't work as expected. ToDo:
224 -- figure out which ones & disallow them.
225 setOptions :: String -> GHCi ()
227 io (do leftovers <- processArgs static_flags (words str) []
228 dyn_flags <- readIORef v_InitDynFlags
229 writeIORef v_DynFlags dyn_flags
230 leftovers <- processArgs dynamic_flags leftovers []
231 dyn_flags <- readIORef v_DynFlags
232 writeIORef v_InitDynFlags dyn_flags
233 if (not (null leftovers))
234 then throwDyn (OtherError ("unrecognised flags: " ++
239 typeOfExpr :: String -> GHCi ()
241 = do st <- getGHCiState
242 dflags <- io (getDynFlags)
243 (st, maybe_ty) <- io (cmTypeExpr (cmstate st) dflags
244 (current_module st) str)
247 Just (unqual, ty) -> io (printForUser stdout unqual (ppr ty))
249 quit :: String -> GHCi ()
252 shellEscape :: String -> GHCi ()
253 shellEscape str = io (system str >> return ())
255 -----------------------------------------------------------------------------
258 data GHCiState = GHCiState
260 modules :: [ModuleName],
261 current_module :: ModuleName,
262 target :: Maybe FilePath,
266 defaultCurrentModule = mkModuleName "Prelude"
268 newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
270 instance Monad GHCi where
271 (GHCi m) >>= k = GHCi $ \s -> m s >>= \(s,a) -> unGHCi (k a) s
272 return a = GHCi $ \s -> return (s,a)
274 getGHCiState = GHCi $ \s -> return (s,s)
275 setGHCiState s = GHCi $ \_ -> return (s,())
277 io m = GHCi $ \s -> m >>= \a -> return (s,a)
279 ghciHandle h (GHCi m) = GHCi $ \s ->
280 Exception.catch (m s) (\e -> unGHCi (h e) s)
281 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
282 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
284 -----------------------------------------------------------------------------
287 linkPackages :: [Package] -> IO ()
288 linkPackages pkgs = mapM_ linkPackage pkgs
290 linkPackage :: Package -> IO ()
291 -- ignore rts and gmp for now (ToDo; better?)
292 linkPackage pkg | name pkg `elem` ["rts", "gmp"] = return ()
294 putStr ("Loading package " ++ name pkg ++ " ... ")
295 let dirs = library_dirs pkg
296 let objs = map (++".o") (hs_libraries pkg ++ extra_libraries pkg)
297 mapM (linkOneObj dirs) objs
298 putStr "resolving ... "
302 linkOneObj dirs obj = do
303 filename <- findFile dirs obj
306 findFile [] obj = throwDyn (OtherError ("can't find " ++ obj))
307 findFile (d:ds) obj = do
308 let path = d ++ '/':obj
309 b <- doesFileExist path
310 if b then return path else findFile ds obj