-----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.35 2001/02/08 14:58:28 simonmar Exp $
+-- $Id: InteractiveUI.hs,v 1.40 2001/02/09 17:29:59 simonmar Exp $
--
-- GHC Interactive User Interface
--
import Util
import PprType {- instance Outputable Type; do not delete -}
import Panic ( GhcException(..) )
+import Config
import Exception
+import Dynamic
#ifndef NO_READLINE
import Readline
#endif
-----------------------------------------------------------------------------
ghciWelcomeMsg = "\
-\ _____ __ __ ____ _________________________________________________\n\
-\(| || || (| |) GHC Interactive, version 5.00 \n\
-\|| __ ||___|| || () For Haskell 98. \n\
-\|| |) ||---|| || || http://www.haskell.org/ghc \n\
-\|| || || || || (| Bug reports to: glasgow-haskell-bugs@haskell.org \n\
-\(|___|| || || (|__|) \\\\______________________________________________________\n"
+\ ___ ___ _\n\
+\ / _ \\ /\\ /\\/ __(_)\n\
+\ / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", For Haskell 98.\n\
+\/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n\
+\\\____/\\/ /_/\\____/|_| Type :? for help.\n"
commands :: [(String, String -> GHCi Bool)]
commands = [
-- and carries on.
runCommand :: String -> GHCi Bool
runCommand c =
- ghciHandle (
- \other_exception
- -> io (do putStrLn ("*** Exception: " ++ show other_exception)
- return False)
- ) $
- ghciHandleDyn
- (\dyn -> case dyn of
- PhaseFailed phase code ->
+ ghciHandle ( \exception ->
+ (case exception of
+ DynException dyn ->
+ case fromDynamic dyn of
+ Nothing -> io (putStrLn ("*** Exception: (unknown)"))
+ Just ghc_ex ->
+ case ghc_ex of
+ PhaseFailed phase code ->
io ( putStrLn ("Phase " ++ phase ++ " failed (code "
++ show code ++ ")"))
- Interrupted -> io (putStrLn "Interrupted.")
- _ -> io (putStrLn (show (dyn :: GhcException)))
- >> return False
- ) $
+ Interrupted -> io (putStrLn "Interrupted.")
+ other -> io (putStrLn (show (ghc_ex :: GhcException)))
+
+ other -> io (putStrLn ("*** Exception: " ++ show exception))
+
+ ) >> return False
+ ) $
+
doCommand c
doCommand (':' : command) = specialCommand command
io m = GHCi $ \s -> m >>= \a -> return (s,a)
+-----------------------------------------------------------------------------
-- recursive exception handlers
+
+-- Don't forget to unblock async exceptions in the handler, or if we're
+-- in an exception loop (eg. let a = error a in a) the ^C exception
+-- may never be delivered. Thanks to Marcin for pointing out the bug.
+
ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
ghciHandle h (GHCi m) = GHCi $ \s ->
- Exception.catch (m s) (\e -> unGHCi (ghciHandle h (h e)) s)
+ Exception.catch (m s)
+ (\e -> unGHCi (ghciHandle h (ghciUnblock (h e))) s)
-ghciHandleDyn h (GHCi m) = GHCi $ \s ->
- Exception.catchDyn (m s) (\e -> unGHCi (ghciHandleDyn h (h e)) s)
+ghciUnblock :: GHCi a -> GHCi a
+ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
-----------------------------------------------------------------------------
-- package loader