FIX BUILD: remove accidentally committed hunk

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

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index 77acf89..1ac2df8 100644 (file)
--- a/compiler/ghci/InteractiveUI.hs
+++ b/compiler/ghci/InteractiveUI.hs
@@ -74,6 +74,7 @@ import Data.Char
 import Data.Dynamic
 import Data.Array
 import Control.Monad as Monad
 import Data.Dynamic
 import Data.Array
 import Control.Monad as Monad

+import Text.Printf

 
 import Foreign.StablePtr       ( newStablePtr )
 import GHC.Exts                ( unsafeCoerce# )
 
 import Foreign.StablePtr       ( newStablePtr )
 import GHC.Exts                ( unsafeCoerce# )

@@ -108,7 +109,7 @@ builtin_commands = [
   ("browse",    keepGoing browseCmd,           False, completeModule),
   ("cd",       keepGoing changeDirectory,      False, completeFilename),
   ("check",    keepGoing checkModule,          False, completeHomeModule),
   ("browse",    keepGoing browseCmd,           False, completeModule),
   ("cd",       keepGoing changeDirectory,      False, completeFilename),
   ("check",    keepGoing checkModule,          False, completeHomeModule),

-  ("continue",  continueCmd,                    False, completeNone),
+  ("continue",  keepGoing continueCmd,          False, completeNone),

   ("ctags",    keepGoing createCTagsFileCmd,   False, completeFilename),
   ("def",      keepGoing defineMacro,          False, completeIdentifier),
   ("delete",    keepGoing deleteCmd,            False, completeNone),
   ("ctags",    keepGoing createCTagsFileCmd,   False, completeFilename),
   ("def",      keepGoing defineMacro,          False, completeIdentifier),
   ("delete",    keepGoing deleteCmd,            False, completeNone),

@@ -131,9 +132,9 @@ builtin_commands = [
   ("set",      keepGoing setCmd,               True,  completeSetOptions),
   ("show",     keepGoing showCmd,              False, completeNone),
   ("sprint",    keepGoing sprintCmd,            False, completeIdentifier),
   ("set",      keepGoing setCmd,               True,  completeSetOptions),
   ("show",     keepGoing showCmd,              False, completeNone),
   ("sprint",    keepGoing sprintCmd,            False, completeIdentifier),

-  ("step",      stepCmd,                        False, completeIdentifier), 
+  ("step",      keepGoing stepCmd,              False, completeIdentifier), 

   ("type",     keepGoing typeOfExpr,           False, completeIdentifier),
   ("type",     keepGoing typeOfExpr,           False, completeIdentifier),

-  ("trace",     traceCmd,                       False, completeIdentifier), 
+  ("trace",     keepGoing traceCmd,             False, completeIdentifier), 

   ("undef",     keepGoing undefineMacro,       False, completeMacro),
   ("unset",    keepGoing unsetOptions,         True,  completeSetOptions)
   ]
   ("undef",     keepGoing undefineMacro,       False, completeMacro),
   ("unset",    keepGoing unsetOptions,         True,  completeSetOptions)
   ]

@@ -149,31 +150,48 @@ shortHelpText = "use :? for help.\n"
 helpText =
  " Commands available from the prompt:\n" ++
  "\n" ++
 helpText =
  " Commands available from the prompt:\n" ++
  "\n" ++

- "   <stmt>                      evaluate/run <stmt>\n" ++
+ "   <statement>                 evaluate/run <statement>\n" ++

  "   :add <filename> ...         add module(s) to the current target set\n" ++
  "   :add <filename> ...         add module(s) to the current target set\n" ++

- "   :abandon                    at a breakpoint, abandon current computation\n" ++
- "   :break [<mod>] <l> [<col>]  set a breakpoint at the specified location\n" ++
- "   :break <name>               set a breakpoint on the specified function\n" ++

  "   :browse [*]<module>         display the names defined by <module>\n" ++
  "   :cd <dir>                   change directory to <dir>\n" ++
  "   :browse [*]<module>         display the names defined by <module>\n" ++
  "   :cd <dir>                   change directory to <dir>\n" ++

- "   :continue                   resume after a breakpoint\n" ++

  "   :ctags [<file>]             create tags file for Vi (default: \"tags\")\n" ++
  "   :def <cmd> <expr>           define a command :<cmd>\n" ++
  "   :ctags [<file>]             create tags file for Vi (default: \"tags\")\n" ++
  "   :def <cmd> <expr>           define a command :<cmd>\n" ++

- "   :delete <number>            delete the specified breakpoint\n" ++
- "   :delete *                   delete all breakpoints\n" ++

  "   :edit <file>                edit file\n" ++
  "   :edit                       edit last module\n" ++
  "   :etags [<file>]             create tags file for Emacs (default: \"TAGS\")\n" ++
  "   :edit <file>                edit file\n" ++
  "   :edit                       edit last module\n" ++
  "   :etags [<file>]             create tags file for Emacs (default: \"TAGS\")\n" ++

--- "   :force <expr>               print <expr>, forcing unevaluated parts\n" ++

  "   :help, :?                   display this list of commands\n" ++
  "   :info [<name> ...]          display information about the given names\n" ++
  "   :kind <type>                show the kind of <type>\n" ++
  "   :load <filename> ...        load module(s) and their dependents\n" ++
  "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
  "   :main [<arguments> ...]     run the main function with the given arguments\n" ++
  "   :help, :?                   display this list of commands\n" ++
  "   :info [<name> ...]          display information about the given names\n" ++
  "   :kind <type>                show the kind of <type>\n" ++
  "   :load <filename> ...        load module(s) and their dependents\n" ++
  "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
  "   :main [<arguments> ...]     run the main function with the given arguments\n" ++

- "   :print [<name> ...]         prints a value without forcing its computation\n" ++

  "   :quit                       exit GHCi\n" ++
  "   :reload                     reload the current module set\n" ++
  "   :quit                       exit GHCi\n" ++
  "   :reload                     reload the current module set\n" ++

+ "   :type <expr>                show the type of <expr>\n" ++
+ "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++
+ "   :!<command>                 run the shell command <command>\n" ++
+ "\n" ++
+ " -- Commands for debugging:\n" ++
+ "\n" ++
+ "   :abandon                    at a breakpoint, abandon current computation\n" ++
+ "   :back                       go back in the history (after :trace)\n" ++
+ "   :break [<mod>] <l> [<col>]  set a breakpoint at the specified location\n" ++
+ "   :break <name>               set a breakpoint on the specified function\n" ++
+ "   :continue                   resume after a breakpoint\n" ++
+ "   :delete <number>            delete the specified breakpoint\n" ++
+ "   :delete *                   delete all breakpoints\n" ++
+ "   :force <expr>               print <expr>, forcing unevaluated parts\n" ++
+ "   :forward                    go forward in the history (after :back)\n" ++
+ "   :history [<n>]              show the last <n> items in the history (after :trace)\n" ++
+ "   :print [<name> ...]         prints a value without forcing its computation\n" ++
+ "   :step                       single-step after stopping at a breakpoint\n"++
+ "   :step <expr>                single-step into <expr>\n"++
+ "   :trace                      trace after stopping at a breakpoint\n"++
+ "   :trace <expr>               trace into <expr> (remembers breakpoints for :history)\n"++
+ "   :sprint [<name> ...]        simplifed version of :print\n" ++
+
+ "\n" ++
+ " -- Commands for changing settings:\n" ++

  "\n" ++
  "   :set <option> ...           set options\n" ++
  "   :set args <arg> ...         set the arguments returned by System.getArgs\n" ++
  "\n" ++
  "   :set <option> ...           set options\n" ++
  "   :set args <arg> ...         set the arguments returned by System.getArgs\n" ++

@@ -181,29 +199,24 @@ helpText =
  "   :set prompt <prompt>        set the prompt used in GHCi\n" ++
  "   :set editor <cmd>           set the command used for :edit\n" ++
  "   :set stop <cmd>             set the command to run when a breakpoint is hit\n" ++
  "   :set prompt <prompt>        set the prompt used in GHCi\n" ++
  "   :set editor <cmd>           set the command used for :edit\n" ++
  "   :set stop <cmd>             set the command to run when a breakpoint is hit\n" ++

- "\n" ++
- "   :show breaks                show active breakpoints\n" ++
- "   :show context               show the breakpoint context\n" ++
- "   :show modules               show the currently loaded modules\n" ++
- "   :show bindings              show the current bindings made at the prompt\n" ++
- "\n" ++
- "   :sprint [<name> ...]        simplifed version of :print\n" ++
- "   :step                       single-step after stopping at a breakpoint\n"++
- "   :step <expr>                single-step into <expr>\n"++
- "   :type <expr>                show the type of <expr>\n" ++
- "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++

  "   :unset <option> ...         unset options\n" ++
  "   :unset <option> ...         unset options\n" ++

- "   :!<command>                 run the shell command <command>\n" ++

  "\n" ++
  "\n" ++

- " Options for ':set' and ':unset':\n" ++
+ "  Options for ':set' and ':unset':\n" ++

  "\n" ++
  "    +r            revert top-level expressions after each evaluation\n" ++
  "    +s            print timing/memory stats after each evaluation\n" ++
  "    +t            print type after evaluation\n" ++
  "    -<flags>      most GHC command line flags can also be set here\n" ++
  "                         (eg. -v2, -fglasgow-exts, etc.)\n" ++
  "\n" ++
  "    +r            revert top-level expressions after each evaluation\n" ++
  "    +s            print timing/memory stats after each evaluation\n" ++
  "    +t            print type after evaluation\n" ++
  "    -<flags>      most GHC command line flags can also be set here\n" ++
  "                         (eg. -v2, -fglasgow-exts, etc.)\n" ++

+ "\n" ++
+ " -- Commands for displaying information:\n" ++
+ "\n" ++
+ "   :show bindings              show the current bindings made at the prompt\n" ++
+ "   :show breaks                show the active breakpoints\n" ++
+ "   :show context               show the breakpoint context\n" ++
+ "   :show modules               show the currently loaded modules\n" ++
+ "   :show <setting>             show anything that can be set with :set (e.g. args)\n" ++

  "\n" 
  "\n" 

--- Todo: add help for breakpoint commands here

 
 findEditor = do
   getEnv "EDITOR" 
 
 findEditor = do
   getEnv "EDITOR" 

@@ -781,6 +794,7 @@ loadModule' files = do
   session <- getSession
 
   -- unload first
   session <- getSession
 
   -- unload first

+  discardActiveBreakPoints

   io (GHC.setTargets session [])
   io (GHC.load session LoadAllTargets)
 
   io (GHC.setTargets session [])
   io (GHC.load session LoadAllTargets)
 

@@ -796,9 +810,7 @@ loadModule' files = do
   -- as a ToDo for now.
 
   io (GHC.setTargets session targets)
   -- as a ToDo for now.
 
   io (GHC.setTargets session targets)

-  ok <- io (GHC.load session LoadAllTargets)
-  afterLoad ok session
-  return ok
+  doLoad session LoadAllTargets

 
 checkModule :: String -> GHCi ()
 checkModule m = do
 
 checkModule :: String -> GHCi ()
 checkModule m = do

@@ -821,19 +833,28 @@ checkModule m = do
 reloadModule :: String -> GHCi ()
 reloadModule "" = do
   io (revertCAFs)              -- always revert CAFs on reload.
 reloadModule :: String -> GHCi ()
 reloadModule "" = do
   io (revertCAFs)              -- always revert CAFs on reload.

+  discardActiveBreakPoints

   session <- getSession
   session <- getSession

-  ok <- io (GHC.load session LoadAllTargets)
-  afterLoad ok session
+  doLoad session LoadAllTargets
+  return ()

 reloadModule m = do
   io (revertCAFs)              -- always revert CAFs on reload.
 reloadModule m = do
   io (revertCAFs)              -- always revert CAFs on reload.

+  discardActiveBreakPoints

   session <- getSession
   session <- getSession

-  ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
+  doLoad session (LoadUpTo (GHC.mkModuleName m))
+  return ()
+
+doLoad session howmuch = do
+  -- turn off breakpoints before we load: we can't turn them off later, because
+  -- the ModBreaks will have gone away.
+  discardActiveBreakPoints
+  ok <- io (GHC.load session howmuch)

   afterLoad ok session
   afterLoad ok session

+  return ok

 
 afterLoad ok session = do
   io (revertCAFs)  -- always revert CAFs on load.
   discardTickArrays
 
 afterLoad ok session = do
   io (revertCAFs)  -- always revert CAFs on load.
   discardTickArrays

-  discardActiveBreakPoints

   graph <- io (GHC.getModuleGraph session)
   graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
   setContextAfterLoad session graph'
   graph <- io (GHC.getModuleGraph session)
   graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
   setContextAfterLoad session graph'

@@ -1079,8 +1100,10 @@ setOptions wds =
    do -- first, deal with the GHCi opts (+s, +t, etc.)
       let (plus_opts, minus_opts)  = partition isPlus wds
       mapM_ setOpt plus_opts
    do -- first, deal with the GHCi opts (+s, +t, etc.)
       let (plus_opts, minus_opts)  = partition isPlus wds
       mapM_ setOpt plus_opts

-

       -- then, dynamic flags
       -- then, dynamic flags

+      newDynFlags minus_opts
+
+newDynFlags minus_opts = do

       dflags <- getDynFlags
       let pkg_flags = packageFlags dflags
       (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
       dflags <- getDynFlags
       let pkg_flags = packageFlags dflags
       (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts

@@ -1118,10 +1141,11 @@ unsetOptions str
 
        mapM_ unsetOpt plus_opts
  
 
        mapM_ unsetOpt plus_opts
  

-       -- can't do GHC flags for now
-       if (not (null minus_opts))
-         then throwDyn (CmdLineError "can't unset GHC command-line flags")
-         else return ()
+       let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
+           no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f))
+
+       no_flags <- mapM no_flag minus_opts
+       newDynFlags no_flags

 
 isMinus ('-':s) = True
 isMinus _ = False
 
 isMinus ('-':s) = True
 isMinus _ = False

@@ -1153,14 +1177,20 @@ optToStr RevertCAFs = "r"
 -- ---------------------------------------------------------------------------
 -- code for `:show'
 
 -- ---------------------------------------------------------------------------
 -- code for `:show'
 

-showCmd str =
+showCmd str = do
+  st <- getGHCiState

   case words str of
   case words str of

+        ["args"]     -> io $ putStrLn (show (args st))
+        ["prog"]     -> io $ putStrLn (show (progname st))
+        ["prompt"]   -> io $ putStrLn (show (prompt st))
+        ["editor"]   -> io $ putStrLn (show (editor st))
+        ["stop"]     -> io $ putStrLn (show (stop st))

        ["modules" ] -> showModules
        ["bindings"] -> showBindings
        ["linker"]   -> io showLinkerState
        ["modules" ] -> showModules
        ["bindings"] -> showBindings
        ["linker"]   -> io showLinkerState

-        ["breaks"] -> showBkptTable
-        ["context"] -> showContext
-       _ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings|breaks]")
+        ["breaks"]   -> showBkptTable
+        ["context"]  -> showContext
+       _ -> throwDyn (CmdLineError "syntax:  :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")

 
 showModules = do
   session <- getSession
 
 showModules = do
   session <- getSession

@@ -1438,26 +1468,23 @@ pprintCommand bind force str = do
   session <- getSession
   io $ pprintClosureCommand session bind force str
 
   session <- getSession
   io $ pprintClosureCommand session bind force str
 

-stepCmd :: String -> GHCi Bool
+stepCmd :: String -> GHCi ()

 stepCmd []         = doContinue GHC.SingleStep
 stepCmd []         = doContinue GHC.SingleStep

-stepCmd expression = runStmt expression GHC.SingleStep
+stepCmd expression = do runStmt expression GHC.SingleStep; return ()

 
 

-traceCmd :: String -> GHCi Bool
+traceCmd :: String -> GHCi ()

 traceCmd []         = doContinue GHC.RunAndLogSteps
 traceCmd []         = doContinue GHC.RunAndLogSteps

-traceCmd expression = runStmt expression GHC.RunAndLogSteps
+traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()

 
 

-continueCmd :: String -> GHCi Bool
-continueCmd [] = doContinue GHC.RunToCompletion
-continueCmd other = do
-   io $ putStrLn "The continue command accepts no arguments."
-   return False
+continueCmd :: String -> GHCi ()
+continueCmd = noArgs $ doContinue GHC.RunToCompletion

 
 

-doContinue :: SingleStep -> GHCi Bool
+doContinue :: SingleStep -> GHCi ()

 doContinue step = do 
   session <- getSession
   runResult <- io $ GHC.resume session step
   afterRunStmt runResult
 doContinue step = do 
   session <- getSession
   runResult <- io $ GHC.resume session step
   afterRunStmt runResult

-  return False
+  return ()

 
 abandonCmd :: String -> GHCi ()
 abandonCmd = noArgs $ do
 
 abandonCmd :: String -> GHCi ()
 abandonCmd = noArgs $ do

@@ -1484,15 +1511,23 @@ deleteCmd argLine = do
          | otherwise = return ()
 
 historyCmd :: String -> GHCi ()
          | otherwise = return ()
 
 historyCmd :: String -> GHCi ()

-historyCmd = noArgs $ do
-  s <- getSession
-  resumes <- io $ GHC.getResumeContext s
-  case resumes of
-    [] -> io $ putStrLn "Not stopped at a breakpoint"
-    (r:rs) -> do
-      let hist = GHC.resumeHistory r
-      spans <- mapM (io . GHC.getHistorySpan s) hist
-      printForUser (vcat (map ppr spans))
+historyCmd arg
+  | null arg        = history 20
+  | all isDigit arg = history (read arg)
+  | otherwise       = io $ putStrLn "Syntax:  :history [num]"
+  where
+  history num = do
+    s <- getSession
+    resumes <- io $ GHC.getResumeContext s
+    case resumes of
+      [] -> io $ putStrLn "Not stopped at a breakpoint"
+      (r:rs) -> do
+        let hist = GHC.resumeHistory r
+            (took,rest) = splitAt num hist
+        spans <- mapM (io . GHC.getHistorySpan s) took
+        let nums = map (printf "-%-3d:") [(1::Int)..]
+        printForUser (vcat (zipWith (<+>) (map text nums) (map ppr spans)))
+        io $ putStrLn $ if null rest then "<end of history>" else "..."

 
 backCmd :: String -> GHCi ()
 backCmd = noArgs $ do
 
 backCmd :: String -> GHCi ()
 backCmd = noArgs $ do

@@ -1763,7 +1798,7 @@ mkTickArray ticks
         [ (line, (nm,span)) | (nm,span) <- ticks,
                               line <- srcSpanLines span ]
     where
         [ (line, (nm,span)) | (nm,span) <- ticks,
                               line <- srcSpanLines span ]
     where

-        max_line = maximum (map GHC.srcSpanEndLine (map snd ticks))
+        max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))

         srcSpanLines span = [ GHC.srcSpanStartLine span .. 
                               GHC.srcSpanEndLine span ]
 
         srcSpanLines span = [ GHC.srcSpanStartLine span .. 
                               GHC.srcSpanEndLine span ]