Fix exception message with ghc -e
[ghc-hetmet.git] / compiler / ghci / InteractiveUI.hs
index 65693b3..afd9702 100644 (file)
@@ -54,6 +54,7 @@ import System.Posix hiding (getEnv)
 #else
 import GHC.ConsoleHandler ( flushConsole )
 import qualified System.Win32
 #else
 import GHC.ConsoleHandler ( flushConsole )
 import qualified System.Win32
+import System.FilePath
 #endif
 
 #ifdef USE_READLINE
 #endif
 
 #ifdef USE_READLINE
@@ -81,9 +82,10 @@ import Data.Array
 import Control.Monad as Monad
 import Text.Printf
 import Foreign
 import Control.Monad as Monad
 import Text.Printf
 import Foreign
-import Foreign.C        ( withCStringLen )
+import Foreign.C
 import GHC.Exts                ( unsafeCoerce# )
 import GHC.IOBase      ( IOErrorType(InvalidArgument) )
 import GHC.Exts                ( unsafeCoerce# )
 import GHC.IOBase      ( IOErrorType(InvalidArgument) )
+import GHC.TopHandler
 
 import Data.IORef      ( IORef, readIORef, writeIORef )
 
 
 import Data.IORef      ( IORef, readIORef, writeIORef )
 
@@ -137,6 +139,7 @@ builtin_commands = [
   ("print",     keepGoing printCmd,             Nothing, completeIdentifier),
   ("quit",     quit,                           Nothing, completeNone),
   ("reload",   keepGoing reloadModule,         Nothing, completeNone),
   ("print",     keepGoing printCmd,             Nothing, completeIdentifier),
   ("quit",     quit,                           Nothing, completeNone),
   ("reload",   keepGoing reloadModule,         Nothing, completeNone),
+  ("run",      keepGoing runRun,               Nothing, completeIdentifier),
   ("set",      keepGoing setCmd,               Just flagWordBreakChars, completeSetOptions),
   ("show",     keepGoing showCmd,              Nothing, completeNone),
   ("sprint",    keepGoing sprintCmd,            Nothing, completeIdentifier),
   ("set",      keepGoing setCmd,               Just flagWordBreakChars, completeSetOptions),
   ("show",     keepGoing showCmd,              Nothing, completeNone),
   ("sprint",    keepGoing sprintCmd,            Nothing, completeIdentifier),
@@ -158,11 +161,15 @@ builtin_commands = [
 -- 
 -- NOTE: in order for us to override the default correctly, any custom entry
 -- must be a SUBSET of word_break_chars.
 -- 
 -- NOTE: in order for us to override the default correctly, any custom entry
 -- must be a SUBSET of word_break_chars.
-word_break_chars, flagWordBreakChars, filenameWordBreakChars :: String
+#ifdef USE_READLINE
+word_break_chars :: String
 word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
                        specials = "(),;[]`{}"
                        spaces = " \t\n"
                    in spaces ++ specials ++ symbols
 word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
                        specials = "(),;[]`{}"
                        spaces = " \t\n"
                    in spaces ++ specials ++ symbols
+#endif
+
+flagWordBreakChars, filenameWordBreakChars :: String
 flagWordBreakChars = " \t\n"
 filenameWordBreakChars = " \t\n\\`@$><=;|&{(" -- bash defaults
 
 flagWordBreakChars = " \t\n"
 filenameWordBreakChars = " \t\n\\`@$><=;|&{(" -- bash defaults
 
@@ -171,7 +178,11 @@ keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
 keepGoing a str = a str >> return False
 
 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
 keepGoing a str = a str >> return False
 
 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
-keepGoingPaths a str = a (toArgs str) >> return False
+keepGoingPaths a str
+ = do case toArgs str of
+          Left err -> io (hPutStrLn stderr err)
+          Right args -> a args
+      return False
 
 shortHelpText :: String
 shortHelpText = "use :? for help.\n"
 
 shortHelpText :: String
 shortHelpText = "use :? for help.\n"
@@ -201,6 +212,7 @@ helpText =
  "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
  "   :quit                       exit GHCi\n" ++
  "   :reload                     reload the current module set\n" ++
  "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
  "   :quit                       exit GHCi\n" ++
  "   :reload                     reload the current module set\n" ++
+ "   :run function [<arguments> ...] run the function with the given arguments\n" ++
  "   :type <expr>                show the type of <expr>\n" ++
  "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++
  "   :!<command>                 run the shell command <command>\n" ++
  "   :type <expr>                show the type of <expr>\n" ++
  "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++
  "   :!<command>                 run the shell command <command>\n" ++
@@ -263,14 +275,15 @@ findEditor = do
   getEnv "EDITOR" 
     `IO.catch` \_ -> do
 #if mingw32_HOST_OS
   getEnv "EDITOR" 
     `IO.catch` \_ -> do
 #if mingw32_HOST_OS
-       win <- System.Win32.getWindowsDirectory
-       return (win `joinFileName` "notepad.exe")
+        win <- System.Win32.getWindowsDirectory
+        return (win </> "notepad.exe")
 #else
 #else
-       return ""
+        return ""
 #endif
 
 #endif
 
-interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
-interactiveUI session srcs maybe_expr = do
+interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe [String]
+              -> IO ()
+interactiveUI session srcs maybe_exprs = do
    -- HACK! If we happen to get into an infinite loop (eg the user
    -- types 'let x=x in x' at the prompt), then the thread will block
    -- on a blackhole, and become unreachable during GC.  The GC will
    -- HACK! If we happen to get into an infinite loop (eg the user
    -- types 'let x=x in x' at the prompt), then the thread will block
    -- on a blackhole, and become unreachable during GC.  The GC will
@@ -286,7 +299,7 @@ interactiveUI session srcs maybe_expr = do
     -- Initialise buffering for the *interpreted* I/O system
    initInterpBuffering session
 
     -- Initialise buffering for the *interpreted* I/O system
    initInterpBuffering session
 
-   when (isNothing maybe_expr) $ do
+   when (isNothing maybe_exprs) $ do
         -- Only for GHCi (not runghc and ghc -e):
 
         -- Turn buffering off for the compiled program's stdout/stderr
         -- Only for GHCi (not runghc and ghc -e):
 
         -- Turn buffering off for the compiled program's stdout/stderr
@@ -298,30 +311,33 @@ interactiveUI session srcs maybe_expr = do
         -- intended for the program, so unbuffer stdin.
         hSetBuffering stdin NoBuffering
 
         -- intended for the program, so unbuffer stdin.
         hSetBuffering stdin NoBuffering
 
-        -- initial context is just the Prelude
+#ifdef USE_READLINE
+        is_tty <- hIsTerminalDevice stdin
+        when is_tty $ do
+            Readline.initialize
+            Readline.setAttemptedCompletionFunction (Just completeWord)
+            --Readline.parseAndBind "set show-all-if-ambiguous 1"
+
+            Readline.setBasicWordBreakCharacters word_break_chars
+            Readline.setCompleterWordBreakCharacters word_break_chars
+            Readline.setCompletionAppendCharacter Nothing
+#endif
+
+   -- initial context is just the Prelude
    prel_mod <- GHC.findModule session (GHC.mkModuleName "Prelude") 
                                       (Just basePackageId)
    GHC.setContext session [] [prel_mod]
 
    prel_mod <- GHC.findModule session (GHC.mkModuleName "Prelude") 
                                       (Just basePackageId)
    GHC.setContext session [] [prel_mod]
 
-#ifdef USE_READLINE
-   Readline.initialize
-   Readline.setAttemptedCompletionFunction (Just completeWord)
-   --Readline.parseAndBind "set show-all-if-ambiguous 1"
-
-   Readline.setBasicWordBreakCharacters word_break_chars
-   Readline.setCompleterWordBreakCharacters word_break_chars
-#endif
-
    default_editor <- findEditor
 
    default_editor <- findEditor
 
-   startGHCi (runGHCi srcs maybe_expr)
-       GHCiState{ progname = "<interactive>",
-                  args = [],
+   startGHCi (runGHCi srcs maybe_exprs)
+        GHCiState{ progname = "<interactive>",
+                   args = [],
                    prompt = "%s> ",
                    stop = "",
                    prompt = "%s> ",
                    stop = "",
-                  editor = default_editor,
-                  session = session,
-                  options = [],
+                   editor = default_editor,
+                   session = session,
+                   options = [],
                    prelude = prel_mod,
                    break_ctr = 0,
                    breaks = [],
                    prelude = prel_mod,
                    break_ctr = 0,
                    breaks = [],
@@ -337,8 +353,8 @@ interactiveUI session srcs maybe_expr = do
 
    return ()
 
 
    return ()
 
-runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
-runGHCi paths maybe_expr = do
+runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
+runGHCi paths maybe_exprs = do
   let read_dot_files = not opt_IgnoreDotGhci
 
   when (read_dot_files) $ do
   let read_dot_files = not opt_IgnoreDotGhci
 
   when (read_dot_files) $ do
@@ -349,35 +365,35 @@ runGHCi paths maybe_expr = do
        dir_ok  <- io (checkPerms ".")
        file_ok <- io (checkPerms file)
        when (dir_ok && file_ok) $ do
        dir_ok  <- io (checkPerms ".")
        file_ok <- io (checkPerms file)
        when (dir_ok && file_ok) $ do
-         either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
-         case either_hdl of
-            Left _e   -> return ()
-            Right hdl -> runCommands (fileLoop hdl False False)
-    
+          either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
+          case either_hdl of
+             Left _e   -> return ()
+             Right hdl -> runCommands (fileLoop hdl False False)
+
   when (read_dot_files) $ do
     -- Read in $HOME/.ghci
     either_dir <- io (IO.try getHomeDirectory)
     case either_dir of
        Left _e -> return ()
        Right dir -> do
   when (read_dot_files) $ do
     -- Read in $HOME/.ghci
     either_dir <- io (IO.try getHomeDirectory)
     case either_dir of
        Left _e -> return ()
        Right dir -> do
-         cwd <- io (getCurrentDirectory)
-         when (dir /= cwd) $ do
-            let file = dir ++ "/.ghci"
-            ok <- io (checkPerms file)
-            when ok $ do
-              either_hdl <- io (IO.try (openFile file ReadMode))
-              case either_hdl of
-                 Left _e   -> return ()
-                 Right hdl -> runCommands (fileLoop hdl False False)
+          cwd <- io (getCurrentDirectory)
+          when (dir /= cwd) $ do
+             let file = dir ++ "/.ghci"
+             ok <- io (checkPerms file)
+             when ok $ do
+               either_hdl <- io (IO.try (openFile file ReadMode))
+               case either_hdl of
+                  Left _e   -> return ()
+                  Right hdl -> runCommands (fileLoop hdl False False)
 
   -- Perform a :load for files given on the GHCi command line
   -- When in -e mode, if the load fails then we want to stop
   -- immediately rather than going on to evaluate the expression.
   when (not (null paths)) $ do
 
   -- Perform a :load for files given on the GHCi command line
   -- When in -e mode, if the load fails then we want to stop
   -- immediately rather than going on to evaluate the expression.
   when (not (null paths)) $ do
-     ok <- ghciHandle (\e -> do showException e; return Failed) $ 
-               loadModule paths
-     when (isJust maybe_expr && failed ok) $
-       io (exitWith (ExitFailure 1))
+     ok <- ghciHandle (\e -> do showException e; return Failed) $
+                loadModule paths
+     when (isJust maybe_exprs && failed ok) $
+        io (exitWith (ExitFailure 1))
 
   -- if verbosity is greater than 0, or we are connected to a
   -- terminal, display the prompt in the interactive loop.
 
   -- if verbosity is greater than 0, or we are connected to a
   -- terminal, display the prompt in the interactive loop.
@@ -385,7 +401,7 @@ runGHCi paths maybe_expr = do
   dflags <- getDynFlags
   let show_prompt = verbosity dflags > 0 || is_tty
 
   dflags <- getDynFlags
   let show_prompt = verbosity dflags > 0 || is_tty
 
-  case maybe_expr of
+  case maybe_exprs of
         Nothing ->
           do
 #if defined(mingw32_HOST_OS)
         Nothing ->
           do
 #if defined(mingw32_HOST_OS)
@@ -401,15 +417,25 @@ runGHCi paths maybe_expr = do
 #endif
             -- enter the interactive loop
             interactiveLoop is_tty show_prompt
 #endif
             -- enter the interactive loop
             interactiveLoop is_tty show_prompt
-        Just expr -> do
+        Just exprs -> do
             -- just evaluate the expression we were given
             -- just evaluate the expression we were given
-            runCommandEval expr
-            return ()
+            enqueueCommands exprs
+            let handle e = do st <- getGHCiState
+                                   -- Jump through some hoops to get the
+                                   -- current progname in the exception text:
+                                   -- <progname>: <exception>
+                              io $ withProgName (progname st)
+                                   -- The "fast exit" part just calls exit()
+                                   -- directly instead of doing an orderly
+                                   -- runtime shutdown, otherwise the main
+                                   -- GHCi thread will complain about being
+                                   -- interrupted.
+                                 $ topHandlerFastExit e
+            runCommands' handle (return Nothing)
 
   -- and finally, exit
   io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
 
 
   -- and finally, exit
   io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
 
-
 interactiveLoop :: Bool -> Bool -> GHCi ()
 interactiveLoop is_tty show_prompt =
   -- Ignore ^C exceptions caught here
 interactiveLoop :: Bool -> Bool -> GHCi ()
 interactiveLoop is_tty show_prompt =
   -- Ignore ^C exceptions caught here
@@ -580,14 +606,18 @@ queryQueue = do
                return (Just c)
 
 runCommands :: GHCi (Maybe String) -> GHCi ()
                return (Just c)
 
 runCommands :: GHCi (Maybe String) -> GHCi ()
-runCommands getCmd = do
+runCommands = runCommands' handler
+
+runCommands' :: (Exception -> GHCi Bool) -- Exception handler
+             -> GHCi (Maybe String) -> GHCi ()
+runCommands' eh getCmd = do
   mb_cmd <- noSpace queryQueue
   mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
   case mb_cmd of 
     Nothing -> return ()
     Just c  -> do
   mb_cmd <- noSpace queryQueue
   mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
   case mb_cmd of 
     Nothing -> return ()
     Just c  -> do
-      b <- ghciHandle handler (doCommand c)
-      if b then return () else runCommands getCmd
+      b <- ghciHandle eh (doCommand c)
+      if b then return () else runCommands' eh getCmd
   where
     noSpace q = q >>= maybe (return Nothing)
                             (\c->case removeSpaces c of 
   where
     noSpace q = q >>= maybe (return Nothing)
                             (\c->case removeSpaces c of 
@@ -628,24 +658,6 @@ enqueueCommands cmds = do
   setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
 
 
   setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
 
 
--- This version is for the GHC command-line option -e.  The only difference
--- from runCommand is that it catches the ExitException exception and
--- exits, rather than printing out the exception.
-runCommandEval :: String -> GHCi Bool
-runCommandEval c = ghciHandle handleEval (doCommand c)
-  where 
-    handleEval (ExitException code) = io (exitWith code)
-    handleEval e                    = do handler e
-                                        io (exitWith (ExitFailure 1))
-
-    doCommand (':' : command) = specialCommand command
-    doCommand stmt
-       = do r <- runStmt stmt GHC.RunToCompletion
-           case r of 
-               False -> io (exitWith (ExitFailure 1))
-                 -- failure to run the command causes exit(1) for ghc -e.
-               _       -> return True
-
 runStmt :: String -> SingleStep -> GHCi Bool
 runStmt stmt step
  | null (filter (not.isSpace) stmt) = return False
 runStmt :: String -> SingleStep -> GHCi Bool
 runStmt stmt step
  | null (filter (not.isSpace) stmt) = return False
@@ -843,9 +855,22 @@ pprInfo pefas (thing, fixity, insts)
        | otherwise                = ppr fix <+> ppr (GHC.getName thing)
 
 runMain :: String -> GHCi ()
        | otherwise                = ppr fix <+> ppr (GHC.getName thing)
 
 runMain :: String -> GHCi ()
-runMain args = do
-  let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
-  enqueueCommands  ['[': ss ++ "] `System.Environment.withArgs` main"]
+runMain s = case toArgs s of
+            Left err   -> io (hPutStrLn stderr err)
+            Right args ->
+                do dflags <- getDynFlags
+                   case mainFunIs dflags of
+                       Nothing -> doWithArgs args "main"
+                       Just f  -> doWithArgs args f
+
+runRun :: String -> GHCi ()
+runRun s = case toCmdArgs s of
+           Left err          -> io (hPutStrLn stderr err)
+           Right (cmd, args) -> doWithArgs args cmd
+
+doWithArgs :: [String] -> String -> GHCi ()
+doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
+                                       show args ++ " (" ++ cmd ++ ")"]
 
 addModule :: [FilePath] -> GHCi ()
 addModule files = do
 
 addModule :: [FilePath] -> GHCi ()
 addModule files = do
@@ -1390,27 +1415,32 @@ setCmd ""
                 ,Opt_PrintEvldWithShow
                 ] 
 setCmd str
                 ,Opt_PrintEvldWithShow
                 ] 
 setCmd str
-  = case toArgs str of
-       ("args":args) -> setArgs args
-       ("prog":prog) -> setProg prog
-        ("prompt":_)  -> setPrompt (after 6)
-        ("editor":_)  -> setEditor (after 6)
-        ("stop":_)    -> setStop (after 4)
-       wds -> setOptions wds
-   where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
-
-setArgs, setProg, setOptions :: [String] -> GHCi ()
-setEditor, setStop, setPrompt :: String -> GHCi ()
+  = case getCmd str of
+    Right ("args",   rest) ->
+        case toArgs rest of
+            Left err -> io (hPutStrLn stderr err)
+            Right args -> setArgs args
+    Right ("prog",   rest) ->
+        case toArgs rest of
+            Right [prog] -> setProg prog
+            _ -> io (hPutStrLn stderr "syntax: :set prog <progname>")
+    Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest
+    Right ("editor", rest) -> setEditor $ dropWhile isSpace rest
+    Right ("stop",   rest) -> setStop   $ dropWhile isSpace rest
+    _ -> case toArgs str of
+         Left err -> io (hPutStrLn stderr err)
+         Right wds -> setOptions wds
+
+setArgs, setOptions :: [String] -> GHCi ()
+setProg, setEditor, setStop, setPrompt :: String -> GHCi ()
 
 setArgs args = do
   st <- getGHCiState
   setGHCiState st{ args = args }
 
 
 setArgs args = do
   st <- getGHCiState
   setGHCiState st{ args = args }
 
-setProg [prog] = do
+setProg prog = do
   st <- getGHCiState
   setGHCiState st{ progname = prog }
   st <- getGHCiState
   setGHCiState st{ progname = prog }
-setProg _ = do
-  io (hPutStrLn stderr "syntax: :set prog <progname>")
 
 setEditor cmd = do
   st <- getGHCiState
 
 setEditor cmd = do
   st <- getGHCiState
@@ -1699,7 +1729,18 @@ completeSetOptions w = do
   return (filter (w `isPrefixOf`) options)
     where options = "args":"prog":allFlags
 
   return (filter (w `isPrefixOf`) options)
     where options = "args":"prog":allFlags
 
-completeFilename = Readline.filenameCompletionFunction
+completeFilename w = do
+    ws <- Readline.filenameCompletionFunction w
+    case ws of
+        -- If we only found one result, and it's a directory, 
+        -- add a trailing slash.
+        [file] -> do
+                isDir <- expandPathIO file >>= doesDirectoryExist
+                if isDir && last file /= '/'
+                    then return [file ++ "/"]
+                    else return [file]
+        _ -> return ws
+                
 
 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
 
 
 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
 
@@ -1713,8 +1754,10 @@ wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]
 wrapCompleter fun w =  do
   strs <- fun w
   case strs of
 wrapCompleter fun w =  do
   strs <- fun w
   case strs of
-    []  -> return Nothing
-    [x] -> return (Just (x,[]))
+    []  -> Readline.setAttemptedCompletionOver True >> return Nothing
+    [x] -> -- Add a trailing space, unless it already has an appended slash.
+           let appended = if last x == '/' then x else x ++ " "
+           in return (Just (appended,[]))
     xs  -> case getCommonPrefix xs of
                ""   -> return (Just ("",xs))
                pref -> return (Just (pref,xs))
     xs  -> case getCommonPrefix xs of
                ""   -> return (Just ("",xs))
                pref -> return (Just (pref,xs))
@@ -1795,10 +1838,13 @@ ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
 -- Utils
 
 expandPath :: String -> GHCi String
 -- Utils
 
 expandPath :: String -> GHCi String
-expandPath path = 
+expandPath path = io (expandPathIO path)
+
+expandPathIO :: String -> IO String
+expandPathIO path = 
   case dropWhile isSpace path of
    ('~':d) -> do
   case dropWhile isSpace path of
    ('~':d) -> do
-       tilde <- io getHomeDirectory -- will fail if HOME not defined
+       tilde <- getHomeDirectory -- will fail if HOME not defined
        return (tilde ++ '/':d)
    other -> 
        return other
        return (tilde ++ '/':d)
    other -> 
        return other
@@ -2115,9 +2161,23 @@ listCmd :: String -> GHCi ()
 listCmd "" = do
    mb_span <- getCurrentBreakSpan
    case mb_span of
 listCmd "" = do
    mb_span <- getCurrentBreakSpan
    case mb_span of
-      Nothing  -> printForUser $ text "not stopped at a breakpoint; nothing to list"
-      Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
-                | otherwise              -> printForUser $ text "unable to list source for" <+> ppr span
+      Nothing ->
+          printForUser $ text "Not stopped at a breakpoint; nothing to list"
+      Just span
+       | GHC.isGoodSrcSpan span -> io $ listAround span True
+       | otherwise ->
+          do s <- getSession
+             resumes <- io $ GHC.getResumeContext s
+             case resumes of
+                 [] -> panic "No resumes"
+                 (r:_) ->
+                     do let traceIt = case GHC.resumeHistory r of
+                                      [] -> text "rerunning with :trace,"
+                                      _ -> empty
+                            doWhat = traceIt <+> text ":back then :list"
+                        printForUser (text "Unable to list source for" <+>
+                                      ppr span
+                                   $$ text "Try" <+> doWhat)
 listCmd str = list2 (words str)
 
 list2 :: [String] -> GHCi ()
 listCmd str = list2 (words str)
 
 list2 :: [String] -> GHCi ()