Add :run and tweak :main

[ghc-hetmet.git] / compiler / ghci / InteractiveUI.hs

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index e4439d6..73b1e47 100644 (file)
--- a/compiler/ghci/InteractiveUI.hs
+++ b/compiler/ghci/InteractiveUI.hs
@@ -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

@@ -137,6 +138,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 +160,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 +177,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 +211,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" ++

@@ -299,13 +310,15 @@ interactiveUI session srcs maybe_expr = do
         hSetBuffering stdin NoBuffering
 
 #ifdef USE_READLINE
         hSetBuffering stdin NoBuffering
 
 #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
-        Readline.setCompletionAppendCharacter Nothing
+        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
 #endif
 
    -- initial context is just the Prelude

@@ -844,9 +857,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

@@ -1391,27 +1417,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

@@ -2132,9 +2163,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 ()